aparler/RosettaCodeData
1
0
Fork 0
Code Issues 12 Pull requests 3 Projects Releases Packages Wiki Activity Actions

September 2017 Update

Browse source
This commit is contained in:
Ingy döt Net 2017-09-23 10:01:46 +02:00
parent bba7bfd280
commit ba8067c3b7
14570 changed files with 153136 additions and 63871 deletions
Download patch file Download diff file Expand all files Collapse all files

2
Task/Call-a-foreign-language-function/CMake/call-a-foreign-language-function-3.cmake
View file

@ -21,7 +21,7 @@ initial_pass(void *info, void *mf, int argc, char *argv[])
/* Parse numerator and denominator. */
for(i = 2, j = 0; i < 4; i++, j++) {
count = sscanf(argv[i], "%d%1s", &n[j], c);
count = sscanf(argv[i], "%d%1s", &n[j], &c);
if (count != 1) {
snprintf(buf, sizeof buf,
"Not an integer: %s", argv[i]);

4
Task/Call-a-foreign-language-function/Fortran/call-a-foreign-language-function-1.f
View file

@ -1,4 +0,0 @@
double add_n(double* a, double* b)
{
return *a + *b;
}

258
Task/Call-a-foreign-language-function/Fortran/call-a-foreign-language-function-2.f
View file

@ -1,258 +0,0 @@
!-----------------------------------------------------------------------
!module dll_module
!-----------------------------------------------------------------------
module dll_module
use iso_c_binding
implicit none
private ! all by default
public :: os_type, dll_type, load_dll, free_dll, init_os_type, init_dll
! general constants:
! the number of bits in an address (32-bit or 64-bit).
integer, parameter :: bits_in_addr = c_intptr_t*8
! global error-level variables:
integer, parameter :: errid_none = 0
integer, parameter :: errid_info = 1
integer, parameter :: errid_warn = 2
integer, parameter :: errid_severe = 3
integer, parameter :: errid_fatal = 4
integer :: os_id
type os_type
character(10) :: endian
character(len=:), allocatable :: newline
character(len=:), allocatable :: os_desc
character(1) :: pathsep
character(1) :: swchar
character(11) :: unfform
end type os_type
type dll_type
integer(c_intptr_t) :: fileaddr
type(c_ptr) :: fileaddrx
type(c_funptr) :: procaddr
character(1024) :: filename
character(1024) :: procname
end type dll_type
! interface to linux API
interface
function dlopen(filename,mode) bind(c,name="dlopen")
! void *dlopen(const char *filename, int mode);
use iso_c_binding
implicit none
type(c_ptr) :: dlopen
character(c_char), intent(in) :: filename(*)
integer(c_int), value :: mode
end function
function dlsym(handle,name) bind(c,name="dlsym")
! void *dlsym(void *handle, const char *name);
use iso_c_binding
implicit none
type(c_funptr) :: dlsym
type(c_ptr), value :: handle
character(c_char), intent(in) :: name(*)
end function
function dlclose(handle) bind(c,name="dlclose")
! int dlclose(void *handle);
use iso_c_binding
implicit none
integer(c_int) :: dlclose
type(c_ptr), value :: handle
end function
end interface
contains
!-----------------------------------------------------------------------
!Subroutine init_dll
!-----------------------------------------------------------------------
subroutine init_dll(dll)
implicit none
type(dll_type), intent(inout) :: dll
dll % fileaddr = 0
dll % fileaddrx = c_null_ptr
dll % procaddr = c_null_funptr
dll % filename = " "
dll % procname = " "
end subroutine init_dll
!-----------------------------------------------------------------------
!Subroutine init_os_type
!-----------------------------------------------------------------------
subroutine init_os_type(os_id,os)
implicit none
integer, intent(in) :: os_id
type(os_type), intent(inout) :: os
select case (os_id)
case (1) ! Linux
os % endian = 'big_endian'
os % newline = achar(10)
os % os_desc = 'Linux'
os % pathsep = '/'
os % swchar = '-'
os % unfform = 'unformatted'
case (2) ! MacOS
os % endian = 'big_endian'
os % newline = achar(10)
os % os_desc = 'MacOS'
os % pathsep = '/'
os % swchar = '-'
os % unfform = 'unformatted'
case default
end select
end subroutine init_os_type
!-----------------------------------------------------------------------
!Subroutine load_dll
!-----------------------------------------------------------------------
subroutine load_dll (os, dll, errstat, errmsg )
! this subroutine is used to dynamically load a dll.
type (os_type), intent(in) :: os
type (dll_type), intent(inout) :: dll
integer, intent( out) :: errstat
character(*), intent( out) :: errmsg
integer(c_int), parameter :: rtld_lazy=1
integer(c_int), parameter :: rtld_now=2
integer(c_int), parameter :: rtld_global=256
integer(c_int), parameter :: rtld_local=0
errstat = errid_none
errmsg = ''
select case (os%os_desc)
case ("Linux","MacOS")
! load the dll and get the file address:
dll%fileaddrx = dlopen( trim(dll%filename)//c_null_char, rtld_lazy )
if( .not. c_associated(dll%fileaddrx) ) then
errstat = errid_fatal
write(errmsg,'(i2)') bits_in_addr
errmsg = 'the dynamic library '//trim(dll%filename)//' could not be loaded. check that the file '// &
'exists in the specified location and that it is compiled for '//trim(errmsg)//'-bit systems.'
return
end if
! get the procedure address:
dll%procaddr = dlsym( dll%fileaddrx, trim(dll%procname)//c_null_char )
if(.not. c_associated(dll%procaddr)) then
errstat = errid_fatal
errmsg = 'the procedure '//trim(dll%procname)//' in file '//trim(dll%filename)//' could not be loaded.'
return
end if
case ("Windows")
errstat = errid_fatal
errmsg = ' load_dll not implemented for '//trim(os%os_desc)
case default
errstat = errid_fatal
errmsg = ' load_dll not implemented for '//trim(os%os_desc)
end select
return
end subroutine load_dll
!-----------------------------------------------------------------------
!Subroutine free_dll
!-----------------------------------------------------------------------
subroutine free_dll (os, dll, errstat, errmsg )
! this subroutine is used to free a dynamically loaded dll
type (os_type), intent(in) :: os
type (dll_type), intent(inout) :: dll
integer, intent( out) :: errstat
character(*), intent( out) :: errmsg
integer(c_int) :: success
errstat = errid_none
errmsg = ''
select case (os%os_desc)
case ("Linux","MacOS")
! close the library:
success = dlclose( dll%fileaddrx )
if ( success /= 0 ) then
errstat = errid_fatal
errmsg = 'the dynamic library could not be freed.'
return
else
errstat = errid_none
errmsg = ''
end if
case ("Windows")
errstat = errid_fatal
errmsg = ' free_dll not implemented for '//trim(os%os_desc)
case default
errstat = errid_fatal
errmsg = ' free_dll not implemented for '//trim(os%os_desc)
end select
return
end subroutine free_dll
end module dll_module
!-----------------------------------------------------------------------
!Main program
!-----------------------------------------------------------------------
program test_load_dll
use, intrinsic :: iso_c_binding
use dll_module
implicit none
! interface to our shared lib
abstract interface
function add_n(a,b)
use, intrinsic :: iso_c_binding
implicit none
real(c_double), intent(in) :: a,b
real(c_double) :: add_n
end function add_n
end interface
type(os_type) :: os
type(dll_type) :: dll
integer :: errstat
character(1024) :: errmsg
type(c_funptr) :: cfun
procedure(add_n), pointer :: fproc
call init_os_type(1,os)
call init_dll(dll)
dll%filename="/full_path_to/shared_lib.so"
! name of the procedure in shared_lib
dll%procname="add_n"
write(*,*) "address: ", dll%procaddr
call load_dll(os, dll, errstat, errmsg )
write(*,*)"load_dll: errstat=", errstat
write(*,*) "address: ", dll%procaddr
call c_f_procpointer(dll%procaddr,fproc)
write(*,*) "add_n(2,5)=",fproc(2.d0,5.d0)
call free_dll (os, dll, errstat, errmsg )
write(*,*)"free_dll: errstat=", errstat
end program test_load_dll

9
Task/Call-a-foreign-language-function/Kotlin/call-a-foreign-language-function.kotlin Normal file
View file

@ -0,0 +1,9 @@
// Kotlin Native v0.2
import kotlinx.cinterop.*
import string.*
fun main(args: Array<String>) {
val hw = strdup ("Hello World!")!!.toKString()
println(hw)
}

3
Task/Call-a-foreign-language-function/Nimrod/call-a-foreign-language-function.nimrod
View file

@ -1,3 +0,0 @@
proc strcmp(a, b: cstring): cint {.importc: "strcmp", nodecl.}
echo strcmp("abc", "def")
echo strcmp("hello", "hello")

42
Task/Call-a-foreign-language-function/Ruby/call-a-foreign-language-function-1.rb
View file

@ -1,14 +1,34 @@
require 'ffi'
/* rc_strdup.c */
#include <stdlib.h> /* free() */
#include <string.h> /* strdup() */
#include <ruby.h>
module LibC
extend FFI::Library
ffi_lib FFI::Platform::LIBC
static VALUE
rc_strdup(VALUE obj, VALUE str_in)
{
VALUE str_out;
char *c, *d;
attach_function :strdup, [:string], :pointer
attach_function :free, [:pointer], :void
end
/*
* Convert Ruby value to C string. May raise TypeError if the
* value isn't a string, or ArgumentError if it contains '\0'.
*/
c = StringValueCStr(str_in);
string = "Hello, World!"
duplicate = LibC.strdup(string)
puts duplicate.get_string(0)
LibC.free(duplicate)
/* Call strdup() and perhaps raise Errno::ENOMEM. */
d = strdup(c);
if (d == NULL)
rb_sys_fail(NULL);
/* Convert C string to Ruby string. */
str_out = rb_str_new_cstr(d);
free(d);
return str_out;
}
void
Init_rc_strdup(void)
{
VALUE mRosettaCode = rb_define_module("RosettaCode");
rb_define_module_function(mRosettaCode, "strdup", rc_strdup, 1);
}

22
Task/Call-a-foreign-language-function/Ruby/call-a-foreign-language-function-2.rb
View file

@ -1,19 +1,3 @@
require 'dl'
require 'fiddle'
# Declare strdup().
# * DL::Handle['strdup'] is the address of the function.
# * The function takes a pointer and returns a pointer.
strdup = Fiddle::Function.new(DL::Handle['strdup'],
[DL::TYPE_VOIDP], DL::TYPE_VOIDP)
# Call strdup().
# * Fiddle converts our Ruby string to a C string.
# * Fiddle returns a DL::CPtr.
duplicate = strdup.call("This is a string!")
# DL::CPtr#to_s converts our C string to a Ruby string.
puts duplicate.to_s
# We must call free(), because strdup() allocated memory.
DL.free duplicate
# extconf.rb
require 'mkmf'
create_makefile('rc_strdup')

36
Task/Call-a-foreign-language-function/Ruby/call-a-foreign-language-function-3.rb
View file

@ -1,33 +1,3 @@
require 'rubygems'
require 'inline'
class InlineTester
def factorial_ruby(n)
(1..n).inject(1, :*)
end
inline do |builder|
builder.c <<-'END_C'
long factorial_c(int max) {
long result = 1;
int i;
for (i = 1; i <= max; ++i)
result *= i;
return result;
}
END_C
end
inline do |builder|
builder.include %q("math.h")
builder.c <<-'END_C'
int my_ilogb(double value) {
return ilogb(value);
}
END_C
end
end
t = InlineTester.new
11.upto(14) {|n| p [n, t.factorial_ruby(n), t.factorial_c(n)]}
p t.my_ilogb(1000)
# demo.rb
require 'rc_strdup'
puts RosettaCode.strdup('This string gets duplicated.')

14
Task/Call-a-foreign-language-function/Ruby/call-a-foreign-language-function-4.rb Normal file
View file

@ -0,0 +1,14 @@
require 'ffi'
module LibC
extend FFI::Library
ffi_lib FFI::Platform::LIBC
attach_function :strdup, [:string], :pointer
attach_function :free, [:pointer], :void
end
string = "Hello, World!"
duplicate = LibC.strdup(string)
puts duplicate.get_string(0)
LibC.free(duplicate)

13
Task/Call-a-foreign-language-function/Ruby/call-a-foreign-language-function-5.rb Normal file
View file

@ -0,0 +1,13 @@
require 'fiddle'
# Find strdup(). It takes a pointer and returns a pointer.
strdup = Fiddle::Function
.new(Fiddle::Handle['strdup'],
[Fiddle::TYPE_VOIDP], Fiddle::TYPE_VOIDP)
# Call strdup().
# - It converts our Ruby string to a C string.
# - It returns a Fiddle::Pointer.
duplicate = strdup.call("This is a string!")
puts duplicate.to_s # Convert the C string to a Ruby string.
Fiddle.free duplicate # free() the memory that strdup() allocated.

12
Task/Call-a-foreign-language-function/Ruby/call-a-foreign-language-function-6.rb Normal file
View file

@ -0,0 +1,12 @@
require 'fiddle'
require 'fiddle/import'
module C
extend Fiddle::Importer
dlload Fiddle::Handle::DEFAULT
extern 'char *strdup(char *)'
end
duplicate = C.strdup("This is a string!")
puts duplicate.to_s
Fiddle.free duplicate

33
Task/Call-a-foreign-language-function/Ruby/call-a-foreign-language-function-7.rb Normal file
View file

@ -0,0 +1,33 @@
require 'rubygems'
require 'inline'
class InlineTester
def factorial_ruby(n)
(1..n).inject(1, :*)
end
inline do |builder|
builder.c <<-'END_C'
long factorial_c(int max) {
long result = 1;
int i;
for (i = 1; i <= max; ++i)
result *= i;
return result;
}
END_C
end
inline do |builder|
builder.include %q("math.h")
builder.c <<-'END_C'
int my_ilogb(double value) {
return ilogb(value);
}
END_C
end
end
t = InlineTester.new
11.upto(14) {|n| p [n, t.factorial_ruby(n), t.factorial_c(n)]}
p t.my_ilogb(1000)

14
Task/Call-a-foreign-language-function/Stata/call-a-foreign-language-function-1.stata Normal file
View file

@ -0,0 +1,14 @@
#include <stdlib.h>
#include "stplugin.h"
STDLL stata_call(int argc, char *argv[]) {
int i, j, n = strtol(argv[1], NULL, 0);
for (i = 1; i <= n; i++) {
for (j = 1; j <= n; j++) {
// Don't forget array indices are 1-based in Stata.
SF_mat_store(argv[0], i, j, 1.0/(double)(i+j-1));
}
}
return 0;
}

6
Task/Call-a-foreign-language-function/Stata/call-a-foreign-language-function-2.stata Normal file
View file

@ -0,0 +1,6 @@
program hilbert
matrix define `1'=J(`2',`2',0)
plugin call hilbertmat, `1' `2'
end
program hilbertmat, plugin

10
Task/Call-a-foreign-language-function/Stata/call-a-foreign-language-function-3.stata Normal file
View file

@ -0,0 +1,10 @@
. hilbert mymat 4
. matrix list mymat
symmetric mymat[4,4]
c1 c2 c3 c4
r1 1
r2 .5 .33333333
r3 .33333333 .25 .2
r4 .25 .2 .16666667 .14285714

16
Task/Call-a-foreign-language-function/Stata/call-a-foreign-language-function-4.stata Normal file
View file

@ -0,0 +1,16 @@
import com.stata.sfi.*;
public class HilbertMatrix {
public static int run(String[] args) {
int n, i, j;
n = Integer.parseInt(args[1]);
Matrix.createMatrix(args[0], n, n, 0.0);
for (i = 0; i < n; i++) {
for (j = 0; j < n; j++) {
// Unlike Stata and the C API, indices are 0-based in the Java API.
Matrix.storeMatrixAt(args[0], i, j, 1.0/(double)(i+j+1));
}
}
return 0;
}
}

10
Task/Call-a-foreign-language-function/Stata/call-a-foreign-language-function-5.stata Normal file
View file

@ -0,0 +1,10 @@
. javacall HilbertMatrix run, classpath(K:\java) args(mymat 4)
. matrix list mymat
symmetric mymat[4,4]
c1 c2 c3 c4
r1 1
r2 .5 .33333333
r3 .33333333 .25 .2
r4 .25 .2 .16666667 .14285714

9
Task/Call-a-foreign-language-function/Stata/call-a-foreign-language-function-6.stata Normal file
View file

@ -0,0 +1,9 @@
. mata: Hilbert(4)
[symmetric]
1 2 3 4
+---------------------------------------------------------+
1 | 1 |
2 | .5 .3333333333 |
3 | .3333333333 .25 .2 |
4 | .25 .2 .1666666667 .1428571429 |
+---------------------------------------------------------+

36
Task/Call-a-foreign-language-function/Zkl/call-a-foreign-language-function.zkl Normal file
View file

@ -0,0 +1,36 @@
//-*-c-*-
// flf.c, Call a foreign-language function
// export zklRoot=/home/ZKL
// clang -O -fPIC -I $zklRoot/VM -c -o flf.o flf.c
// clang flf.o -L$zklRoot/Lib -lzkl -shared -Wl,-soname,flf.so -o flf.so
#include <string.h>
#include "zklObject.h"
#include "zklMethod.h"
#include "zklString.h"
#include "zklImports.h"
// strlen(str)
static Instance *zkl_strlen(Instance *_,pArglist arglist,pVM vm)
{
Instance *s = arglistGetString(arglist,0,"strlen",vm);
size_t sz = strlen(stringText(s));
return intCreate(sz,vm);
}
static int one;
DllExport void *construct(void *vm)
{
if (!vm) return (void *)ZKLX_PROTOCOL; // handshake
// If this is reloaded, nothing happens except
// construct() is called again so don't reinitialize
if (!one) // static items are zero
{
// do some one time initialization
one = 1;
}
return methodCreate(Void,0,zkl_strlen,vm);
}