ftnlf

Check-in [524d1fe4c9]
Login

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

Overview
Comment:Merge "multi" version.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1:524d1fe4c99edc21b52c1f1cdd247577cbb56811
User & Date: vadim 2018-05-07 08:31:03
Context
2018-05-08
10:38
Factor out ftnlf library (need to test under Windows). check-in: a7938cc2b8 user: vadim tags: trunk
2018-05-07
08:31
Merge "multi" version. check-in: 524d1fe4c9 user: vadim tags: trunk
08:29
Loadable Fortran extensions. Leaf check-in: e31927db4e user: vadim tags: multi
2017-05-07
08:28
Fix stack problems. check-in: f2cb6dd5d5 user: vadim tags: trunk, ftnlf-v1
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to CMakeLists.txt.


1
2
3
4
5
6
7
..
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
..
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

cmake_minimum_required(VERSION 2.6)
project(ftnlf Fortran C)

# Prefer static
find_library(LUA_STATIC_LIB NAMES 
	liblua51.a liblua5.1.a liblua-5.1.a liblua.a
	lua51 lua5.1 lua-5.1 lua)
................................................................................
		set (FCFLAGS "-fp-model precise -xHOST -O2") 
	else()
		set (FCFLAGS "-fp-model precise -g -O0 -C -traceback")
	endif()
	set (FCFLAGS90 "-warn -ipo")
elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU")
	if(MINGW)
#		set (LFLAGS "-static-libgcc -static-libgfortran -Wl,-s")
		set (LFLAGS "-static-libgcc -static-libgfortran")
	else()		
		set (LFLAGS "")
	endif()
	if(CMAKE_BUILD_TYPE STREQUAL "Release")
		set (FCFLAGS "-O2 -march=native -mfpmath=sse")
	else()
		set (FCFLAGS "-g -O0 -fcheck=all -fbacktrace")
	endif()
	set (FCFLAGS90 "-Wall")
endif()

# gfortran does not respect current directory in INCLUDEs unless explicitly told to
include_directories(${LUA_INCLUDE_DIR} ${CMAKE_CURRENT_BINARY_DIR})
add_executable(genconf luaf/genconf.c)
................................................................................
add_custom_command(
	OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/luaf_conf.fi
	COMMAND genconf > luaf_conf.fi
	DEPENDS genconf
	)

set (src
    test.f90
    ftnlf.f90
	ftnlf_interp.f90
	luaf/luaf.f90
	luaf/luafe.f90
	${CMAKE_CURRENT_BINARY_DIR}/luaf_conf.fi
	)

add_executable(ftnlf_test ${src})
# Link static
>







 







|







|







 







|
|
|







1
2
3
4
5
6
7
8
..
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
..
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
# -*- indent-tabs-mode: t; tab-width: 2; -*-
cmake_minimum_required(VERSION 2.6)
project(ftnlf Fortran C)

# Prefer static
find_library(LUA_STATIC_LIB NAMES 
	liblua51.a liblua5.1.a liblua-5.1.a liblua.a
	lua51 lua5.1 lua-5.1 lua)
................................................................................
		set (FCFLAGS "-fp-model precise -xHOST -O2") 
	else()
		set (FCFLAGS "-fp-model precise -g -O0 -C -traceback")
	endif()
	set (FCFLAGS90 "-warn -ipo")
elseif(CMAKE_Fortran_COMPILER_ID STREQUAL "GNU")
	if(MINGW)
		#	set (LFLAGS "-static-libgcc -static-libgfortran -Wl,-s")
		set (LFLAGS "-static-libgcc -static-libgfortran")
	else()		
		set (LFLAGS "")
	endif()
	if(CMAKE_BUILD_TYPE STREQUAL "Release")
		set (FCFLAGS "-O2 -march=native -mfpmath=sse")
	else()
		set (FCFLAGS "-g -O0 -fcheck=all -fbacktrace -frecursive")
	endif()
	set (FCFLAGS90 "-Wall")
endif()

# gfortran does not respect current directory in INCLUDEs unless explicitly told to
include_directories(${LUA_INCLUDE_DIR} ${CMAKE_CURRENT_BINARY_DIR})
add_executable(genconf luaf/genconf.c)
................................................................................
add_custom_command(
	OUTPUT ${CMAKE_CURRENT_BINARY_DIR}/luaf_conf.fi
	COMMAND genconf > luaf_conf.fi
	DEPENDS genconf
	)

set (src
	test.f90
	ftnlf.f90
	ftnlf_fxcore.f90
	luaf/luaf.f90
	luaf/luafe.f90
	${CMAKE_CURRENT_BINARY_DIR}/luaf_conf.fi
	)

add_executable(ftnlf_test ${src})
# Link static

Changes to ftnlf.f90.

3
4
5
6
7
8
9
10

11
12
13


14
15
16
17


18

19
20
21
22
23
24
25
26
27
28
29
30
31












32
33
34
35
36
37
38
..
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70

71






72
73
74
75
76
77

78
79
80
81

82
83
84
85
86
87
88
89
90
91
92
93
94
95
...
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122






123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
















139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163






164
165

166
167
168
169
170
171
172
173
174














175
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
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
238
239
240
...
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
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
...
355
356
357
358
359
360
361
362
363
364
365
366

367
368




369




370
371
372
373
374
375




376
















377
378
379



380
381

382

383
384
385
386

387

388
389
390
391
392
393
394
395
396
397

398
399
400

401
402
403
404

405
406
407

408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425

426
427

































428
429
430
module ftnlf
    ! ForTraN Lua Functions -- interface module 
    use, intrinsic :: iso_c_binding, only: c_ptr, c_int
    use LuaF
    use luaFE
    implicit none
    private
    public :: ftnlf_init, ftnlf_done, luafun, luafunc, luacache


    type(c_ptr) :: L_st



contains
    ! Initialization EP
    function ftnlf_init(fname) result(r)
        use, intrinsic :: iso_c_binding, only: c_associated, c_funloc, c_null_ptr


        character(*), intent(in) :: fname

        logical :: r
        integer(4) :: res
    
        r = .false. ! Default
        ! Create Lua state
        L_st = luaL_newstate()

        if (.not. c_associated(L_st)) then
            write(0,103)
    103     format('Failed to initialize Lua.')
            return
        end if













        ! 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))
................................................................................
            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
        use, intrinsic :: iso_c_binding, only: c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        call lua_pop(L, 1)

        ! Initialize libraries
        call luaL_openlibs(L)

        ! Register Fortran functions for Lua
        call lua_register(L, F_C_STR('interp'), c_funloc(l_newintobj))

        






        r = 0
    end function linit1
    
    ! 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) :: 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
        if (lua_checkstack(L_st, 4) == 0) then
            ! Stack overflow, return
................................................................................
            call lua_pushcfunction(L_st, c_funloc(lfuncall1))
            ns = 3
        end if

        call lua_pushstring_f(L_st, tbl)
        call lua_pushstring_f(L_st, key)
        
        ! Push numeric args
        if (.not. pushargs(args)) then
            ! 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
    
    ! Call lua 'function' from BD (cached)
    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
















        integer(4) :: res, n
        
        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, 4) == 0) then
            ! Stack overflow, return
            return 
        end if
        
        ! Push function, string args
        ! 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 numeric args
        if (.not. pushargs(args)) then
            ! Pop previous args
            call lua_pop(L_st, 3)
            return
        endif
        






        ! Call Lua
        n = 2 + 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 luafunc















    ! Push arguments
    function pushargs(args) result(r)



        real(8), intent(in) :: args(:)

        logical :: r
        integer(4) :: i, n
        
        r = .false.


        n = size(args)





        ! The possibility of OOM condition is ignored here
        ! If such thing happens, user is already messed up





        if (lua_checkstack(L_st, n) == 0) then
            ! Stack overflow, return
            return 
        end if


        do i = 1, n
            call lua_pushnumber(L_st, args(i))
        enddo















        r = .true.










































    end function pushargs
        












































    ! Lua EP for evaluation of function from BD (two-level name)
    function lfuncall2(L) bind(C) result(r)
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        call gettbl2(L)
        call lfun_tail(L)
        r = 1
    end function lfuncall2

    ! Lua EP for evaluation of function from BD (one-level name)
    function lfuncall1(L) bind(C) result(r)
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        call gettbl1(L)
        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)
        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_REGISTRYINDEX)
        call lfun_checktbl(L, 'cached ')
        
        ! Remove table name
        call lua_remove(L, 1)
        
        call lfun_tail(L)
        r = 1
    end function lfuncallc

    ! Call lua 'function' from BD
    function luacache(tbldir, tbl, cname) result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in) :: tbldir
        character(*), intent(in) :: tbl, cname
................................................................................
    end function lcache1

    ! Fetch table from BD (two-level name)
    subroutine gettbl2(L)
        type(c_ptr) :: L

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

        ! Stack is now: tblname key arg1 ... argn tbldir
        ! Get table from tbldir
        call lua_pushvalue(L, 1)
        call lua_gettable(L, -2)
        call lfun_checktbl(L, 'table ')
        
        ! Remove table name
        call lua_remove(L, 1)
        ! Stack is now: key arg1 ... argn tbldir tbl
        ! Remove tbldir
        call lua_remove(L, -2)
        ! Stack is now: key arg1 ... argn tbl
    end subroutine gettbl2

    ! Fetch table from BD (one-level name)
    subroutine gettbl1(L)
        type(c_ptr) :: L

        ! 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 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

end module ftnlf







|
>



>
>


|

>
>

>

|











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







 







<









|
|
>
|
>
>
>
>
>
>






>


|
|
>



|
|

|







 







|
|





|
|
>
>
>
>
>
>
|



|
|

|
|
|
|
|




>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|





|











|
|





>
>
>
>
>
>

<
>
|



|
|

|

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

|


>
>
|
>
>
>
>
>


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

>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|

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






|
<








|
<








|

|








|
<







 







|

|








|







|


|







|

|







 







|
|
<
|
<
>

|
>
>
>
>

>
>
>
>
|





>
>
>
>

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


<
>
>
>
|
<
>

>


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


|
<
>
|
<
|
>

<
|
|
<
<
<
<


<
|
<
<
<


|
>
|
|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
|


3
4
5
6
7
8
9
10
11
12
13
14
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
45
46
47
48
49
50
51
52
53
54
55
56
..
70
71
72
73
74
75
76

77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
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
118
119
120
121
...
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
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
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
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
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384

385
386
387
388
389
390
391
392
393

394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413

414
415
416
417
418
419
420
...
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
...
535
536
537
538
539
540
541
542
543

544

545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585

586
587
588
589

590
591
592
593
594


595
596
597
598




599
600



601
602


603
604
605
606

607
608

609
610
611

612
613




614
615

616



617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
module ftnlf
    ! ForTraN Lua Functions -- interface module 
    use, intrinsic :: iso_c_binding, only: c_ptr, c_int
    use LuaF
    use luaFE
    implicit none
    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
        character(*), intent(in) :: fname
        type(luaFE_FunctionEntry), optional :: loadlist(:)
        logical :: r
        integer(4) :: res, nload
    
        r = .false. ! Default
        ! Create Lua state
        L_st = luaL_newstate()

        if (.not. c_associated(L_st)) then
            write(0,103)
    103     format('Failed to initialize Lua.')
            return
        end if

        ! initialize loaders
        if (present(loadlist)) then
            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
        
        ! The 2nd stage -- load database file
        res = luaL_dofile_r(L_st, F_C_STR(fname))
................................................................................
            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, intrinsic :: iso_c_binding, only: c_funloc
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        call lua_pop(L, 1)

        ! Initialize libraries
        call luaL_openlibs(L)

        ! Register FX modules
        call lua_getglobal(L, F_C_STR('package'))
        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)
        deallocate(fx_loaders)
    end subroutine ftnlf_done
    
    ! Call lua 'function' from BD, generic case
    function luafuna(tbldir, tbl, key, args, fvals, &
        & arr_i, arr_m, arr_o) result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in) :: tbldir
        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, ns, 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, 4) == 0) then
            ! Stack overflow, return
................................................................................
            call lua_pushcfunction(L_st, c_funloc(lfuncall1))
            ns = 3
        end if

        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, ns)
            return
        endif
        
        ! Number of arguments
        n = ns - 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 luafuna

    ! Call lua 'function' from BD, simplified interface
    function luafun(tbldir, tbl, key, args, fval) result(r)
        character(*), intent(in) :: tbldir
        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 = 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
            return 
        end if
        
        ! Push function, string args
        ! 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
        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.

        ! Sizes of arrays
        na = size(args)
        narr_i = size(arr_i)
        nv = size(fvals)
        narr_o = size(arr_o)
        narr_m = size(arr_m)

        ! The possibility of OOM condition is ignored here
        ! If such thing happens, user is already messed up

        ! Stack requirements here:
        ! <na> + ud_i + ud_m + ud_o + nv + {closure} = 5 + na

        ! Provide stack
        call luaL_checkstack(L_st, na+5, F_C_STR('too many arguments'))



        
        ! push numerical arguments
        do k = 1, na
            call lua_pushnumber(L_st, args(k))
        end do
        ns = na

        ! create userdata values
        ! 1. input parameters
        if (.not. createuv(narr_i, ns)) return
        call filluv(narr_i, arr_i)
        ! 2. modified parameters
        if (.not. createuv(narr_m, ns)) return
        call filluv(narr_m, arr_m)
        ! 3. output parameters
        if (.not. createuv(narr_o, ns)) return

        ! Push number of output values
        call lua_pushinteger(L_st, int(nv, c_intptr_t))
        
        r = .true.
    contains
        ! Create UD value
        ! Protected call is used
        ! In case of error pop extra arguments from the stack
        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
                ! failure => pop stack values
                call lua_pop(L_st, ns)
            end if
        end function createuv
            
        ! Fill UD value on the stack top from array
        ! No checks are made
        subroutine filluv(s, arr)
            use, intrinsic :: iso_c_binding, only: c_f_pointer
            integer(4), intent(in) :: s
            real(8), intent(in) :: arr(:)
            
            type(c_ptr) :: ud
            real(8), pointer :: aptr(:)

            ud = lua_touserdata(L_st, -1)
            call c_f_pointer(ud, aptr, [s])

            aptr(1:s) = arr(1:s)
            
            aptr => null()
        end subroutine filluv

    end function packargs
        
    ! Unpack values
    subroutine unpackvals(fvals, arr_m, arr_o)
        real(8), intent(inout) :: fvals(:), arr_m(:), arr_o(:)

        integer(4) :: nv, narr_o, narr_m, k

        ! Sizes of arrays
        nv = size(fvals)
        narr_o = size(arr_o)
        narr_m = size(arr_m)

        ! get numerical arguments (no checks are made here,
        ! see lfun_tail)
        do k = 1, nv
            fvals(k) = lua_tonumber(L_st, 2+k)
        end do

        ! extract userdata values
        ! 1. modified parameters
        call xtruv(1, narr_m, arr_m)
        ! 2. output parameters
        call xtruv(2, narr_o, arr_o)

    contains
        ! Extract UD value on the stack index onto array
        ! No checks are made
        subroutine xtruv(ix, s, arr)
            use, intrinsic :: iso_c_binding, only: c_f_pointer
            integer(4), intent(in) :: ix, s
            real(8), intent(inout) :: arr(:)
            
            type(c_ptr) :: ud
            real(8), pointer :: aptr(:)

            ud = lua_touserdata(L_st, ix)
            call c_f_pointer(ud, aptr, [s])

            arr(1:s) = aptr(1:s)
            
            aptr => null()
        end subroutine xtruv
        
    end subroutine unpackvals

    ! Lua EP for evaluation of function from BD (two-level name)
    function lfuncall2(L) bind(C) result(r)
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        call gettbl2(L)
        r = lfun_tail(L)

    end function lfuncall2

    ! Lua EP for evaluation of function from BD (one-level name)
    function lfuncall1(L) bind(C) result(r)
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        call gettbl1(L)
        r = lfun_tail(L)

    end function lfuncall1

    ! Lua EP for evaluation of function from BD (cached name)
    function lfuncallc(L) bind(C) result(r)
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        ! Provide stack
        call luaL_checkstack(L, 4, F_C_STR('too many arguments'))
        
        ! Stack is now: tblname key arg1 ... argn UI UM UO NV
        ! Get table from the globals
        call lua_pushvalue(L, 1)
        call lua_gettable(L, LUA_REGISTRYINDEX)
        call lfun_checktbl(L, 'cached ')
        
        ! Remove table name
        call lua_remove(L, 1)
        
        r = lfun_tail(L)

    end function lfuncallc

    ! Call lua 'function' from BD
    function luacache(tbldir, tbl, cname) result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in) :: tbldir
        character(*), intent(in) :: tbl, cname
................................................................................
    end function lcache1

    ! Fetch table from BD (two-level name)
    subroutine gettbl2(L)
        type(c_ptr) :: L

        ! Provide stack
        call luaL_checkstack(L, 4, F_C_STR('too many arguments'))
        
        ! Stack is now: tbldirname tblname key arg1 ... argn UI UM UO NV
        ! Get tbldir from the globals
        call lua_pushvalue(L, 1)
        call lua_gettable(L, LUA_GLOBALSINDEX)
        call lfun_checktbl(L, 'global ')
        
        ! Remove tbldir name
        call lua_remove(L, 1)

        ! Stack is now: tblname key arg1 ... argn UI UM UO NV tbldir
        ! Get table from tbldir
        call lua_pushvalue(L, 1)
        call lua_gettable(L, -2)
        call lfun_checktbl(L, 'table ')
        
        ! Remove table name
        call lua_remove(L, 1)
        ! Stack is now: key arg1 ... argn UI UM UO NV tbldir tbl
        ! Remove tbldir
        call lua_remove(L, -2)
        ! Stack is now: key arg1 ... argn UI UM UO NV tbl
    end subroutine gettbl2

    ! Fetch table from BD (one-level name)
    subroutine gettbl1(L)
        type(c_ptr) :: L

        ! Provide stack
        call luaL_checkstack(L, 4, F_C_STR('too many arguments'))
        
        ! Stack is now: tblname key arg1 ... argn UI UM UO NV 
        ! 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 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 UI UM UO NV tbl
    ! Expecting stack on output: none

    function lfun_tail(L) result(r)

        use ftnlf_fxcore, only: mt_interp
        type(c_ptr) :: L
        integer(4) :: r, typ
        integer(4) :: na, nv, k
        type(c_ptr) :: udck
        character(9) :: buf
        character(10) :: buft

        r = 0
        ! to support extra pushes
        call luaL_checkstack(L, 5, F_C_STR('stack overflow'))
        ! Number of numeric arguments
        na = lua_gettop(L) - (2+4) 

        ! Get value from the table 
        call lua_pushvalue(L, 1)
        call lua_gettable(L, -2)
        typ = lua_type(L, -1)
        ! Move value below the arguments
        call lua_insert(L, 2)
        ! pop table
        call lua_pop(L, 1)

        ! Get number of output arguments
        ! Get and pop dimensions
        nv = INT(lua_tointeger(L, -1), 4)
        call lua_pop(L, 1)

        ! Send UM and UO userdata values to stack bottom
        ! to return them later
        call lua_insert(L, 1)
        call lua_insert(L, 1)

        ! Stack is now:
        ! UM UO key val arg1 ... argn UI
        ! < DEBUG >
        call luaFE_check(L, lua_gettop(L) == na+5, 'stack inconsistency')

        ! classify value and call it
        if (typ == LUA_TNUMBER) then
            ! Constant

            if (ckarg(nv == 1, &
                & 'Too many output arguments for constant ') /= 0) return
            ! Pop input userdata and arguments
            call lua_pop(L, na+1)

            ! stack is now: UM UO key val
        elseif (typ == LUA_TUSERDATA) then
            udck = luaL_checkudata(L, 4, F_C_STR(mt_interp))
            ! Interpolation table
            ! Expecting one argument


            if (ckarg(na == 1 .and. nv == 1, &
                & 'Too many arguments for interpolation function ') /= 0) return
            ! Pop input userdata
            call lua_pop(L, 1)




            ! Stack is now: UM UO key ud arg
            ! call userdata w/metamethod



            ! argument gets replaced with result
            call lua_call(L, na, nv)


            ! stack is now: UM UO key val
        elseif (typ == LUA_TFUNCTION) then
            ! Function of (many) arguments
            ! Stack is now: UM UO key fun arg1 .. argn UI

            ! Push userdata values
            call lua_pushvalue(L, 1)

            call lua_pushvalue(L, 2)
            ! Stack is now: UM UO key fun arg1 .. argn UI UM UO
            ! Call function w/out protection, since we're already in pcall

            call lua_call(L, na+3, nv)
            ! Stack is now: UM UO key val1 ... valn




        else
            ! Other types -> signal error

            typ = ckarg(.false., 'Bad type of value ')



            return
        endif

        ! remove key, so argument numbering is consistent
        call lua_remove(L, 3)

        r = 2+nv ! number of returns
        ! < DEBUG >
        call luaFE_check(L, lua_gettop(L) == r, 'stack inconsistency')

        ! Check values
        do k = 1, nv
            typ = lua_type(L, 2+k)
            if (typ /= LUA_TNUMBER) then
                ! Format error message
                write (buf,10) k
10              format ('value #', I2)
                call lua_typename_f(L, typ, buft)
                call luaFE_check(L, .false., &
                & 'bad type of '//buf//': '//'number' &
                & //' expected, got '//TRIM(buft))
            end if
        end do

    contains
        function ckarg(cond, msg) result(r)
            integer(4) :: r
            logical, intent(in) :: cond
            character(*), intent(in) :: msg
            integer(4), parameter :: ix_key = 3
            if (cond) then
                r = 0
            else
                call lua_pushstring_f(L, msg)
                call lua_pushvalue(L, ix_key)
                call lua_concat(L, 2)
                r = lua_error(L)
            end if
        end function ckarg
    end function lfun_tail

end module ftnlf

Deleted ftnlf.txt.

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
27
28
29
30
31
32
33
34
35
36
37
Список элементов для последующей интеграции.

(+)0. Interp
(+)0.0. <Сделано>
(-)0.1. (???) Заменить метаметод index на call, проверить. Сделать проверку, что передан один аргумент.

1. Инициализация.
(+)1.1. Инициализация интерпретатора Lua.
(+)1.1.1. Глобальная (модульная) переменная, содержащая состояние интерпретатора.
(+)1.2. Открытие библиотек.
(+)1.3. Открытие модуля, содержащего interp.
(+)1.4. (?) Глобализация interp
(+)1.5. Загрузка файла Lua с БД (NB: имя файла должно быть известно на этот момент!!!)
(*)1.6. Запись необходимых значений (каких?) в реестр Lua.
(-)1.6.1. Выбор материала топлива и оболочки, таблицы для которых будут записаны в реестр (?).

(+) 2. Финализация.
(+) 2.1. Финализация Lua.

3. Механизм для вызова функции -- универсальная обертка.
(+)3.1. Распаковать аргументы.
(+)3.2. Положить в стек "свойство" (таблицу взять из реестра, имя "свойства" из аргументов).
(+)3.2.1. Взять из кэша (реестра).
(+)3.3. Обработать случай скаляра.
(+)3.4. (???) Обработать случай ud, если не будет сделан 0.1.
(+)3.5. Обработать случай функции.
(+)3.6. protected call с диагностикой.

4. Сервисные функции.
(*)4.1. Загрузка таблицы по двухуровнему имени.
(+)4.2. Кэширование -- 1.6.

5. Имитатор.
(+)5.1. Основная подпрограмма
(+)5.2. База данных

 
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<
<










































































Name change from ftnlf_interp.f90 to ftnlf_fxcore.f90.

1
2
3




4


5






6






































































































































































































































































































7
8
9
10
11
12
13
..
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
..
53
54
55
56
57
58
59



60
61
62
63
64
65
66
67
68
69
70
71
72
73
74


75
76
77
78
79

80
81
82
83
84
85
86
87

88
89
90
91
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
118
119
120
121
122
123
124
125
126
127
128
129

130
131
132
133
134
135
136
137


138
139

140
141
142
143

144
145
146
147
148
149
150
151
152

153

154
155

156
157
158
159
160
161
162
163
164
165

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



179
180
181
182



183
184
185
186
187
188
189
190
191
! Subroutines to use in Lua extensions to Fortran
! Linear interpolation: 
module ftnlf_interp




    private


    public l_newintobj






contains






































































































































































































































































































    ! Interpolation of the 0th and 1st order
    REAL(8) FUNCTION TABINT(LS, KEY,N,X0,X,Y)
        !&P
        !&P   Programmed by:    B.B.Sakharov
        !&P
        !&F   Function:
        !&F      perform interpolation
................................................................................
        type(c_ptr), intent(in) :: LS
        INTEGER(4) :: KEY,N
        REAL(8) :: X0,X,Y
        DIMENSION X(N),Y(N)
        INTEGER I
        DOUBLE PRECISION A

        call luaFE_check(LS, (KEY.LE.1) .AND. (KEY.GE.0), &
            '<<TABINT>> Invalid input parameter KEY')
        call luaFE_check(LS, N .GE. 1, &
            '<<TABINT>> Invalid input parameter N')

        IF (X0.LE.X(1)) THEN
            TABINT=Y(1)
            RETURN
................................................................................
            IF ((X0.GE.X(I)) .AND. (X0.LT.X(I+1))) GO TO 10
        ENDDO
    10  CONTINUE

        IF (KEY.EQ.0) THEN
            TABINT=Y(I)
            RETURN



        ELSE
            A=(X0-X(I))/DMAX1((X(I+1)-X(I)),1.D-30)
            TABINT=Y(I)+A*(Y(I+1)-Y(I))
            RETURN
        ENDIF
    END FUNCTION TABINT

    ! Create new interpolation object from table at the top
    function l_newintobj(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_int, c_ptr, c_f_pointer, c_size_t
        use LuaF
        use LuaFE
        implicit none
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r


        integer(4) :: ntbl, lentbl, k, i, key
        integer(4), pointer:: itbl(:)
        type(c_ptr) :: ud
        real(8), pointer :: tbl(:)
        real(8) :: x, y

        
        ! Check args
        call luaL_checktype(L, 1, LUA_TTABLE)
        if (lua_gettop(L) == 2) then
            call luaL_checktype(L, 2, LUA_TNUMBER)
            ! Get interpolation key and pop it
            key = INT(lua_tointeger(L, 2), 4)
            call lua_pop(L, 1)

        else
            key = 1
        endif
        
        ! get table length
        ntbl = INT(lua_objlen(L, 1), 4)
        call luaFE_check(L, ntbl > 0 .and. mod(ntbl, 2) == 0, &

            'Invalid interpolation table')

        ntbl = ntbl/2
        lentbl = (1+2*ntbl)
        
        ! Allocate Lua userdata
        ud = lua_newuserdata(L, INT(lentbl*8, C_SIZE_T))
        ! Move table atop
        call lua_insert(L, -2)
        
        ! Associate Fortran table with ptr (integer part only)
        call c_f_pointer(ud, itbl, [2])
        itbl(1) = ntbl
        itbl(2) = key
        ! Disassociate
        itbl => NULL()

        ! Associate Fortran table with ptr
        call c_f_pointer(ud, tbl, [lentbl])
        
        ! Fill the table
        do k = 1, ntbl
            ! Get x
            i = 2*k-1
            call lua_rawgeti(L, -1, i)
            x = luaFE_checkdouble(L, -1, 'x element')
            ! Get y
            i = 2*k
            call lua_rawgeti(L, -2, i)
            y = luaFE_checkdouble(L, -1, 'y element')
            ! Pop x, y
            call lua_pop(L, 2)
            ! Put to table
            tbl(1+k) = x
            tbl(1+ntbl+k) = y
        enddo


        ! Disassociate
        tbl => NULL()
        
        ! Table is not needed anymore
        call lua_pop(L, 1)
        
        ! Set metatable


        call lua_newtable(L)
        call luaFE_register(L, '__index', l_intidx)

        r = lua_setmetatable(L, -2)
        
        ! Return userdata
        r = 1

    end function l_newintobj
    
    ! Interpolation userdata metatable __index method
    function l_intidx(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_int, c_ptr, c_f_pointer
        use LuaF
        implicit none
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        integer(4) :: ntbl, lentbl, key

        type(c_ptr) :: ud
        integer(4), pointer:: itbl(:)

        real(8), pointer :: tbl(:)
        real(8) :: x, y
        
        ! Check args, get length
        call luaL_checktype(L, 1, LUA_TUSERDATA)
        call luaL_checktype(L, 2, LUA_TNUMBER)
        ! Get ptr to interpolation data
        ud = lua_touserdata(L, 1)
        ! Get interpolation value
        x = REAL(lua_tonumber(L, 2), 8)

        ! Pop them
        call lua_pop(L, 2)
        
        ! Associate Fortran table with ptr (integer part only)
        call c_f_pointer(ud, itbl, [2])
        ntbl = itbl(1)
        key = itbl(2)
        lentbl = (1+2*ntbl)
        ! Disassociate
        itbl => NULL()

        ! Associate Fortran table with ptr
        call c_f_pointer(ud, tbl, [lentbl])




        ! Interpolate
        y = TABINT(L, key, ntbl, x, tbl(2:1+ntbl), tbl(2+ntbl:lentbl))




        ! Disassociate
        tbl => NULL()
        
        ! Return interpolated value
        call lua_pushnumber(L, y)
        r = 1
    end function l_intidx
    
end module ftnlf_interp
|
|
|
>
>
>
>

>
>
|
>
>
>
>
>
>

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







 







|







 







>
>
>








|
|
<
<
<


>
>
|
<

|

>




<
|
<
<
>





|
|
>
|
>
|
|


|
<
<

<
<
<
<
<
<
<
|
|
|




|



|




|
|

>


|
|
<
<
<

>
>
|
|
>




>
|

|
|
|
<
<


>
|
>

<
>
|


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

<
<
>
>
>
|

|

>
>
>

|

<
<

|
|
|
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
27
28
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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
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
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
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
...
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
...
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378



379
380
381
382
383

384
385
386
387
388
389
390
391

392


393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408


409







410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433



434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449


450
451
452
453
454
455

456
457
458
459
460

461
462
463
464

465
466
467
468
469
470





471


472
473
474
475
476
477
478
479
480
481
482
483
484


485
486
487
488
! Fortran extensions to use in Lua modules
! (Fortran arrayas, linear interpolation, ...)
module ftnlf_fxcore
    use LuaF
    use LuaFE
    use, intrinsic :: iso_c_binding, only: c_int, c_ptr
    implicit none
    private
    ! Public API: loader function, userdata id for interp objects,
    ! C functions to operate with Fortran arrays
    public ldr_fx_core
    public l_fa_new, l_fa_pack, l_fa_unpack
    public mt_interp

    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) 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, 'aunpack', l_fa_unpack)
        call luaFE_register(L, 'interp', l_interp_new)

        r = 1
    end function ldr_fx_core

    ! ======= Fortran Arrays =======

    ! Metatable and metamethods
    ! Load existing metatable or create new
    function newmt(L, mtkey)
        type(c_ptr) :: L
        character(*), intent(in) :: mtkey
        logical :: newmt

        newmt = luaL_newmetatable(L, F_C_STR(mtkey)) /= 0
        if (newmt) then
            ! Metatable is created, now add new methods
            call luaFE_registerSUV(L, '__len', l_fa_len)
            call luaFE_registerSUV(L, '__index', l_fa_idx)
            call luaFE_registerSUV(L, '__newindex', l_fa_nidx)
            
        end if
        
    end function newmt

    ! Fortran array userdata metatable __len method
    function l_fa_len(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_size_t
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        type(c_ptr) :: ud
        integer(c_size_t) :: s
        
        ! Check args, get length
        ! @@@ name of userdata?
        ud = luaFE_checkudSUV(L, 1, 'FA/interp userdata')
        ! bytes to double
        s = lua_objlen(L, 1)/8
        call lua_pushinteger(L, s)
        r = 1
    end function l_fa_len

    ! Fortran array userdata metatable __index method
    function l_fa_idx(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_size_t, c_f_pointer
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        type(c_ptr) :: ud
        integer(c_size_t) :: s, k
        real(8), pointer :: arr(:)
        
        ! Check 1st arg, get length
        ! @@@ name of userdata?
        ud = luaFE_checkudSUV(L, 1, 'FA/interp userdata')
        ! bytes to double
        s = lua_objlen(L, 1)/8

        ! Check 2nd arg, check bounds
        k = luaL_checkinteger(L, 2)
        if (k < 1 .or. k > s) then
            r = luaL_argerror(L, 2, F_C_STR('out of bounds'))
        end if

        ! Associate
        call c_f_pointer(ud, arr, [s])
        
        ! Return array item
        call lua_pushnumber(L, arr(k))

        ! Disassociate
        arr => NULL()
        
        r = 1
    end function l_fa_idx

    ! Fortran array userdata metatable __newindex method
    function l_fa_nidx(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_size_t, c_f_pointer
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        type(c_ptr) :: ud
        integer(c_size_t) :: s, k
        real(8), pointer :: arr(:)
        real(8) :: v
        
        ! Check 1st arg, get length
        ! @@@ name of userdata?
        ud = luaFE_checkudSUV(L, 1, 'FA/interp userdata')
        ! bytes to double
        s = lua_objlen(L, 1)/8

        ! Check 2nd arg, check bounds
        k = luaL_checkinteger(L, 2)
        if (k < 1 .or. k > s) then
            r = luaL_argerror(L, 2, F_C_STR('out of bounds'))
        end if

        ! Check 3rd arg
        v = luaL_checknumber(L, 3)

        ! Associate
        call c_f_pointer(ud, arr, [s])
        
        ! Replace array item
        arr(k) = v

        ! Disassociate
        arr => NULL()
        
        r = 0
    end function l_fa_nidx

    ! Create new Fortran array with the desired length
    function l_fa_new(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_intptr_t) :: s
        type(c_ptr) :: ud
        real(8), pointer :: arr(:)
        logical :: rl
        
        ! Check args
        s = luaL_checkinteger(L, 1)
        if (s < 0) then
            r = luaL_argerror(L, 1, F_C_STR('negative length'))
        end if

        ! Allocate Lua userdata
        ud = lua_newuserdata(L, 8*s)
        
        ! Associate Fortran array with ptr
        call c_f_pointer(ud, arr, [s])
        
        ! Fill the array
        arr = 0.d0

        ! Disassociate
        arr => NULL()

        ! Set metatable
        rl = newmt(L, mt_FA)
        r = lua_setmetatable(L, -2)
        
        ! Return userdata
        r = 1
    end function l_fa_new

    ! Pack numeric arguments into existing or new Fortran array
    ! Usage: v = apack(arg1, arg2, ...., argn, arr)
    ! n >= 0
    ! where arr is:
    !  - existing Fortran array where to pack (#arr >= n)
    !  - N => create new array of length N (N >= n)
    !  - nil => create new array of length n
    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) :: nlast, nargs, typ, k

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
        real(8), pointer :: arr(:)
        
        ! Check args
        nlast = lua_gettop(L)
        nargs = nlast - 1
        typ = lua_type(L, -1)

        if (typ == LUA_TUSERDATA) then
            ! Now stack is: arg1 ... argn ud
            ud = luaL_checkudata(L, nlast, F_C_STR(mt_FA))
            
            ! obtain length
            ! (bytes to double)
            s = lua_objlen(L, -1)/8
        else
            if (typ == LUA_TNIL) then
                ! default size
                ! pop nil
                call lua_pop(L, 1)
                s = nargs
                ! push size
                call lua_pushinteger(L, s)
            elseif (typ == LUA_TNUMBER) then
                s = lua_tointeger(L, -1)
            else
                r = luaL_argerror(L, nlast, 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

        ! check bounds
        if (s < nargs) then
            r = luaL_argerror(L, 2, F_C_STR('too many arguments'))
        end if

        ! Associate
        call c_f_pointer(ud, arr, [s])
        ! Fill array
        do k = 1, nargs
            arr(k) = luaL_checknumber(L, k)
        end do

        ! Disassociate
        arr => NULL()

        ! Return userdata (on the stack top), throw away arguments
        r = 1
    end function l_fa_pack

    ! Unpack numeric arguments from existing Fortran array
    ! Usage: v1, v2, ..., vn = aunpack(arr, n)
    ! where n is:
    !  - number (0 <= n <= #arr)
    !  - nil or none => unpack all (n == #arr)
    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) :: nvals, k

        integer(c_intptr_t) :: s
        type(c_ptr) :: ud
        real(8), pointer :: arr(:)
        
        ! Check 1st arg, get length
        ud = luaL_checkudata(L, 1, F_C_STR(mt_FA))
        ! bytes to double
        s = lua_objlen(L, 1)/8

        ! Check 2nd arg
        if (lua_isnoneornil(L, 2)) then
            ! Default
            nvals = int(s, c_int)
        else
            ! Get number of output values
            nvals = luaL_checkint(L, 2)

            ! check bounds
            if (s < nvals) then
                r = luaL_argerror(L, 2, F_C_STR('too many output values'))
            end if
        end if

        ! Provide stack
        call luaL_checkstack(L, nvals, F_C_STR('too many output values'))

        ! Associate
        call c_f_pointer(ud, arr, [s])
        ! Push elements of array
        do k = 1, nvals
            call lua_pushnumber(L, arr(k))
        end do

        ! Disassociate
        arr => NULL()

        ! Return output arguments, discard everything else
        r = nvals
    end function l_fa_unpack

    ! ======= Fortran Arrays =======


    ! ======= Interpolation Objects =======

    ! Interpolation of the 0th and 1st order
    REAL(8) FUNCTION TABINT(LS, KEY,N,X0,X,Y)
        !&P
        !&P   Programmed by:    B.B.Sakharov
        !&P
        !&F   Function:
        !&F      perform interpolation
................................................................................
        type(c_ptr), intent(in) :: LS
        INTEGER(4) :: KEY,N
        REAL(8) :: X0,X,Y
        DIMENSION X(N),Y(N)
        INTEGER I
        DOUBLE PRECISION A

        call luaFE_check(LS, (KEY.LE.1) .AND. (KEY.GE.-1), &
            '<<TABINT>> Invalid input parameter KEY')
        call luaFE_check(LS, N .GE. 1, &
            '<<TABINT>> Invalid input parameter N')

        IF (X0.LE.X(1)) THEN
            TABINT=Y(1)
            RETURN
................................................................................
            IF ((X0.GE.X(I)) .AND. (X0.LT.X(I+1))) GO TO 10
        ENDDO
    10  CONTINUE

        IF (KEY.EQ.0) THEN
            TABINT=Y(I)
            RETURN
        ELSE IF (KEY.EQ.-1) THEN
            TABINT=Y(I+1)
            RETURN          
        ELSE
            A=(X0-X(I))/DMAX1((X(I+1)-X(I)),1.D-30)
            TABINT=Y(I)+A*(Y(I+1)-Y(I))
            RETURN
        ENDIF
    END FUNCTION TABINT

    ! Create new interpolation object from table at the top
    function l_interp_new(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_f_pointer, c_size_t



        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r
        integer :: key
        integer(c_size_t) :: lentbl
        integer(4) :: k, i, ntbl

        type(c_ptr) :: ud
        real(8), pointer :: arr(:)
        real(8) :: x, y
        logical :: rl
        
        ! Check args
        call luaL_checktype(L, 1, LUA_TTABLE)
        if (lua_gettop(L) == 2) then

            ! Get interpolation key


            key = luaL_checkint(L, 2)
        else
            key = 1
        endif
        
        ! get table length
        lentbl = lua_objlen(L, 1)
        if (lentbl > 0 .and. mod(lentbl, 2) == 0) then
        else
            r = luaL_argerror(L, 1, 'Invalid interpolation table')
        endif
        ntbl = INT(lentbl/2, 4)
        lentbl = lentbl + 1
        
        ! Allocate Lua userdata
        ud = lua_newuserdata(L, 8*lentbl)


        







        ! Associate Fortran array with ptr
        call c_f_pointer(ud, arr, [lentbl])

        ! Fill the table
        do k = 1, ntbl
            ! Get x
            i = 2*k-1
            call lua_rawgeti(L, 1, i)
            x = luaFE_checkdouble(L, -1, 'x element')
            ! Get y
            i = 2*k
            call lua_rawgeti(L, 1, i)
            y = luaFE_checkdouble(L, -1, 'y element')
            ! Pop x, y
            call lua_pop(L, 2)
            ! Put to table
            arr(k) = x
            arr(ntbl+k) = y
        enddo
        arr(lentbl) = dble(key)

        ! Disassociate
        arr => NULL()




        ! Set metatable
        rl = newmt(L, mt_interp)
        ! Add call metamethod
        if (rl) then
            call luaFE_registerSUV(L, '__call', l_interp_call)
        end if
        r = lua_setmetatable(L, -2)
        
        ! Return userdata
        r = 1

    end function l_interp_new
    
    ! Interpolation userdata metatable __call method
    function l_interp_call(L) bind(C) result(r)
        use, intrinsic :: iso_c_binding, only: c_size_t, c_f_pointer


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

        integer(4) :: ntbl, key
        
        type(c_ptr) :: ud

        integer(c_size_t) :: lentbl
        real(8), pointer :: arr(:)
        real(8) :: x, y
        
        ! Check 1st arg, get length

        ! @@@ name of userdata?
        ud = luaFE_checkudSUV(L, 1, 'FA/interp userdata')
        ! bytes to double
        lentbl = lua_objlen(L, 1)/8


        ! Check 2nd arg
        x = luaL_checknumber(L, 2)

        ! Associate
        call c_f_pointer(ud, arr, [lentbl])








        ! Get key
        key = INT(arr(lentbl), 4)
        ntbl = INT((lentbl-1)/2, 4)
        
        ! Interpolate
        y = TABINT(L, key, ntbl, x, arr(1:ntbl), arr(1+ntbl:2*ntbl))

        ! Return interpolated value
        call lua_pushnumber(L, y)

        ! Disassociate
        arr => NULL()
        


        r = 1
    end function l_interp_call

end module ftnlf_fxcore

Changes to intel/c.cmd.

1
2
call "C:\Program Files\Intel\Composer XE 2011 SP1\bin\ipsxe-comp-vars.bat" ia32 vs2010
ifort /QxHOST /O2 /C /traceback /warn ..\luaf\luaf.f90 ..\luaf\luafe.f90 ..\ftnlf_interp.f90 ..\ftnlf.f90 ..\test.f90 /exe:ftnlf_test.exe lua5.1_32.lib 

|
1
2
call "C:\Program Files\Intel\Composer XE 2011 SP1\bin\ipsxe-comp-vars.bat" ia32 vs2010
ifort /QxHOST /O2 /C /traceback /warn ..\luaf\luaf.f90 ..\luaf\luafe.f90 ..\ftnlf_fxcore.f90 ..\ftnlf.f90 ..\test.f90 /exe:ftnlf_test.exe lua5.1_32.lib 

Changes to luaf/luafe.f90.

1
2
3
4
5
6
















7
8
9
10
11
12
13
..
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63













64
65
66
67
68
69
70
...
169
170
171
172
173
174
175

176



















































177
178
MODULE LUAFE
    ! Fortran extensions to Lua API

    USE LUAF
    IMPLICIT NONE

















CONTAINS

    SUBROUTINE luaFE_check(L, cond, msg)
        ! Check condition and signal error if false
        USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT
        IMPLICIT NONE
        TYPE(C_PTR), INTENT(IN) :: L
................................................................................
    END SUBROUTINE luaFE_checktype

    SUBROUTINE luaFE_register(L, n, f)
        USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT, C_FUNPTR, C_FUNLOC
        IMPLICIT NONE
        TYPE(C_PTR), INTENT(IN) :: L
        CHARACTER(LEN=*), INTENT(IN) :: n
        INTERFACE
            FUNCTION f(L) BIND(C)
                USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT
                IMPLICIT NONE
                TYPE(C_PTR), VALUE, INTENT(IN) :: L
                INTEGER(KIND=C_INT) :: f
            END FUNCTION f
        END INTERFACE

        TYPE(C_FUNPTR) :: fptr
        
        fptr = C_FUNLOC(f)
        CALL lua_pushstring_f(L, n)
        CALL lua_pushcfunction(L, fptr)
        CALL lua_settable(L, -3_C_INT)
    END SUBROUTINE luaFE_register














    FUNCTION luaFE_checkint4(L, idx, n) RESULT(r)
        USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR
        IMPLICIT NONE
        TYPE(C_PTR), INTENT(IN) :: L
        INTEGER, INTENT(IN) :: idx
        CHARACTER(LEN=*), INTENT(IN) :: n
................................................................................
        INTEGER, INTENT(IN) :: idx
        TYPE(C_PTR) :: luaFE_checklud

        call luaL_checktype(L, INT(idx, C_INT), LUA_TLIGHTUSERDATA)
        luaFE_checklud = lua_touserdata(L, INT(idx, C_INT))
    END FUNCTION luaFE_checklud






















































END MODULE LUAFE
    






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







 







|
<
<
<
<
<
<
<








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







 







>

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


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
27
28
29
..
57
58
59
60
61
62
63
64







65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
...
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
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
MODULE LUAFE
    ! Fortran extensions to Lua API

    USE LUAF
    IMPLICIT NONE

    ABSTRACT INTERFACE
        FUNCTION luaFE_Function(L) BIND(C)
            USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT
            IMPLICIT NONE
            TYPE(C_PTR), VALUE, INTENT(IN) :: L
            INTEGER(KIND=C_INT) :: luaFE_Function
        END FUNCTION luaFE_Function
    END INTERFACE

    INTEGER, PARAMETER :: luaFE_NameLen = 32

    TYPE luaFE_FunctionEntry
        CHARACTER(LEN=luaFE_NameLen) :: name
        PROCEDURE(luaFE_Function), POINTER, NOPASS :: f
    END TYPE luaFE_FunctionEntry

CONTAINS

    SUBROUTINE luaFE_check(L, cond, msg)
        ! Check condition and signal error if false
        USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT
        IMPLICIT NONE
        TYPE(C_PTR), INTENT(IN) :: L
................................................................................
    END SUBROUTINE luaFE_checktype

    SUBROUTINE luaFE_register(L, n, f)
        USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT, C_FUNPTR, C_FUNLOC
        IMPLICIT NONE
        TYPE(C_PTR), INTENT(IN) :: L
        CHARACTER(LEN=*), INTENT(IN) :: n
        PROCEDURE(luaFE_Function) :: f








        TYPE(C_FUNPTR) :: fptr
        
        fptr = C_FUNLOC(f)
        CALL lua_pushstring_f(L, n)
        CALL lua_pushcfunction(L, fptr)
        CALL lua_settable(L, -3_C_INT)
    END SUBROUTINE luaFE_register

    SUBROUTINE luaFE_registerlist(L, flist)
        USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT
        IMPLICIT NONE
        TYPE(C_PTR), INTENT(IN) :: L
        TYPE(luaFE_FunctionEntry) :: flist(:)
        INTEGER(4) :: k

        DO k = 1, SIZE(flist)
            CALL luaFE_register(L, TRIM(flist(k)%name), flist(k)%f)
        END DO

    END SUBROUTINE luaFE_registerlist

    FUNCTION luaFE_checkint4(L, idx, n) RESULT(r)
        USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR
        IMPLICIT NONE
        TYPE(C_PTR), INTENT(IN) :: L
        INTEGER, INTENT(IN) :: idx
        CHARACTER(LEN=*), INTENT(IN) :: n
................................................................................
        INTEGER, INTENT(IN) :: idx
        TYPE(C_PTR) :: luaFE_checklud

        call luaL_checktype(L, INT(idx, C_INT), LUA_TLIGHTUSERDATA)
        luaFE_checklud = lua_touserdata(L, INT(idx, C_INT))
    END FUNCTION luaFE_checklud

    ! Userdata checking using metatables as upvalues

    ! Register function in table using the table as self upvalue
    SUBROUTINE luaFE_registerSUV(L, n, f)
        USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT, C_FUNPTR, C_FUNLOC
        IMPLICIT NONE
        TYPE(C_PTR), INTENT(IN) :: L
        CHARACTER(LEN=*), INTENT(IN) :: n
        PROCEDURE(luaFE_Function) :: f

        TYPE(C_FUNPTR) :: fptr
        
        fptr = C_FUNLOC(f)
        CALL lua_pushstring_f(L, n)
        ! Push table to use as upvalue
        CALL lua_pushvalue(L, -2_C_INT)
        CALL lua_pushcclosure(L, fptr, 1_C_INT)
        CALL lua_settable(L, -3_C_INT)
    END SUBROUTINE luaFE_registerSUV

    FUNCTION luaFE_checkudSUV(L, idx, name) RESULT(r)
        USE, INTRINSIC :: ISO_C_BINDING, ONLY: C_PTR, C_INT
        IMPLICIT NONE
        TYPE(C_PTR), INTENT(IN) :: L
        INTEGER, INTENT(IN) :: idx
        CHARACTER(*), INTENT(IN) :: name
        TYPE(C_PTR) :: r
        LOGICAL :: ck
        INTEGER(C_INT) :: err

        ! Userdata?
        CALL luaL_checktype(L, INT(idx, C_INT), LUA_TUSERDATA)
        ck = .FALSE.
        ! Has metatable?
        IF (lua_getmetatable(L, INT(idx, C_INT)) /= 0) THEN
            ! in the stack now
            ! compare with the stored upvalue
            IF (lua_rawequal(L, INT(-1_C_INT), &
                & lua_upvalueindex(1)) /= 0) THEN
                ! expected value, ok
                ck = .TRUE.
            END IF
            ! pop metatable
            CALL lua_pop(L, 1)
        END IF
        ! Signal error
        IF (.NOT. ck) THEN
            err = luaL_typerror(L, INT(idx, C_INT), &
                & F_C_STR(name))
        ENDIF
        r = lua_touserdata(L, INT(idx, C_INT))
    END FUNCTION luaFE_checkudSUV

END MODULE LUAFE
    

Changes to test.f90.












































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
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44






45
46
47
48
49
50











































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

    r = luafun('dir1', 'tbl1', 'v5', [1.d0,-3.5d0], fval)
    write (*,'(L,X,1PE11.4)') r, fval

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

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

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

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

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

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

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







    ! Finalize
    call ftnlf_done()
    write (0,'(A)') '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
27
28
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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
module testmod
    ! Test module
    use LuaF
    use LuaFE
    use, intrinsic :: iso_c_binding, only: c_int, c_ptr
    implicit none
    private
    ! Public API: loader function
    public ldr_fx_test

contains
    ! FX.Test module loader
    function ldr_fx_test(L) bind(C) 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, 'testfun', l_test)

        r = 1
    end function ldr_fx_test

    function l_test(L) bind(C) result(r)
        type(c_ptr), value, intent(in) :: L
        integer(c_int) :: r

        real(8) :: v

        ! Check 1nd arg
        v = luaL_checknumber(L, 1)
        
        v = v + sqrt(2.d0)

        call lua_pushnumber(L, v)
        
        r = 1
    end function l_test

end module testmod

program test
    ! Mockup for ftnlf
    use ftnlf
    use luaFE, only: luaFE_FunctionEntry
    use testmod
    implicit none
    
    type(luaFE_FunctionEntry) :: ldr(1)
    logical :: r
    real(8) :: fval
    real(8) :: fvals(10), arr_m(1), arr_o(10)
    
    ! Initialize
    ldr(1)%name='FX.Test'
    ldr(1)%f => ldr_fx_test
    r = ftnlf_init('testdb.lua', ldr)
    if (.not. r) stop 99

    ! Simplified iface
    r = luafun('', 'tbl1', 'val1', [1.d0,-3.5d0], fval)
    write (*,'(L2,1X,1PE11.4)') r, fval

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

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

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

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

    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
    arr_m(1) = -0.9d0
    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,6(1X,1PE11.4))') r, fvals(1:2), arr_m(1:1), arr_o(1:3)

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

end program test

Changes to testdb.lua.


1
2
3
4
5







6
7
8
9
10
11
12
13






























iii = interp({0,1,10,0,15,-3})

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







}

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

}






























>
|




>
>
>
>
>
>
>




|



>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
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
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
local FXC = require('FX.Core')
iii = FXC.interp({0,1,10,0,15,-3})

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])
am[1] = am[1]*(-10.)
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},

}

if false then
local A = FXC.array(4)
print(#A)
print(A[1])
A[1] = 96.7
print(A[1])
A[1] = 0.1
print(A[1])

local jjj = FXC.interp({0,1,10,0,15,-3})
print('[] ',jjj[4])
print('() ',jjj(4))

local A = FXC.apack(11,22,33,nil)
print(A[1], A[2], A[3])
local B = FXC.apack(4,5,A)
print(A[1], A[2], A[3])
print(#B)
print(B[1], B[2], B[3])

print(FXC.aunpack(B))

local Z = FXC.array(9000)
print(FXC.aunpack(Z,5))

local T = require('FX.Test')
print(T.testfun(-1.4))

end