ftnlf

Check-in [e7fb98c94b]
Login

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

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

Changes to ftnlf.f90.

91
92
93
94
95
96
97
98

99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
...
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
...
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
...
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
...
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
...
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
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
520
521
522
523
524
525
526
527
528

529
530
531
532
533
534
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
    ! 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, args_a, fvals, fvals_a) result(r)

        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in) :: tbldir
        character(*), intent(in) :: tbl, key
        real(8), intent(in) :: args(:), args_a(:)
        real(8), intent(inout) :: fvals(:), fvals_a(:)
        logical :: r
        integer(4) :: res, n, ns
        real(8), allocatable, target :: p(:)
        
        r = .false.
        ! Check stack
        ! The possibility of OOM condition is ignored here
        ! If such thing happens, user is already messed up
        if (lua_checkstack(L_st, 4) == 0) then
            ! Stack overflow, return
................................................................................
            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, args_a, fvals, fvals_a, p)) then
            ! Pop previous args
            call lua_pop(L_st, ns)
            return
        endif
        






        ! Call Lua
        n = ns - 1 + 5

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

        call unpackvals(p, fvals, fvals_a)


    end function 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), fvals_a(0)

        r = luafuna(tbldir, tbl, key, args, [ real(8) :: ], fvals, fvals_a)
        if (r) &
            fval = fvals(1)

    end function luafun
    
    ! Call lua 'function' from BD (cached), generic case
    function luafunca(tbl, key, args, args_a, fvals, fvals_a) result(r)
................................................................................
        ! Cached value
        call lua_pushcfunction(L_st, c_funloc(lfuncallc))

        call lua_pushstring_f(L_st, tbl)
        call lua_pushstring_f(L_st, key)
        
        ! Push function arguments and return sizes
        if (.not. packargs(args, args_a, fvals, fvals_a, p)) then
            ! Pop previous args
            call lua_pop(L_st, 3)
            return
        endif
        
        ! Call Lua
        n = 3 - 1 + 5
        res = lua_pcall(L_st, n, 1, 0)
        r = lcheck(res)
        if (.not. r) return

        call unpackvals(p, fvals, fvals_a)

    end function luafunca

    ! Call lua 'function' from BD (cached), simplified interface
    function luafunc(tbl, key, args, fval) result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in) :: tbl, key
................................................................................

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

    ! Pack arguments
    function packargs(args, args_a, fvals, fvals_a, argp) result(r)
        use, intrinsic :: iso_c_binding, only: c_loc, c_intptr_t, c_ptr

        real(8), intent(in) :: args(:), args_a(:)
        real(8), intent(inout) :: fvals(:), fvals_a(:)
        real(8), allocatable, target, intent(out) :: argp(:)
        logical :: r
        integer(4) :: na, na2, nv, nv2, nt
        type(c_ptr) :: aptr
        
        r = .false.


        na = size(args)
        na2 = size(args_a)
        nv = size(fvals)
        nv2 = size(fvals_a)
        nt = max(na + na2, nv + nv2)


        ! The possibility of OOM condition is ignored here
        ! If such thing happens, user is already messed up
        
        ! Allocate array for light userdata
        allocate(argp(nt))



        ! pack userdata
        argp(1:na) = args(1:na)
        argp(na+1:na+na2) = args_a(1:na2)
        aptr = c_loc(argp)

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


        ! Push dimensions
        call lua_pushinteger(L_st, int(na, c_intptr_t))
        call lua_pushinteger(L_st, int(na2, c_intptr_t))









        call lua_pushinteger(L_st, int(nv, c_intptr_t))














        call lua_pushinteger(L_st, int(nv2, c_intptr_t))











        ! Push the data










        call lua_pushlightuserdata(L_st, aptr)


        r = .true.





    end function packargs
        
    ! Unpack values
    subroutine unpackvals(valp, fvals, fvals_a)
        real(8), intent(inout) :: fvals(:), fvals_a(:)
        real(8), allocatable, target, intent(inout) :: valp(:) 

        integer(4) :: nv, nv2, nt
        

        nv = size(fvals)
        nv2 = size(fvals_a)
        nt = nv + nv2








        ! Unpack userdata
        fvals(1:nv) = valp(1:nv)
        fvals_a(1:nv2) = valp(nv+1:nv+nv2)





        deallocate(valp)



















    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)
        call lfun_tail(L)
        r = 0
    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 = 0
    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
        ! 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
................................................................................
    ! 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
        ! 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, F_C_STR('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 na1 na2 nv1 nv2 U tbl
    ! Expecting stack on output: none
    subroutine lfun_tail(L)
        use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer
        use ftnlf_fxcore, only: mt_interp
        type(c_ptr) :: L
        integer(4) :: typ, nargs, nargo
        integer(4) :: na, na2, nv, nv2, nt, k
        type(c_ptr) :: aptr, udck

        real(8), pointer :: av(:)

        ! assert
        ! < DEBUG >
        call luaL_checkstack(L, 2, F_C_STR('stack overflow'))
        call luaFE_check(L, lua_gettop(L) == 1+4+1+1, 'stack inconsistency')


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

        ! Deconstruct arguments
        ! Get dimensions
        na = INT(lua_tointeger(L, -5), 4)
        na2 = INT(lua_tointeger(L, -4), 4)
        nv = INT(lua_tointeger(L, -3), 4)
        nv2 = INT(lua_tointeger(L, -2), 4)
        ! Get userdata
        aptr = lua_touserdata(L, -1)
        ! Pop them
        call lua_pop(L, 5)

        ! Stack is now:
        ! key val
        ! < DEBUG >
        call luaFE_check(L, lua_gettop(L) == 2, 'stack inconsistency')

        ! obtain arguments and push them
        call luaL_checkstack(L, na+2, F_C_STR('too many arguments'))
        nt = max(na + na2, nv + nv2)
        call c_f_pointer(aptr, av, [nt])
        
        ! push numbers
        do k = 1, na
            call lua_pushnumber(L, av(k))
        end do
        nargs = na
        if (na2 > 0) then
            nargs = nargs + 1
            ! create table
            call lua_createtable(L, na2, 0)
            do k = 1, na2
                call lua_pushnumber(L, av(na+k))


                call lua_rawseti(L, -2, k)
            enddo
        end if


        ! Stack is now:
        ! key val arg1 arg2 ... argn ?argtbl?
        ! < DEBUG >
        call luaFE_check(L, lua_gettop(L) == 2+nargs, 'stack inconsistency')

        ! Determine number of output arguments
        nargo = nv
        if (nv2 /= 0) then
            nargo = nargo + 1
        end if

        ! classify value and call it
        if (typ == LUA_TNUMBER) then
            ! Constant
            if (ckarg(nv == 1 .and. nv2 == 0, &
                & 'Too many output arguments for constant ') /= 0) return
            ! Stack is now: key val args
            ! Pop arguments

            call lua_pop(L, nargs)
            ! stack is now: key val
        elseif (typ == LUA_TUSERDATA) then
            udck = luaL_checkudata(L, 2, F_C_STR(mt_interp))
            ! Interpolation table
            ! Expecting one argument
            if (ckarg(na == 1 .and. na2 == 0 .and. nv == 1 .and. nv2 == 0, &
                & 'Too many arguments for interpolation function ') /= 0) return


            ! Stack is now: key ud arg
            ! call userdata w/metamethod
            ! argument gets replaced with result
            call lua_call(L, nargs, nargo)
            ! stack is now: key val
        elseif (typ == LUA_TFUNCTION) then
            ! Function of (many) arguments
            ! Stack is now: key fun arg1 .. argn argt




            ! Call function w/out protection, since we're already in pcall
            call lua_call(L, nargs, nargo)
            ! Stack is now: key val1 ... valn valt
        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, 1)


        ! < DEBUG >
        call luaFE_check(L, lua_gettop(L) == nargo, 'stack inconsistency')

        ! pack arguments back
        ! numerical

        do k = 1, nv
            av(k) = luaL_checknumber(L, k)
        enddo
        if (nv2 /= 0) then
            call luaL_checkstack(L, 1, F_C_STR('stack overflow'))
            ! table
            ! FIXME: check length
            call luaL_checktype(L, nargo, LUA_TTABLE)
            do k = 1, nv2
                call lua_rawgeti(L, -1, k)
                av(nv+k) = luaL_checknumber(L, -1)
                call lua_pop(L, 1)
            enddo
        end if

        ! Disassociate
        av => NULL()

        ! pop values
        call lua_pop(L, nargo)

        ! < DEBUG >
        call luaFE_check(L, lua_gettop(L) == 0, 'stack inconsistency')
    contains
        function ckarg(cond, msg) result(r)
            integer(4) :: r
            logical, intent(in) :: cond
            character(*), intent(in) :: msg

            if (cond) then
                r = 0
            else
                call lua_pushstring_f(L, msg)
                call lua_pushvalue(L, 1)
                call lua_concat(L, 2)
                r = lua_error(L)
            end if
        end function ckarg
    end subroutine lfun_tail

end module ftnlf







|
>



|
|

|
<







 







|





>
>
>
>
>
>

<
>
|



|
>










|

|







 







|
|
|
|
|







|







 







|
|
>
|
|
<

|
<


>
>

|

|
<
>
>


|
<
<
>
>

<
<
|
|
|
|
|
|
|
>

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

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

<
>
>
>
>
>



|
|
<
>
|
|
>

|
<
>

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

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








|
<








|
<










|








|
<







 







|








|







|


|









|







 







|

|
<


|
|
|
>
|

|
|
|
|
>










|
|
<
<
|
<
<
<
<
|

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


|

|

<
<
<
<
<
<



|

<
<
>
|
|

|


|

>
>
|


|
|


|
>
>
>
>

|
|







|
>
>

|

<
<
>

<
|
|
|
|
|
|
|
|
|
<
|
|

<
<
<
<
<
<
<
<





>




|




|


91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106

107
108
109
110
111
112
113
...
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
...
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
...
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
...
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
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
...
520
521
522
523
524
525
526
527
528
529

530
531
532
533
534
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
    ! 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
................................................................................
            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, args_a, fvals, fvals_a) result(r)
................................................................................
        ! Cached value
        call lua_pushcfunction(L_st, c_funloc(lfuncallc))

        call lua_pushstring_f(L_st, tbl)
        call lua_pushstring_f(L_st, key)
        
        ! Push function arguments and return sizes
!@        if (.not. packargs(args, args_a, fvals, fvals_a, p)) then
!@            ! Pop previous args
!@            call lua_pop(L_st, 3)
!@            return
!@        endif
        
        ! Call Lua
        n = 3 - 1 + 5
        res = lua_pcall(L_st, n, 1, 0)
        r = lcheck(res)
        if (.not. r) return

!@        call unpackvals(p, fvals, fvals_a)

    end function luafunca

    ! Call lua 'function' from BD (cached), simplified interface
    function luafunc(tbl, key, args, fval) result(r)
        use, intrinsic :: iso_c_binding, only: c_funloc
        character(*), intent(in) :: tbl, key
................................................................................

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

    ! Pack arguments
    function packargs(args, fvals, arr_i, arr_m, arr_o) result(r)
        use, intrinsic :: iso_c_binding, only: c_intptr_t
        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
................................................................................
    ! 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

Changes to test.f90.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
..
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
program test
    ! Mockup for ftnlf
    use ftnlf
    implicit none
    
    logical :: r
    real(8) :: fval
    real(8) :: fvals(10), fvals_a(10)
    
    ! Initialize
    r = ftnlf_init('testdb.lua')
    if (.not. r) stop 99

    ! Simplified iface
    r = luafun('', 'tbl1', 'val1', [1.d0,-3.5d0], 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
    r = luafuna('', 'tbl1', 'valN', [1.d0,-3.5d0], &
        & [1.1d0, 1.2d0, 1.3d0, 1.4d0], fvals(1:1), fvals_a(1:3))
    write (*,'(L2,4(1X,1PE11.4))') r, fvals(1:1), fvals_a(1:3)

    ! 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
..
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
program test
    ! Mockup for ftnlf
    use ftnlf
    implicit none
    
    logical :: r
    real(8) :: fval
    real(8) :: fvals(10), arr_m(0), arr_o(10)
    
    ! Initialize
    r = ftnlf_init('testdb.lua')
    if (.not. r) stop 99

    ! Simplified iface
    r = luafun('', 'tbl1', 'val1', [1.d0,-3.5d0], 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
    r = luafuna('', 'tbl1', 'valN', [1.d0,-3.5d0], fvals(1:1), &
        & [1.1d0, 1.2d0, 1.3d0, 1.4d0], arr_m, arr_o)
    write (*,'(L2,4(1X,1PE11.4))') r, fvals(1:1), arr_o(1:3)

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

end program test

Changes to testdb.lua.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
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,tbl)
local r = {}
r[1] = (x+y)*tbl[1]
r[2] = (x*y)/tbl[2]
r[3] = math.atan2(y*tbl[3],x*tbl[4])
return x-y,r
end
}

dir1 = {
   tbl1 = { v5 = function(x,y) return x-y end },
   tbl2 = { v6 = FXC.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
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])
return x-y
end
}

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