├── examples ├── import-test.pl ├── ImportTest.pm ├── compcv-is-null.pl ├── cq.pl ├── csub.pl ├── type-example.pl ├── libobjmg.pl ├── magic-objects │ ├── sos-04-new-attribute.pl │ ├── sos-03-simple-subclass.pl │ ├── sos-01-create-destroy.pl │ ├── sos-05-SOS.pl │ ├── SOS02.pm │ ├── sos-02-refcount-inc.pl │ ├── SOS05.pm │ ├── SOS03.pm │ └── SOS04.pm ├── libprima.pm ├── point-example.pl ├── csub-few-macros.pl ├── prima-lib-ellipse.pl ├── pdl-periodogram.pl ├── prima-ellipse.pl ├── mgpoint.pm └── primatest.pl ├── .travis.yml ├── bench ├── matrix-mult │ ├── mult.pdl │ ├── generate.pl │ ├── mult.cbl3 │ ├── mult.cbl2 │ └── mult.cbl ├── rng │ ├── MyRNG.pm │ ├── rng4.pl │ ├── rng3.pl │ ├── rng2.pl │ └── rng.pl ├── plot-bench.pl ├── euclidean-distance.pl ├── avg.pl ├── xs-tcc-naive-bench.pl ├── set-av.pl ├── mandelbrot │ ├── mandelbrot.pdl │ ├── mandelbrot5.pdl │ ├── mandelbrot2.pdl │ ├── mandelbrot3.pdl │ ├── mandelbrot.cpl │ ├── mandelbrot3.cpl │ ├── mandelbrot4.pdl │ └── mandelbrot2.cpl ├── prime-numbers.pl ├── random-access │ └── random-access.pl └── c-blocks-vs-inline.pl ├── travis.notes ├── problems ├── null-op-pointer.pl ├── interpolation-blocks-package.pl └── memory-leak.pl ├── src ├── cb_utils.h ├── cb_mem_mgmt.h ├── cb_custom_op.h ├── cb_c_blocks_data.h ├── cb_utils.c ├── cb_custom_op.c ├── cb_code_parser_extractor.h └── cb_mem_mgmt.c ├── t ├── 06-double-colon.t ├── 36-API-Creation.t ├── 40-csub.t ├── 22-keyword-scoping.t ├── 55-types.t ├── 18-clex-global-vars.t ├── 07-compiler-setup.t ├── 05-brace-counting.t ├── 99-stdio-fails.t ├── 02-use-and-no.t ├── 21-cshare-warnings.t ├── 15-clex-with-define.t ├── 35-API-Memory.t ├── 82b-IsaStruct.t ├── 08-lexical-compiler-warnings.t ├── 03-line-counting.t ├── 03-error-reporting.t ├── 80-StretchyBuffer.t ├── 13-clex-struct.t ├── 17-clex-define-undefine-series.t ├── 82a-Struct.t ├── 11-clex-series.t ├── 04-PerlAPI.t ├── 01-basics.t ├── 09-cleanup.t ├── 60-filters.t ├── 06-interpolation.t ├── 19-clex-binds-correct-scope.t ├── 16-clex-scoping.t ├── 12-clex-struct.t ├── 50-sigiled-vars.t ├── 20-cshare.t ├── 10-clex.t ├── 81-Object-Magic.t └── 30-API-SV.t ├── appveyor.yml ├── .gitignore ├── MANIFEST ├── lib └── C │ └── Blocks │ ├── Filter │ └── BlockArrowMethods.pm │ ├── PerlAPI.pm │ ├── Types │ ├── Pointers.pm │ └── IsaStruct.pm │ ├── Filter.pm │ └── Types.pm ├── Build.PL ├── valgrind-suppressions.supp └── Changes /examples/import-test.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use C::Blocks; 5 | use ImportTest; 6 | cblock { 7 | foo(); 8 | } 9 | print "Done!\n"; 10 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | perl: 3 | - "5.22" 4 | - "5.20" 5 | - "5.18" 6 | - "5.16" 7 | - "5.14" 8 | 9 | before_install: 10 | - cpanm Alien::TinyCCx 11 | - cpanm --installdeps --notest . 12 | -------------------------------------------------------------------------------- /bench/matrix-mult/mult.pdl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use PDL; 4 | use PDL::IO::FastRaw; 5 | my $A = readfraw('A.bin'); 6 | my $B = readfraw('B.bin'); 7 | #print "A x B is ", $A x $B, "\n"; 8 | print ${($A x $B)->get_dataref}; 9 | -------------------------------------------------------------------------------- /travis.notes: -------------------------------------------------------------------------------- 1 | Look at the following travis config files: 2 | 3 | OS X only: 4 | https://github.com/agordon/pretest-macos-runs/blob/master/.travis.yml 5 | 6 | Linux and OS X together: 7 | https://github.com/agordon/tinycc-mirror/blob/mob/.travis.yml 8 | -------------------------------------------------------------------------------- /problems/null-op-pointer.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | 5 | # removing static clears up the issue 6 | clex { 7 | static unsigned int x; 8 | } 9 | 10 | #use C::Blocks::Filter; 11 | cblock { 12 | x = 123456789; 13 | } 14 | 15 | -------------------------------------------------------------------------------- /src/cb_utils.h: -------------------------------------------------------------------------------- 1 | #ifndef CB_UTILS_H_ 2 | #define CB_UTILS_H_ 3 | 4 | /* General utilities that have to be used across multiple files. 5 | * Obviously, adding things here should be done sparingly... */ 6 | 7 | #include 8 | #include 9 | 10 | /* Lexical Perl warnings */ 11 | void cb_warnif (pTHX_ const char * category, SV * message); 12 | 13 | #endif 14 | -------------------------------------------------------------------------------- /bench/matrix-mult/generate.pl: -------------------------------------------------------------------------------- 1 | # Generates the test matrices for the benchmark 2 | 3 | use strict; 4 | use warnings; 5 | use PDL; 6 | use PDL::IO::FastRaw; 7 | 8 | my $size = shift || 200; 9 | 10 | my $template = zeros($size, $size); 11 | ($template->grandom * 20)->short->double->writefraw('A.bin'); 12 | ($template->grandom * 20)->short->double->writefraw('B.bin'); 13 | 14 | -------------------------------------------------------------------------------- /examples/ImportTest.pm: -------------------------------------------------------------------------------- 1 | package ImportTest; 2 | 3 | use strict; 4 | use warnings; 5 | use C::Blocks; 6 | use C::Blocks::PerlAPI; 7 | 8 | cshare { 9 | int foo() { 10 | printf("Hello from TestMe!\n"); 11 | } 12 | } 13 | 14 | no warnings 'C::Blocks::import', 'redefine'; 15 | sub import { 16 | print "Importing from TestMe\n"; 17 | # goto &C::Blocks::load_lib 18 | C::Blocks::load_lib(@_); 19 | } 20 | 21 | 1; 22 | -------------------------------------------------------------------------------- /t/06-double-colon.t: -------------------------------------------------------------------------------- 1 | # This tests double-colon handling. 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | # Load cblocks 8 | use C::Blocks -noPerlAPI; 9 | 10 | cblock { 11 | int some__variable; 12 | some::variable = 10; 13 | } 14 | BEGIN { pass 'cblock using empty-string interpolation compiles fine' } 15 | is($@, '', 'Executing double-colon-using glorified no-op is fine'); 16 | 17 | done_testing; 18 | -------------------------------------------------------------------------------- /appveyor.yml: -------------------------------------------------------------------------------- 1 | branches: 2 | only: 3 | - master 4 | 5 | init: 6 | - git config --global core.autocrlf input 7 | 8 | install: 9 | - cinst strawberryperl --version 5.20.1.1 10 | - SET PATH=C:\strawberry\c\bin;C:\strawberry\perl\site\bin;C:\strawberry\perl\bin;%PATH% 11 | - cpanm --installdeps --notest . 12 | 13 | build_script: 14 | - perl Build.PL 15 | - Build 16 | 17 | test_script: 18 | - Build test verbose=1 19 | -------------------------------------------------------------------------------- /problems/interpolation-blocks-package.pl: -------------------------------------------------------------------------------- 1 | # Test of 2 | use strict; 3 | use warnings; 4 | 5 | # Uncomment to trigger compile-time error: 6 | # Undefined subroutine &main::foo called at (eval 7) line 2. 7 | package TEST; 8 | 9 | use C::Blocks; 10 | use C::Blocks::PerlAPI; 11 | 12 | sub foo { 13 | print "caller is " . caller . "\n"; 14 | '' 15 | } 16 | 17 | cblock { 18 | printf("from C\n"); 19 | ${ 20 | foo(); 21 | } 22 | } 23 | -------------------------------------------------------------------------------- /examples/compcv-is-null.pl: -------------------------------------------------------------------------------- 1 | package TestType; 2 | package main; 3 | 4 | use strict; 5 | use warnings; 6 | use C::Blocks; 7 | use C::Blocks::PerlAPI; 8 | my TestType $foo; 9 | 10 | cblock { 11 | printf("PL_compcv is 0x%p\n", PL_compcv); 12 | printf("Perl thinks this is "); 13 | if (!CvISXSUB(PL_compcv)) printf("not "); 14 | printf("an XSUB\n"); 15 | // HV * stash = PadnameTYPE($foo); 16 | // printf("stash has address %p\n", stash); 17 | // if (stash) printf("$foo has a type %s\n", HvNAME(stash)); 18 | } 19 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Combination of ignore and unignore to ignore files without extensions 2 | * 3 | !*.* 4 | !*/ 5 | 6 | 7 | *.o 8 | _build 9 | blib 10 | MYMETA* 11 | META* 12 | inc/Alien/TinyCC.pm 13 | lib/C/Blocks/PerlAPI.xs 14 | MANIFEST.SKIP.bak 15 | share/ 16 | names.txt 17 | *.bin 18 | *.bin.hdr 19 | *.swp 20 | *.swo 21 | lib/C/Blocks.c 22 | lib/C/Blocks/PerlAPI.c 23 | 24 | # Mandelbrot benchmark-related files 25 | bench/mandelbrot/mandelbrot.perl 26 | bench/mandelbrot/mandelbrot.c 27 | bench/mandelbrot/_Inline/ 28 | *.pbm 29 | -------------------------------------------------------------------------------- /t/36-API-Creation.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks; 5 | 6 | cblock { 7 | SV * my_sv = newSV(10); 8 | SvREFCNT_dec(my_sv); 9 | } 10 | BEGIN { pass 'newSV does not cause croak' } 11 | 12 | cblock { 13 | AV * my_av = newAV(); 14 | SvREFCNT_dec(my_av); 15 | } 16 | BEGIN { pass 'newAV does not cause croak' } 17 | 18 | cblock { 19 | HV * my_hv = newHV(); 20 | SvREFCNT_dec(my_hv); 21 | } 22 | BEGIN { pass 'newHV does not cause croak' } 23 | 24 | pass 'Script executes without trouble'; 25 | done_testing; 26 | 27 | -------------------------------------------------------------------------------- /src/cb_mem_mgmt.h: -------------------------------------------------------------------------------- 1 | #ifndef CB_MEM_MGMT_H_ 2 | #define CB_MEM_MGMT_H_ 3 | 4 | /* Logic related to implementing, creating, and managing the C::Blocks 5 | * custom ops. */ 6 | 7 | #include 8 | #include 9 | 10 | void *cb_mem_alloc(size_t n_bytes); 11 | 12 | /* Needs to be called before using C::Blocks to initialize the 13 | * executable_memory state. */ 14 | void cb_mem_mgmt_init(); 15 | /* Needs to be called during global destruction to free the 16 | * executable_memory state. */ 17 | void cb_mem_mgmt_cleanup(); 18 | 19 | #endif 20 | -------------------------------------------------------------------------------- /src/cb_custom_op.h: -------------------------------------------------------------------------------- 1 | #ifndef CB_CUSTOM_OP_H_ 2 | #define CB_CUSTOM_OP_H_ 3 | 4 | /* Logic related to implementing, creating, and managing the C::Blocks 5 | * custom ops. */ 6 | 7 | #include 8 | #include 9 | 10 | extern XOP tcc_xop; 11 | 12 | /* Create a new OP that'll execute the given symbol pointer. */ 13 | OP * cb_build_op(pTHX_ void *sym_pointer); 14 | 15 | /* Sets up the global state related to our custom OP(s). 16 | * To be called once before using any of them (eg. BEGIN time of C::Blocks) */ 17 | void cb_init_custom_op(pTHX); 18 | 19 | 20 | #endif 21 | -------------------------------------------------------------------------------- /problems/memory-leak.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | 5 | sub get_mem_usage { 6 | my $info = `ps -q $$ aux`; 7 | $info =~ /\n\S+\s+\S+\s+\S+\s+\S+\s+(\d+)/ 8 | or die "Unable to get memory!\n"; 9 | return $1; 10 | } 11 | my $mem = get_mem_usage; 12 | print "Initial memory consumption: $mem\n"; 13 | 14 | my $limit = shift (@ARGV) || 100; 15 | for my $iterations (1 .. $limit) { 16 | eval q{ 17 | cblock { 18 | int i = 0; 19 | i++; 20 | } 21 | }; 22 | if ($iterations % 100 == 0) { 23 | $mem = get_mem_usage; 24 | print "Memory consumption: $mem\n"; 25 | } 26 | } 27 | -------------------------------------------------------------------------------- /src/cb_c_blocks_data.h: -------------------------------------------------------------------------------- 1 | #ifndef CB_C_BLOCKS_DATA_H_ 2 | #define CB_C_BLOCKS_DATA_H_ 3 | 4 | /* For now, this header will hold the widely-used typedefs/struct definitions 5 | * for the global state. That's not an ideal structure, but transiently 6 | * unavoidable. */ 7 | 8 | typedef struct c_blocks_data { 9 | char * end; 10 | char * xs_c_name; 11 | char * xs_perl_name; 12 | char * xsub_name; 13 | SV * exsymtabs; 14 | SV * code_top; 15 | SV * code_main; 16 | SV * code_bottom; 17 | SV * error_msg_sv; 18 | int N_newlines; 19 | int keep_curly_brackets; 20 | int add_test; 21 | } c_blocks_data; 22 | 23 | 24 | 25 | #endif 26 | -------------------------------------------------------------------------------- /src/cb_utils.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | #include 4 | 5 | void cb_warnif (pTHX_ const char * category, SV * message) { 6 | dSP; 7 | 8 | /* Prepare the stack */ 9 | ENTER; 10 | SAVETMPS; 11 | 12 | /* Push the category and message onto the stack. The message must 13 | * be a mortalized SV. */ 14 | PUSHMARK(SP); 15 | XPUSHs(sv_2mortal(newSVpvf("C::Blocks::%s", category))); 16 | XPUSHs(message); 17 | PUTBACK; 18 | 19 | /* Call */ 20 | /* XXX why can't I just call warnings::warnif??? */ 21 | call_pv("C::Blocks::warnif", G_VOID); 22 | 23 | /* cleanup */ 24 | FREETMPS; 25 | LEAVE; 26 | } 27 | 28 | -------------------------------------------------------------------------------- /bench/rng/MyRNG.pm: -------------------------------------------------------------------------------- 1 | # MyRNG.pm 2 | package MyRNG; 3 | use strict; 4 | use warnings; 5 | use C::Blocks; 6 | use C::Blocks::Types qw(uint); 7 | 8 | # Implement KISS random number generator, copy-and-pasted from 9 | # http://www0.cs.ucl.ac.uk/staff/d.jones/GoodPracticeRNG.pdf 10 | cshare { 11 | unsigned int x = 123456789,y = 362436000, 12 | z = 521288629,c = 7654321; /* State variables */ 13 | 14 | unsigned int KISS() { 15 | unsigned long long t, a = 698769069ULL; 16 | x = 69069*x+12345; 17 | y ^= (y<<13); y ^= (y>>17); y ^= (y<<5); 18 | t = a*z+c; c = (t>>32); 19 | return x+y+(z=t); 20 | } 21 | } 22 | 1; 23 | 24 | -------------------------------------------------------------------------------- /examples/cq.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | 5 | sub salutation_filter { 6 | s/Hello/Goodbye/g; 7 | } 8 | use C::Blocks::Filter qw(&salutation_filter); 9 | 10 | print "Here is a block of C code\n[", cq { printf("Hello!\n"); }, "]\n"; 11 | 12 | my $var = 'Foo'; 13 | 14 | my $code = cq { 15 | Foo 16 | interpolated: "$var" 17 | Escapes: "\n" 18 | }; 19 | 20 | print "funny code is [$code]\n"; 21 | 22 | print '-' x 20, "\n"; 23 | 24 | #line 1 cq.pl 25 | my $func_name = 'sum'; 26 | my $op = '+'; 27 | my $code = cq { 28 | printf("Performing '$func_name'\n"); 29 | RESULT = a $op b; 30 | }; 31 | print "Code is [$code]\n"; 32 | -------------------------------------------------------------------------------- /examples/csub.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | use C::Blocks::PerlAPI; 5 | 6 | csub csum { 7 | /* get "items" variable, and stack pointer variables used by ST() */ 8 | dXSARGS; 9 | 10 | int i; 11 | double sum = 0.; 12 | 13 | /* Sum the given numeric values. */ 14 | for (i = 0; i < items; ++i) sum += SvNV( ST(i) ); 15 | 16 | /* Prepare stack to receive return values. */ 17 | XSprePUSH; 18 | /* Push the sum onto the return stack */ 19 | mXPUSHn(sum); 20 | /* Indicate we're returning a single value on the stack. */ 21 | XSRETURN(1); 22 | } 23 | 24 | my $limit = shift || 5; 25 | 26 | my $return = csum(1 .. $limit); 27 | print "sum of 1 to $limit is $return\n"; 28 | -------------------------------------------------------------------------------- /t/40-csub.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks; 5 | 6 | # Tell C::Blocks to add rudimentary communications functions for testing 7 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 8 | 9 | # Start with a known (blank) message 10 | $C::Blocks::_msg = ''; 11 | 12 | # Create a csub that sets the message to a known string 13 | csub set_msg_to_hello { 14 | c_blocks_send_msg("Hello!"); 15 | } 16 | 17 | BEGIN { pass 'csub compiles without trouble' } 18 | pass('At runtime, csub gets skipped without trouble'); 19 | is($C::Blocks::_msg, '', 'No side-effects before calling csub'); 20 | 21 | set_msg_to_hello(); 22 | is($C::Blocks::_msg, 'Hello!', 'csub has desired effect'); 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /t/22-keyword-scoping.t: -------------------------------------------------------------------------------- 1 | # This tests the import/unimport lexical behavior of the C::Blocks keywords. 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More tests => 3; 6 | 7 | SCOPE: { 8 | use C::Blocks -noPerlAPI; 9 | ok( 10 | eval q[cblock { int i; } 1], 11 | "Compiled C block within C::Blocks scope" 12 | ); 13 | SCOPE: { 14 | no C::Blocks; 15 | local $SIG{__WARN__} = sub {}; 16 | ok( 17 | !eval q[cblock { int i; } 1], 18 | "Expectedly failed to compile C block within 'no C::Blocks' scope" 19 | ); 20 | } 21 | } 22 | 23 | 24 | local $SIG{__WARN__} = sub {}; 25 | ok( 26 | !eval q[cblock { int i; } 1], 27 | "Expectedly failed to compile C block outside C::Blocks scope" 28 | ); 29 | 30 | 31 | 32 | 33 | -------------------------------------------------------------------------------- /bench/plot-bench.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | my %to_plot; 5 | while (<>) { 6 | if (/N = (\d+)/) { 7 | $to_plot{N} ||= []; 8 | push @{$to_plot{N}}, $1; 9 | } 10 | elsif (/^\s*(\w+): (\d+\.\d+(e-\d+)?)/) { 11 | $to_plot{$1} ||= []; 12 | push @{$to_plot{$1}}, $2; 13 | } 14 | } 15 | 16 | use PDL; 17 | use PDL::Graphics::Prima::Simple; 18 | my $xs = pdl($to_plot{N}); 19 | my %plot_args; 20 | for my $column (keys %to_plot) { 21 | next if $column eq 'N'; 22 | $plot_args{-$column} = ds::Pair($xs, pdl($to_plot{$column}), 23 | plotType => ppair::Lines); 24 | } 25 | plot(%plot_args, 26 | x => { 27 | label => '$N_{rand}$', 28 | scaling => sc::Log, 29 | }, 30 | y => { 31 | label => 'Time (s)', 32 | scaling => sc::Log 33 | } 34 | ); 35 | -------------------------------------------------------------------------------- /examples/type-example.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | use C::Blocks::Types qw(double double_array Int); 5 | 6 | # Generate some synthetic data; 7 | my @data = map { rand() } 1 .. 10; 8 | print "data are @data\n"; 9 | 10 | # Pack this data into a C array 11 | my double_array $points = pack 'd*', @data; 12 | 13 | # Calculate the rms (root mean square) 14 | my double $rms = 0; 15 | cblock { 16 | for (int i = 0; i < length_$points; i++) { 17 | $rms += $points[i]*$points[i]; 18 | } 19 | $rms = sqrt($rms / length_$points); 20 | } 21 | 22 | print "data rms is $rms\n"; 23 | 24 | # Note that Int is capitalized, unlike the other type names 25 | my Int $foo = 4; 26 | cblock { 27 | printf("$foo is %d\n", $foo); 28 | } 29 | -------------------------------------------------------------------------------- /t/55-types.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks; 5 | use C::Blocks::Types qw(:all); 6 | 7 | my NV $var = 23; 8 | 9 | cblock { $var = 10.5; } 10 | is($var, 10.5, 'NV works'); 11 | 12 | my uint $unsigned = 0; 13 | cblock { $unsigned = 5; } 14 | is($unsigned, 5, 'uint works'); 15 | 16 | my Int $signed = 0; 17 | cblock { $signed = -5; } 18 | is($signed, -5, 'Int works'); 19 | 20 | 21 | # Taken from http://stackoverflow.com/questions/483622/how-can-i-catch-the-output-from-a-carp-in-perl 22 | my Int $foo; 23 | my $stderr = ''; 24 | { 25 | local *STDERR; 26 | open STDERR, '>', \$stderr; 27 | cblock { 28 | $foo = 3.5; /* should warn */ 29 | } 30 | } 31 | like($stderr, qr/uninitialized value/, 'Standard types on uninitialized values warn'); 32 | 33 | done_testing; 34 | -------------------------------------------------------------------------------- /examples/libobjmg.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use mgpoint; 4 | 5 | # Perl-side constructor and methods 6 | my $thing = mgpoint->new; 7 | $thing->set(3, 4); 8 | print "Distance to ", $thing->name, " is ", $thing->distance_1, "\n"; 9 | $thing->name('Random Point'); 10 | 11 | # Access data from C-side... 12 | use C::Blocks; 13 | cblock { 14 | data_from_SV($thing)->x = 5; 15 | } 16 | # ... and illustrate that the modifications are Perl accessible 17 | print "After manual cblock, distance to ", $thing->name, " is ", $thing->distance_2, "\n"; 18 | 19 | # Use cisa to make data manipulation code even cleaner 20 | { 21 | # A typed alias 22 | my mgpoint $thing2 = $thing; 23 | cblock { 24 | $thing2->x = 7; 25 | } 26 | } 27 | print "After cblock, distance to ", $thing->name, " is ", $thing->distance_3, "\n"; 28 | -------------------------------------------------------------------------------- /t/18-clex-global-vars.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks -noPerlAPI; 5 | 6 | ###### Create a lexically scoped global variable ###### 7 | 8 | # Declare a global that we'll use throughout 9 | clex { double A; } 10 | 11 | BEGIN { pass('Lexical block with global compiles fine') } 12 | 13 | # Initialize the global 14 | cblock { A = 20; } 15 | 16 | BEGIN { pass('Block that uses the global compiles fine') } 17 | pass('Block that sets the global runs without trouble'); 18 | 19 | #### Does the value of the variable live beyond the end of the block? #### 20 | 21 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 22 | cblock { 23 | c_blocks_send_bytes(&A, sizeof(double)); 24 | } 25 | 26 | my $result = unpack('d', $C::Blocks::_msg); 27 | is($result, 20, 'Global variables have static storage'); 28 | 29 | done_testing; 30 | -------------------------------------------------------------------------------- /t/07-compiler-setup.t: -------------------------------------------------------------------------------- 1 | # This tests compiler setup. 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | # Load cblocks 8 | use C::Blocks -noPerlAPI; 9 | 10 | # Does -D work? 11 | BEGIN { 12 | $C::Blocks::_add_msg_functions = 1; 13 | $C::Blocks::compiler_options = '-Wall -Dtest_foo'; 14 | } 15 | $C::Blocks::_msg = ''; 16 | cblock { 17 | #ifdef test_foo 18 | c_blocks_send_msg("1"); 19 | #endif 20 | } 21 | ok ($C::Blocks::_msg, "compiler_options supports -D preprocessor definitions"); 22 | 23 | # Is compiler option cleared after block is compiled? 24 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 25 | cblock { 26 | #ifdef test_foo 27 | c_blocks_send_msg("2"); 28 | #else 29 | c_blocks_send_msg("3"); 30 | #endif 31 | } 32 | is ($C::Blocks::_msg, 3, "compiler_options cleared before next block"); 33 | 34 | 35 | done_testing; 36 | -------------------------------------------------------------------------------- /t/05-brace-counting.t: -------------------------------------------------------------------------------- 1 | # This tests the brace counting logic to make sure it catches the 2 | # important situations. 3 | 4 | use strict; 5 | use warnings; 6 | use Test::More; 7 | 8 | # Load cblocks 9 | use C::Blocks -noPerlAPI; 10 | 11 | eval q{ 12 | cblock { 13 | /* } { */ 14 | } 15 | }; 16 | is($@, '', 'Braces are ignored in C-style blocks'); 17 | 18 | eval q{ 19 | cblock { 20 | char * foo = " } { "; 21 | } 22 | }; 23 | is($@, '', 'Braces are ignored in double-quoted strings'); 24 | 25 | eval q{ 26 | cblock { 27 | // } { 28 | } 29 | }; 30 | is($@, '', 'Braces are ignored in C++ comments'); 31 | 32 | eval q{ 33 | cblock { 34 | // } \ 35 | { 36 | } 37 | }; 38 | is($@, '', 'Braces are ignored in pathological C++ comments'); 39 | 40 | 41 | eval q{ 42 | cblock { 43 | char a = '}'; 44 | char b = '{'; 45 | } 46 | }; 47 | is($@, '', 'Braces are ignored in single-quoted strings'); 48 | 49 | done_testing; 50 | -------------------------------------------------------------------------------- /t/99-stdio-fails.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | # I will construct my tap by hand in order to get the right results 5 | BEGIN { 6 | $| = 1; 7 | print "1..7\n"; 8 | } 9 | 10 | # Make sure it loads 11 | use C::Blocks; 12 | BEGIN { 13 | print "ok 1 - loaded C::Blocks\n"; 14 | } 15 | 16 | clex { 17 | #include 18 | } 19 | 20 | # First real print 21 | cblock { 22 | printf("ok 2 - printf from C block\n"); 23 | } 24 | 25 | cblock { 26 | // #include 27 | printf("ok 3 - multiple C blocks compile and run correctly\n"); 28 | } 29 | 30 | eval q{ 31 | cblock { 32 | // #include 33 | printf("ok 4 - string evals work\n"); 34 | } 35 | 1; 36 | } or do { 37 | print "not ok 4 - string evals work\n"; 38 | }; 39 | 40 | for (5 .. 7) { 41 | eval qq{ 42 | cblock { 43 | // #include 44 | printf("ok $_ - repeated string evals work!\\n"); 45 | } 46 | 1; 47 | } or do { 48 | printf("not ok $_ - repeated string evals work!\n"); 49 | } 50 | } 51 | -------------------------------------------------------------------------------- /t/02-use-and-no.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | # In order to delay the compilation until run (i.e. test) time, we have 6 | # to wrap these in string evals. 7 | eval q{ 8 | # Should work 9 | use C::Blocks -noPerlAPI; 10 | cblock { 11 | int i = 0; 12 | } 13 | }; 14 | is($@, '', 'Compilation works fine'); 15 | 16 | eval q{ 17 | # Should work 18 | use C::Blocks -noPerlAPI; 19 | cblock { 20 | int i = 0; 21 | } 22 | 23 | # Should fail to compile 24 | no C::Blocks; 25 | cblock { 26 | int i = 0; 27 | } 28 | }; 29 | isnt($@, '', 'saying no C::Blocks then using "cblock" issues exception'); 30 | like($@, qr/syntax error .* near "cblock/, 'the exception is due to bad "cblock" keyword'); 31 | 32 | eval q{ 33 | use C::Blocks -noPerlAPI; 34 | cblock { 35 | int i = 0; 36 | } 37 | 38 | no C::Blocks; 39 | 40 | my $foo = 1; 41 | 42 | use C::Blocks -noPerlAPI; 43 | cblock { 44 | int i = 0; 45 | } 46 | }; 47 | 48 | is($@, '', 'use => no => use again lets us compile'); 49 | 50 | done_testing; 51 | -------------------------------------------------------------------------------- /t/21-cshare-warnings.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks -noPerlAPI; 5 | use Test::Warn; 6 | 7 | # This tests how warnings are issued when injecting the import method 8 | 9 | # no conflict, no warning 10 | warning_is {eval q{ 11 | package TestPackage1; 12 | cshare { 13 | void foo1() { 14 | int i; 15 | i = 5; 16 | } 17 | } 18 | }} undef, 'No import, no problem!'; 19 | 20 | # redefinition warning 21 | warning_like {eval q{ 22 | package TestPackage2; 23 | sub import { } 24 | cshare { 25 | void foo1() { 26 | int i; 27 | i = 5; 28 | } 29 | } 30 | }} qr/'import' method already found/, 31 | 'Existence of import warns when warnings are enabled'; 32 | 33 | # silenced redefinition warning 34 | warning_is {eval q{ 35 | package TestPackage3; 36 | no warnings 'C::Blocks::import'; 37 | sub import { } 38 | cshare { 39 | void foo1() { 40 | int i; 41 | i = 5; 42 | } 43 | } 44 | }} undef, 'Explicitly turning off C::Blocks::import avoids warning'; 45 | 46 | package main; 47 | done_testing; 48 | -------------------------------------------------------------------------------- /examples/magic-objects/sos-04-new-attribute.pl: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | sos-04-new-attribute.pl - full subclass with a new attribute 4 | 5 | =head1 QUESTION 6 | 7 | This script tests the subclass created in SOS04. 8 | 9 | =cut 10 | 11 | use strict; 12 | use warnings; 13 | use C::Blocks; 14 | use SOS04; 15 | 16 | print "=== creating SOS04 object ===\n"; 17 | my $thing = SOS04->new; 18 | #print "thing is $thing\n"; 19 | #use Devel::Peek; 20 | #Dump($thing); 21 | 22 | my $new_val = int(rand(1000)); 23 | print "=== setting thing's value to $new_val ===\n"; 24 | $thing->set_val($new_val); 25 | 26 | print "=== getting and printing thing's value ===\n"; 27 | print "thing's val is ", $thing->get_val, "\n"; 28 | 29 | print "=== getting rid of SOS04 object ===\n"; 30 | undef $thing; 31 | 32 | print "=== All done! ===\n"; 33 | 34 | =head1 RESULTS 35 | 36 | Everything works as expected. The SOS04 object's new methods are called 37 | from Perl-space as they should be. All refcounting works, as evidenced 38 | by destruction at the proper moment. 39 | 40 | =cut 41 | -------------------------------------------------------------------------------- /bench/matrix-mult/mult.cbl3: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | use C::Blocks::PerlAPI; 5 | use C::Blocks::Type; 6 | 7 | sub load_data { 8 | my ($filename, $data_ref) = @_; 9 | open my $in_fh, '<', $filename or die "Unable to open $filename\n"; 10 | local $/; 11 | $$data_ref = <$in_fh>; 12 | } 13 | 14 | # Load A and B 15 | my ($A, $B); 16 | load_data('A.bin', \$A); 17 | load_data('B.bin', \$B); 18 | 19 | # Check dimensions 20 | length($A) == length($B) or die "Sizes for A and B differ\n"; 21 | my $m = sqrt(length($A) / 8); 22 | $m = int($m) or die "A is not a square matrix\n"; 23 | 24 | # Allocate room for the result 25 | vec (my $C, length($B) - 1, 8) = 0; 26 | 27 | # Use a blas matrix multiply 28 | BEGIN { @C::Blocks::libraries_to_link = ('/usr/lib/libblas.so') } 29 | clex { #include } 30 | 31 | cisa C::Blocks::Type::int $m; 32 | cisa C::Blocks::Type::Buffer::double $A, $B, $C; 33 | 34 | cblock { 35 | cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, $m, $m, $m, 36 | 1.0, $A, $m, $B, $m, 0.0, $C, $m); 37 | } 38 | print $C; 39 | -------------------------------------------------------------------------------- /examples/magic-objects/sos-03-simple-subclass.pl: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | sos-03-simple-subclass.pl - simple subclassing, just changing a method 4 | 5 | =head1 QUESTION 6 | 7 | This script tests the subclass created in SOS03. The only difference is 8 | that new() and the reference count decrement should indicate they were 9 | defined in SOS03; the others are still from SOS01. 10 | 11 | =cut 12 | 13 | use strict; 14 | use warnings; 15 | use C::Blocks; 16 | use SOS01; 17 | use SOS03; 18 | use C::Blocks::Filter::BlockArrowMethods; 19 | 20 | print "=== creating SOS01 object ===\n"; 21 | my $thing = SOS01->new; 22 | 23 | print "=== getting rid of SOS01 object ===\n"; 24 | undef $thing; 25 | 26 | print "=== creating SOS03 object ===\n"; 27 | $thing = SOS03->new; 28 | 29 | print "=== All done! ===\n"; 30 | 31 | =head1 RESULTS 32 | 33 | Everything works as expected. The SOS01 object is created and destroyed 34 | as expected. The SOS03 object utilizes the SOS01 methods for most of its 35 | functionality, but calls SOS03::refcount_dec at the appropriate time. 36 | 37 | =cut 38 | -------------------------------------------------------------------------------- /bench/euclidean-distance.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use C::Blocks; 5 | use PDL; 6 | BEGIN { delete $main::{double} } 7 | use C::Blocks::Types qw(double double_array); 8 | use Benchmark qw(timethese :hireswallclock); 9 | 10 | # Generate some data 11 | my (@data, $pdl_data, $N); 12 | my double_array $packed_data; 13 | for my $log_n (1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 5.5, 6, 6.5, 7) { 14 | $N = 10**$log_n; 15 | print "--- For N = $N ---\n"; 16 | 17 | my @data = map { rand() } 1 .. $N; 18 | $pdl_data = pdl(\@data); 19 | $packed_data = pack('d*', @data); 20 | 21 | timethese(1000, { PDL => \&pdl_euclid, CBlocks => \&c_blocks_euclid}); 22 | print "PDL returned ", pdl_euclid(), " and c_blocks_avg returned ", 23 | c_blocks_euclid(), "\n"; 24 | } 25 | 26 | sub pdl_euclid { 27 | return sqrt(sum($pdl_data*$pdl_data)); 28 | } 29 | 30 | sub c_blocks_euclid { 31 | my double $sum = 0; 32 | cblock { 33 | for (int i = 0; i < array_length($packed_data); i++) { 34 | $sum += $packed_data[i] * $packed_data[i]; 35 | } 36 | } 37 | return sqrt($sum); 38 | } 39 | -------------------------------------------------------------------------------- /bench/avg.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use C::Blocks; 5 | use PDL; 6 | BEGIN { delete $main::{double} } 7 | use C::Blocks::Types qw(double double_array); 8 | use Benchmark qw(timethese :hireswallclock); 9 | 10 | # Generate some data 11 | my (@data, $pdl_data, $N); 12 | my double_array $packed_data; 13 | for my $log_n (1, 2, 3, 4, 5, 6, 7) { 14 | $N = 10**$log_n; 15 | print "--- For N = $N ---\n"; 16 | 17 | @data = map { rand() } 1 .. $N; 18 | $pdl_data = pdl(\@data); 19 | $packed_data = pack('d*', @data); 20 | 21 | timethese(1000, { PDL => \&pdl_avg, CBlocks => \&c_blocks_avg, Perl => \&perl_avg}); 22 | print "PDL returned ", pdl_avg(), " and c_blocks_avg returned ", 23 | c_blocks_avg(), "\n"; 24 | } 25 | 26 | sub pdl_avg { 27 | return $pdl_data->avg; 28 | } 29 | 30 | sub perl_avg { 31 | my $sum = 0; 32 | $sum += $_ foreach @data; 33 | return $sum / @data; 34 | } 35 | 36 | sub c_blocks_avg { 37 | my double $sum = 0; 38 | cblock { 39 | for (int i = 0; i < array_length($packed_data); i++) { 40 | $sum += $packed_data[i]; 41 | } 42 | } 43 | return $sum / $N; 44 | } 45 | -------------------------------------------------------------------------------- /t/15-clex-with-define.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks -noPerlAPI; 5 | 6 | # Tell C::Blocks to add rudimentary communications functions for testing 7 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 8 | 9 | # Build a function that sets a global for me. 10 | clex { 11 | #define get_dbl ((double*)c_blocks_get_msg())[0] 12 | #define send_dbl(to_send) c_blocks_send_bytes(&to_send, sizeof(double)) 13 | } 14 | 15 | BEGIN { 16 | pass('Lexical block with defines compiles without trouble'); 17 | } 18 | pass('At runtime, lexical block gets skipped without trouble'); 19 | 20 | # Generate a random integer between zero and 20, send it 21 | my $number = rand(20) % 20; 22 | $C::Blocks::_msg = pack('d', $number); 23 | 24 | my $double = $number * 2; 25 | # Double it in C 26 | cblock { 27 | double old = get_dbl; 28 | old *= 2.0; 29 | send_dbl(old); 30 | } 31 | my $result = unpack('d', $C::Blocks::_msg); 32 | is($result, $double, 'C defines from previously compiled scope work'); 33 | 34 | BEGIN { 35 | pass('cblock following lexical block compiles without trouble'); 36 | } 37 | 38 | done_testing; 39 | -------------------------------------------------------------------------------- /bench/xs-tcc-naive-bench.pl: -------------------------------------------------------------------------------- 1 | # This benchmark is taken from XS::TCC's author tools example script. 2 | # It does not compare C::Blocks to XS::TCC, however. 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use C::Blocks; 8 | use C::Blocks::Types qw(Int double); 9 | use Benchmark qw(timethese :hireswallclock); 10 | 11 | # Generate some data 12 | my Int $N; 13 | for my $log_n (1, 1.5, 2, 2.5, 3) { 14 | $N = int(10**$log_n); 15 | print "--- For N = $N ---\n"; 16 | 17 | timethese(1000, { 18 | perl_math => \&perl_math, 19 | CBlocks_math => \&c_blocks_math, 20 | }); 21 | print "Perl version returned ", perl_math(), " and C::Blocks version returned ", 22 | c_blocks_math(), "\n"; 23 | } 24 | 25 | sub perl_math { 26 | my $n = $N; 27 | --$n; 28 | my $res = 0; 29 | for my $i (0..$n) { 30 | $res += $i / ($_ == 0 ? 1 : $_) for 0..$n; 31 | } 32 | return $res; 33 | } 34 | 35 | sub c_blocks_math { 36 | my double $to_return = 0; 37 | cblock { 38 | for (int i = 0; i < $N; i++) { 39 | for (int j = 0; j < $N; j++) { 40 | $to_return += i / (double)(j == 0 ? 1 : j); 41 | } 42 | } 43 | } 44 | return $to_return; 45 | } 46 | -------------------------------------------------------------------------------- /t/35-API-Memory.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks; 5 | 6 | # Try allocating a double array and filling it with numbers. 7 | my $c_array_ptr; 8 | 9 | clex { 10 | #define N 10 11 | } 12 | 13 | cblock { 14 | double * c_array; 15 | int i; 16 | Newx(c_array, N, double); 17 | 18 | for (i = 0; i < N; i++) { 19 | c_array[i] = i; 20 | } 21 | 22 | sv_setiv($c_array_ptr, PTR2IV(c_array)); 23 | } 24 | BEGIN { pass 'Use of Newx, sv_setiv, and PTR2IV compiles without issue' } 25 | 26 | my $sum; 27 | cblock { 28 | /* sum the array */ 29 | int i; 30 | double sum = 0; 31 | double * data = INT2PTR(double*, SvIV($c_array_ptr)); 32 | for (i = 0; i < N; i++) { 33 | sum += data[i]; 34 | } 35 | sv_setnv($sum, sum); 36 | } 37 | 38 | is($sum, 45, 'Sum of data is correct; probably correctly stored'); 39 | 40 | cblock { 41 | double * data = INT2PTR(double*, SvIV($c_array_ptr)); 42 | Safefree(data); 43 | } 44 | BEGIN { pass 'Use of Safefree compiles without issue' } 45 | pass 'Freeing data does not segfault'; 46 | 47 | done_testing; 48 | 49 | BEGIN { pass 'Remainder of test script compiled without issue' } 50 | -------------------------------------------------------------------------------- /bench/set-av.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use C::Blocks; 5 | use C::Blocks::PerlAPI; 6 | use Benchmark qw(timethese :hireswallclock); 7 | 8 | # Generate some data 9 | my $N; 10 | for my $log_n (1, 2, 3, 4, 5, 6) { 11 | $N = 10**$log_n; 12 | print "--- For N = $N ---\n"; 13 | 14 | timethese(1000, { 15 | perl_allocate => \&perl_alloc, 16 | perl_push => \&perl_push, 17 | perl_map => \&perl_map, 18 | CBlocks_allocate => \&c_blocks_alloc, 19 | # CBlocks_push => \&c_blocks_push, 20 | }); 21 | } 22 | 23 | # Push N zeros onto an array 24 | sub perl_push { 25 | my @array; 26 | push (@array, 0) for 1 .. $N; 27 | } 28 | 29 | sub perl_map { 30 | my @array = map { 0 } (1 .. $N); 31 | } 32 | 33 | sub perl_alloc { 34 | my @array; 35 | $#array = $N - 1; 36 | $array[$_] = 0 foreach (0 .. $N - 1); 37 | } 38 | 39 | sub c_blocks_alloc { 40 | my @array; 41 | cblock { 42 | int i; 43 | int N = SvIV($N); 44 | 45 | /* Dereference to get the original array */ 46 | av_extend(@array, N); 47 | 48 | for (i = 0; i < N; i++) { 49 | sv_setiv(*(av_fetch(@array, i, 1)), 0); 50 | } 51 | } 52 | } 53 | 54 | #sub c_blocks_push { 55 | #} 56 | -------------------------------------------------------------------------------- /examples/magic-objects/sos-01-create-destroy.pl: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | sos-01-create-destroy.pl - exercise SOS01 creation and destruction 4 | 5 | =head1 QUESTION 6 | 7 | See L for the major question and detailed discussion of 8 | implementation tradeoffs. The question of this script is much simpler: 9 | does the creation and destruction code work? 10 | 11 | =cut 12 | 13 | use strict; 14 | use warnings; 15 | use SOS01; 16 | 17 | print "=== create thing ===\n"; 18 | my $thing = SOS01->new; 19 | print "=== destroy thing ===\n"; 20 | undef $thing; 21 | print "=== create another thing ===\n"; 22 | $thing = SOS01->new; 23 | print "=== copy another thing ===\n"; 24 | my $thing2 = $thing; 25 | #use Devel::Peek; 26 | #Dump($thing2); 27 | print "=== destroy first copy of another thing ===\n"; 28 | undef $thing; 29 | print "=== implicitly destroy another thing at end of script ===\n"; 30 | 31 | =head1 RESULTS 32 | 33 | The code works as expected. Everything runs in the expected order and 34 | with minimal call stack depth. The demise of the variables coincides 35 | with the exact time that their reference counts should have dropped to 36 | zero. All seems well for the moment. 37 | -------------------------------------------------------------------------------- /bench/mandelbrot/mandelbrot.pdl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use PDL; 4 | 5 | my $w = my $h = shift || 200; 6 | my $limit = 4; 7 | 8 | # Allocate working memory. Real and imaginary values for the locations: 9 | my $Cr = sequence($w) * 2 / $w - 1.5; 10 | my $Ci = sequence($h)->transpose * 2 / $h - 1; 11 | # Complex numbers to which the sequence converges: 12 | my $Zr = zeros($w, $h); 13 | my $Zi = $Zr->copy; 14 | # Temporary complex numbers used in the calculation: 15 | my $Tr = $Zr->copy; 16 | my $Ti = $Zr->copy; 17 | 18 | # Perform 50 iterations 19 | for (1 .. 50) { 20 | $Zi = 2 * $Zr * $Zi + $Ci; 21 | $Zr = $Tr - $Ti + $Cr; 22 | $Tr = $Zr * $Zr; 23 | $Ti = $Zi * $Zi; 24 | } 25 | 26 | # identify the locations that did not converge 27 | my $to_compress = zeros(byte, $w, $h); 28 | $to_compress->where(($Tr + $Ti) <= $limit) .= 1; 29 | 30 | # Collapse the bitmap into one bit per pixel 31 | my $bytes_per_line = $w / 8; 32 | my $to_save = zeros(byte, $bytes_per_line, $h); 33 | for my $bit (0 .. 7) { 34 | $to_save |= $to_compress->slice([$bit, -1, 8], [0,-1]) << 7 - $bit; 35 | } 36 | 37 | # Save the result 38 | print "P4\n$w $h\n"; # PBM image header 39 | print ${$to_save->get_dataref}; 40 | 41 | -------------------------------------------------------------------------------- /t/82b-IsaStruct.t: -------------------------------------------------------------------------------- 1 | # The first test for C::Blocks::Types::IsaStruct. This is essentially a 2 | # test version of the synopsis. 3 | use strict; 4 | use warnings; 5 | 6 | ############ 7 | # package with struct 8 | ############ 9 | package My::Point; 10 | # testing hack: make it possible to "use" this package 11 | BEGIN { $INC{'My/Point.pm'} = __FILE__ } 12 | use C::Blocks; 13 | use C::Blocks::Types::IsaStruct; 14 | cshare { 15 | typedef struct My::Point_t { 16 | int x; 17 | int y; 18 | } My::Point; 19 | } 20 | 21 | ############ 22 | # back to the testing... 23 | ############ 24 | package main; 25 | use Test::More; 26 | use C::Blocks; 27 | use My::Point; 28 | 29 | my Point $thing = pack('ii', 3, 4); 30 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 31 | cblock { 32 | if ($thing.x == 3) { 33 | c_blocks_send_msg("worked"); 34 | } 35 | else { 36 | c_blocks_send_msg(""); 37 | } 38 | $thing.y = 5; //== syntax hiliting... grumble grumble 39 | } 40 | 41 | ok $C::Blocks::_msg, "thing's x-value was properly set by pack and reachable via struct member"; 42 | my (undef, $y) = unpack('ii', $thing); 43 | is $y, 5 => "Able to set thing's y-value via struct member assignment"; 44 | 45 | done_testing; 46 | -------------------------------------------------------------------------------- /examples/libprima.pm: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | examples::libprima - providing the C interface to the Prima GUI toolkit 4 | 5 | =head1 TO USE 6 | 7 | I have not put too much effort into making this run from anywhere, so 8 | you will have to be a bit careful in how you use this example module. 9 | The script F is an example that uses this 10 | module. To run that script, or any script that uses this, you will have 11 | to invoke the script from the root directory of this distribution. 12 | 13 | =cut 14 | 15 | package examples::libprima; 16 | use strict; 17 | use warnings; 18 | use Prima::Config; 19 | use ExtUtils::Embed; 20 | 21 | use C::Blocks; 22 | 23 | # Link to the Prima library: 24 | BEGIN { 25 | # Utilize ExtUtils::Embed to get some build info 26 | $C::Blocks::compiler_options = join(' ', $Prima::Config::Config{inc}, ccopts); 27 | 28 | # tcc doesn't know how to use quotes in -I paths; remove them if found. 29 | $C::Blocks::compiler_options =~ s/-I"([^"]*)"/-I$1/g if $^O =~ /MSWin/; 30 | 31 | # Set the Prima library 32 | @C::Blocks::libraries_to_link = ($Prima::Config::Config{dlname}); 33 | } 34 | cshare { 35 | #include 36 | #include 37 | } 38 | 39 | 1; 40 | -------------------------------------------------------------------------------- /bench/matrix-mult/mult.cbl2: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | use C::Blocks::PerlAPI; 5 | 6 | sub load_data { 7 | my ($filename, $data_ref) = @_; 8 | open my $in_fh, '<', $filename or die "Unable to open $filename\n"; 9 | local $/; 10 | $$data_ref = <$in_fh>; 11 | } 12 | 13 | # Load A and B 14 | my ($A, $B); 15 | load_data('A.bin', \$A); 16 | load_data('B.bin', \$B); 17 | 18 | # Check dimensions 19 | length($A) == length($B) or die "Sizes for A and B differ\n"; 20 | my $dim_size = sqrt(length($A) / 8); 21 | $dim_size = int($dim_size) or die "A is not a square matrix\n"; 22 | 23 | # Allocate room for the result 24 | vec (my $C, length($B) - 1, 8) = 0; 25 | 26 | # Load blas 27 | BEGIN { 28 | @C::Blocks::libraries_to_link = ('libatlas.so.3', 'libblas.so'); 29 | # $C::Blocks::compiler_options = '-Wall -static -latlas'; 30 | } 31 | clex { 32 | #include 33 | } 34 | 35 | # Use a very simple implementation 36 | cisa C::Blocks::Type::int $dim_size; 37 | 38 | cblock { 39 | int d = $dim_size; 40 | double * A = (double*)SvPVbyte_nolen($A); 41 | double * B = (double*)SvPVbyte_nolen($B); 42 | double * C = (double*)SvPVbyte_nolen($C); 43 | cblas_dgemm(CblasRowMajor, CblasNoTrans, CblasNoTrans, d, d, d, 1.0, 44 | A, d, B, d, 0.0, C, d); 45 | } 46 | print $C; 47 | -------------------------------------------------------------------------------- /bench/matrix-mult/mult.cbl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | use C::Blocks::PerlAPI; 5 | 6 | sub load_data { 7 | my ($filename, $data_ref) = @_; 8 | open my $in_fh, '<', $filename or die "Unable to open $filename\n"; 9 | local $/; 10 | $$data_ref = <$in_fh>; 11 | } 12 | 13 | # Load A and B 14 | my ($A, $B); 15 | load_data('A.bin', \$A); 16 | load_data('B.bin', \$B); 17 | 18 | # Check dimensions 19 | length($A) == length($B) or die "Sizes for A and B differ\n"; 20 | my $dim_size = sqrt(length($A) / 8); 21 | $dim_size = int($dim_size) or die "A is not a square matrix\n"; 22 | 23 | # Allocate room for the result 24 | vec (my $C, length($B) - 1, 8) = 0; 25 | 26 | # Use a very simple implementation 27 | cisa C::Blocks::Type::int $m; 28 | cisa C::Blocks::Type::Buffer::double $A, $B, $C; 29 | 30 | cblock { 31 | double * A = (double*)SvPVbyte_nolen($A); 32 | double * B = (double*)SvPVbyte_nolen($B); 33 | double * C = (double*)SvPVbyte_nolen($C); 34 | double * curr; 35 | int i, j, k; 36 | for (i = 0; i < $dim_size; i++) { 37 | for (j = 0; j < $dim_size; j++) { 38 | curr = C + i + j * $dim_size; 39 | *curr = 0; 40 | for (k = 0; k < $dim_size; k++) { 41 | *curr += A[k + j * $dim_size] * B[i + k * $dim_size]; 42 | } 43 | } 44 | } 45 | } 46 | print $C; 47 | -------------------------------------------------------------------------------- /t/08-lexical-compiler-warnings.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use Test::More; 3 | use Test::Warn; 4 | use C::Blocks -noPerlAPI; 5 | 6 | 7 | 8 | # no "use warnings", no warning 9 | $C::Blocks::_add_msg_functions = 1; 10 | $C::Blocks::_msg = ''; 11 | warning_is {eval q{ 12 | cblock { 13 | int *a; 14 | double b; 15 | a = &b; 16 | c_blocks_send_msg("1"); 17 | } 18 | }} undef, 'Nothing reported if no "use warnings"'; 19 | is ($C::Blocks::_msg, 1, "unreported compiler warnings still allow execution"); 20 | 21 | 22 | use warnings; 23 | $C::Blocks::_add_msg_functions = 1; 24 | # redefinition warning 25 | warning_like {eval q{ 26 | cblock { 27 | int *a; 28 | double b; 29 | a = &b; 30 | c_blocks_send_msg("hello"); 31 | } 32 | }} qr/incompatible pointer type/, '"use warnings" turns on compiler warnings'; 33 | is ($C::Blocks::_msg, "hello", "reported compiler warnings still allow execution"); 34 | 35 | # silenced redefinition warning 36 | warning_is {eval q{ 37 | no warnings 'C::Blocks::compiler'; 38 | cblock { 39 | int *a; 40 | double b; 41 | a = &b; 42 | c_blocks_send_msg("-0.5"); 43 | } 44 | }} undef, 'Explicitly turning off C::Blocks::compiler avoids warning'; 45 | is ($C::Blocks::_msg, "-0.5", "specifically ignored compiler warnings still allow execution"); 46 | 47 | done_testing; 48 | -------------------------------------------------------------------------------- /examples/magic-objects/sos-05-SOS.pl: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | sos-05-SOS.pl - trying out the real module 4 | 5 | =head1 QUESTION 6 | 7 | L creates a simple class that implements a two-dimensional point. 8 | This script exercises it. Can we create the point? Can we call methods 9 | on it? 10 | 11 | =cut 12 | 13 | use strict; 14 | use warnings; 15 | use SOS05; 16 | use C::Blocks; 17 | use C::Blocks::Filter::BlockArrowMethods; 18 | 19 | print "=== create thing ===\n"; 20 | my SOS05 $thing = SOS05->new; 21 | print "=== destroy thing ===\n"; 22 | undef $thing; 23 | print "=== create another thing and set x and y ===\n"; 24 | $thing = SOS05->new; 25 | $thing->set_x(4); 26 | $thing->set_y(3); 27 | print "=== get the magnitude and direction ===\n"; 28 | print "thing's magnitude is ", $thing->magnitude, "\n"; 29 | cblock { 30 | printf("from C, thing's magnitude is %f\n", $thing=>magnitude()); 31 | } 32 | 33 | print "thing's direction (in radians) is ", $thing->direction, "\n"; 34 | cblock { 35 | printf("from C, thing's direction is %f\n", $thing=>direction()); 36 | } 37 | 38 | =head1 RESULTS 39 | 40 | This works as expected. Allocation and deallocation do not cause any 41 | trouble. It is possible to create two new attributes and then work with 42 | them using either the C interface or Perl interface. 43 | -------------------------------------------------------------------------------- /t/03-line-counting.t: -------------------------------------------------------------------------------- 1 | use Test::More; 2 | use C::Blocks; 3 | 4 | #line 1 "test.pl" 5 | cblock {} 6 | is(__LINE__, 2, "Completely empty block reports correct lines"); 7 | 8 | #line 1 "test.pl" 9 | cblock { 10 | } 11 | is(__LINE__, 3, "Empty with one newline reports correct lines"); 12 | 13 | #line 1 "test.pl" 14 | cblock { 15 | 16 | } 17 | is(__LINE__, 4, "Empty with two newlines reports correct lines"); 18 | 19 | #line 1 "test.pl" 20 | cblock { 21 | 22 | 23 | } 24 | is(__LINE__, 5, "Empty with three newlines reports correct lines"); 25 | 26 | #line 1 "test.pl" 27 | cblock { ${ '' } } 28 | is(__LINE__, 2, "Empty block with empty interpolation block reports correct lines"); 29 | 30 | #line 1 "test.pl" 31 | cblock { ${ '' } 32 | } 33 | is(__LINE__, 3, "Empty block with empty interpolation block followed by single newline reports correct lines"); 34 | 35 | #line 1 "test.pl" 36 | cblock { 37 | ${ '' } } 38 | is(__LINE__, 3, "Empty block with single newline followed by empty interpolation block reports correct lines"); 39 | 40 | #line 1 "test.pl" 41 | cblock { 42 | ${ '' } 43 | } 44 | is(__LINE__, 4, "Empty block with empty interpolation block surrouned by newlines reports correct lines"); 45 | 46 | $C::Blocks::cq_line_directives = 1; 47 | my $line = __LINE__; my $code = cq {}; 48 | like($code, qr/#line $line/, "generated cq has correct line number"); 49 | 50 | done_testing; 51 | -------------------------------------------------------------------------------- /t/03-error-reporting.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | ################# 6 | # Single cblock # 7 | ################# 8 | 9 | # In order to delay the compilation until run (i.e. test) time, we have 10 | # to wrap these in string evals. 11 | eval q{ 12 | #line 9 "t/03-error-reporting.t" 13 | # Should croak with the appropriate line 14 | use C::Blocks -noPerlAPI; 15 | cblock { 16 | int i 5 17 | } 18 | }; 19 | like($@, qr/error/, 'Compilation fails with informative message'); 20 | 21 | my $file = __FILE__; 22 | $file =~ tr/\\/\//; # windows backslash fix 23 | $file = quotemeta($file); 24 | like($@, qr/$file/, 'Error is reported in this file'); 25 | 26 | unlike($@, qr//, 'Error does not report from ""'); 27 | 28 | like($@, qr/:12:/, 'Error is reported from the correct line'); 29 | 30 | 31 | #################### 32 | # Multiple cblocks # 33 | #################### 34 | 35 | eval q{ 36 | #line 9 "t/03-error-reporting.t" 37 | # Should croak with the appropriate line 38 | use C::Blocks -noPerlAPI; 39 | cblock { 40 | int i = 5; 41 | } 42 | 43 | cblock {} 44 | 45 | cblock { 46 | int i 5 47 | } 48 | }; 49 | like($@, qr/error/, 'Compilation fails with informative message'); 50 | like($@, qr/$file/, 'Error is reported in this file'); 51 | unlike($@, qr//, 'Error does not report from ""'); 52 | like($@, qr/:18:/, 'Error is reported from the correct line'); 53 | 54 | done_testing; 55 | -------------------------------------------------------------------------------- /bench/mandelbrot/mandelbrot5.pdl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use PDL; 4 | use Inline 'Pdlpp'; 5 | 6 | my $w = my $h = shift || 200; 7 | my $limit = 4; 8 | 9 | my $byte_width = $w % 8 == 0 ? $w / 8 : int($w / 8) + 1; 10 | 11 | my $data = zeros(byte, $byte_width, $h)->mandelbrot; 12 | print "P4\n$w $h\n"; # PBM image header 13 | print ${$data->get_dataref}; 14 | 15 | __END__ 16 | 17 | __Pdlpp__ 18 | 19 | pp_def('mandelbrot', 20 | Pars => 'input(b, h); [o]output(b, h)', 21 | Code => q{ 22 | int i, x; 23 | int height = $SIZE(h); 24 | int iter = 50; 25 | int byte_acc = 0; 26 | int bit_num = 0; 27 | double limit = 2.0; 28 | double Zr, Zi, Tr, Ti, Cr, Ci; 29 | loop (h) %{ 30 | for(x=0; x < height; ++x) { 31 | Zr = Zi = Tr = Ti = 0.0; 32 | Cr = (2.0 * x / height - 1.5); 33 | Ci = (2.0 * h / height - 1.0); 34 | 35 | for (i = 0; i < iter && (Tr+Ti <= limit*limit); ++i) { 36 | Zi = 2.0 * Zr * Zi + Ci; 37 | Zr = Tr - Ti + Cr; 38 | Tr = Zr * Zr; 39 | Ti = Zi * Zi; 40 | } 41 | 42 | byte_acc <<= 1; 43 | if (Tr+Ti <= limit*limit) byte_acc |= 0x01; 44 | 45 | ++bit_num; 46 | 47 | if (bit_num == 8) { 48 | $output(b=>x/8) = byte_acc; 49 | byte_acc = 0; 50 | bit_num = 0; 51 | } 52 | else if (x == height - 1) { 53 | byte_acc <<= (8-height%8); 54 | $output(b=>x/8) = byte_acc; 55 | byte_acc = 0; 56 | bit_num = 0; 57 | } 58 | } 59 | %} 60 | }, 61 | ); 62 | 63 | -------------------------------------------------------------------------------- /MANIFEST: -------------------------------------------------------------------------------- 1 | bench/avg.pl 2 | bench/c-blocks-vs-inline.pl 3 | bench/euclidean-distance.pl 4 | bench/prime-numbers.pl 5 | bench/set-av.pl 6 | bench/xs-tcc-naive-bench.pl 7 | Build.PL 8 | examples/csub.pl 9 | examples/libobjmg.pl 10 | examples/libprima.pm 11 | examples/pdl-periodogram.pl 12 | examples/point-example.pl 13 | examples/prima-ellipse.pl 14 | examples/prima-lib-ellipse.pl 15 | examples/primatest.pl 16 | lib/C/Blocks.pm 17 | lib/C/Blocks.xs 18 | lib/C/Blocks/PerlAPI.pm 19 | lib/C/Blocks/PerlAPI.xs.PL 20 | lib/C/Blocks/StretchyBuffer.pm 21 | lib/C/Blocks/Types.pm 22 | lib/C/Blocks/Types/Pointers.pm 23 | lib/C/Blocks/Filter.pm 24 | lib/C/Blocks/Filter/BlockArrowMethods.pm 25 | #lib/C/Blocks/Object/Magic.pm 26 | MANIFEST This list of files 27 | ppport.h 28 | README.pod 29 | t/01-basics.t 30 | t/02-use-and-no.t 31 | t/03-error-reporting.t 32 | t/04-PerlAPI.t 33 | t/05-brace-counting.t 34 | t/06-double-colon.t 35 | t/06-interpolation.t 36 | t/07-compiler-setup.t 37 | t/08-lexical-compiler-warnings.t 38 | t/10-clex.t 39 | t/11-clex-series.t 40 | t/12-clex-struct.t 41 | t/13-clex-struct.t 42 | t/15-clex-with-define.t 43 | t/16-clex-scoping.t 44 | t/17-clex-define-undefine-series.t 45 | t/18-clex-global-vars.t 46 | t/20-cshare.t 47 | t/21-cshare-warnings.t 48 | t/30-API-SV.t 49 | t/35-API-Memory.t 50 | t/36-API-Creation.t 51 | t/40-csub.t 52 | t/50-sigiled-vars.t 53 | t/55-types.t 54 | t/60-filters.t 55 | t/80-StretchyBuffer.t 56 | #t/81-Object-Magic.t 57 | t/99-stdio-fails.t 58 | META.yml 59 | META.json 60 | Changes 61 | -------------------------------------------------------------------------------- /examples/point-example.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | use C::Blocks::PerlAPI; 5 | use C::Blocks::Types qw(double); 6 | 7 | clex { 8 | typedef struct _point_t { 9 | double x; 10 | double y; 11 | } point; 12 | 13 | double point_distance_from_origin (point * loc) { 14 | printf("x is %f, y is %f\n", loc->x, loc->y); 15 | return sqrt(loc->x * loc->x + loc->y * loc->y); 16 | } 17 | 18 | /* Assume they have an SV packed with a point struct */ 19 | point * _point_from_SV(pTHX_ SV * point_SV) { 20 | return (point*)SvPV_nolen(point_SV); 21 | } 22 | #define point_from_SV(point_sv) _point_from_SV(aTHX_ point_sv) 23 | } 24 | 25 | # Generate some synthetic data; 26 | my @pairs = map { rand() } 1 .. 10; 27 | print "Pairs are @pairs\n"; 28 | 29 | # Assume pairs is ($x1, $y1, $x2, $y2, $x3, $y3, ...) 30 | # Create a C array of doubles, which is equivalent to an 31 | # array of points with half as many array elements 32 | my $points = pack 'd*', @pairs; 33 | 34 | # Calculate the average distance to the origin: 35 | my double $avg_distance = 0; 36 | cblock { 37 | point * points = point_from_SV($points); 38 | int N_points = av_len(@pairs) / 2 + 0.5; 39 | int i; 40 | for (i = 0; i < N_points; i++) { 41 | $avg_distance += point_distance_from_origin(points + i); 42 | } 43 | $avg_distance /= N_points; 44 | } 45 | 46 | print "Average distance to origin is $avg_distance\n"; 47 | -------------------------------------------------------------------------------- /src/cb_custom_op.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | XOP tcc_xop; 4 | 5 | typedef void (*my_void_func)(pTHX); 6 | 7 | PP(tcc_pp) { 8 | dSP; 9 | void *ptr = INT2PTR(my_void_func, (UV)PL_op->op_targ); 10 | my_void_func p_to_call = ptr; 11 | p_to_call(aTHX); 12 | RETURN; 13 | } 14 | 15 | 16 | Perl_ophook_t original_opfreehook; 17 | 18 | static void 19 | op_free_hook(pTHX_ OP *o) { 20 | if (original_opfreehook != NULL) 21 | original_opfreehook(aTHX_ o); 22 | 23 | if (o->op_ppaddr == Perl_tcc_pp) { 24 | o->op_targ = 0; /* important or Perl will use it to access the pad */ 25 | } 26 | } 27 | 28 | OP * cb_build_op(pTHX_ void *sym_pointer) { 29 | /* create new OP that gets the sym_pointer from its op_targ slot 30 | * and invokes it */ 31 | OP * o; 32 | NewOp(1101, o, 1, OP); 33 | 34 | o->op_type = (OPCODE)OP_CUSTOM; 35 | o->op_next = (OP*)o; 36 | o->op_private = 0; 37 | o->op_flags = 0; 38 | o->op_targ = (PADOFFSET)PTR2UV(sym_pointer); 39 | o->op_ppaddr = Perl_tcc_pp; 40 | 41 | return o; 42 | } 43 | 44 | 45 | 46 | 47 | void cb_init_custom_op(pTHX) { 48 | /* Setup our callback for cleaning up OPs during global cleanup */ 49 | original_opfreehook = PL_opfreehook; 50 | PL_opfreehook = op_free_hook; 51 | 52 | /* Set up the custom op */ 53 | XopENTRY_set(&tcc_xop, xop_name, "tccop"); 54 | XopENTRY_set(&tcc_xop, xop_desc, "Op to run jit-compiled C code"); 55 | XopENTRY_set(&tcc_xop, xop_class, OA_BASEOP); 56 | 57 | Perl_custom_op_register(aTHX_ Perl_tcc_pp, &tcc_xop); 58 | } 59 | 60 | -------------------------------------------------------------------------------- /bench/mandelbrot/mandelbrot2.pdl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use PDL; 4 | 5 | my $w = my $h = shift || 200; 6 | my $limit = 4; 7 | 8 | # Allocate working memory: 9 | my $Cr = (zeros($w, $h)->xvals * 2 / $w - 1.5)->flat; 10 | my $Ci = (zeros($w, $h)->yvals * 2 / $h - 1)->flat; 11 | # Complex numbers to which the sequence converges: 12 | my $Zr = zeros($w * $h); 13 | my $Zi = $Zr->copy; 14 | # Temporary complex numbers used in the calculation: 15 | my $Tr = zeros($w, $h); 16 | my $Ti = $Tr->copy; 17 | # bitmap of the locations where we are still working: 18 | my $not_converged = ones($w, $h); 19 | 20 | # Perform 50 iterations 21 | for (1 .. 50) { 22 | $Zi .= 2 * $Zr * $Zi + $Ci; 23 | $Zr .= $Tr->where($not_converged) - $Ti->where($not_converged) + $Cr; 24 | $Tr->where($not_converged) .= $Zr * $Zr; 25 | $Ti->where($not_converged) .= $Zi * $Zi; 26 | 27 | my $still_not_converged = (($Tr->where($not_converged) + $Ti->where($not_converged)) <= $limit); 28 | $not_converged->where($not_converged) .= $still_not_converged; 29 | $Zi = $Zi->where($still_not_converged)->sever; 30 | $Zr = $Zr->where($still_not_converged)->sever; 31 | $Ci = $Ci->where($still_not_converged)->sever; 32 | $Cr = $Cr->where($still_not_converged)->sever; 33 | } 34 | 35 | # Collapse the bitmap into one bit per pixel 36 | my $bytes_per_line = $w / 8; 37 | my $to_save = zeros(byte, $bytes_per_line, $h); 38 | for my $bit (0 .. 7) { 39 | $to_save |= $not_converged->slice([$bit, -1, 8], [0,-1]) << 7 - $bit; 40 | } 41 | 42 | print "P4\n$w $h\n"; # PBM image header 43 | print ${$to_save->get_dataref}; 44 | 45 | -------------------------------------------------------------------------------- /t/80-StretchyBuffer.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks; 5 | 6 | use C::Blocks::StretchyBuffer; 7 | BEGIN { pass 'StretchyBuffer imports without trouble' } 8 | 9 | my ($sb_pointer, $info_to_test); 10 | 11 | cblock { 12 | double * data = NULL; 13 | sbadd(data, 20); 14 | for (int i = 0; i < sbcount(data); data[i] = i++); 15 | sv_setiv($sb_pointer, PTR2IV(data)); 16 | } 17 | BEGIN { pass 'Use of StretchyBuffer compiles without issue' } 18 | 19 | cblock { 20 | /* Get the first element */ 21 | double * data = INT2PTR(double*, SvIV($sb_pointer)); 22 | sv_setiv($info_to_test, data[0]); 23 | } 24 | 25 | is($info_to_test, 0, 'First element is zero'); 26 | 27 | cblock { 28 | /* Get the length */ 29 | double * data = INT2PTR(double*, SvIV($sb_pointer)); 30 | sv_setiv($info_to_test, sbcount(data)); 31 | } 32 | 33 | is($info_to_test, 20, 'Size is correctly stored and accessible'); 34 | 35 | cblock { 36 | /* Pop the last element off */ 37 | double * data = INT2PTR(double*, SvIV($sb_pointer)); 38 | sv_setiv($info_to_test, sbpop(data)); 39 | } 40 | is($info_to_test, 19, 'Popping off the last item of a 20-item'); 41 | 42 | cblock { 43 | double * data = INT2PTR(double*, SvIV($sb_pointer)); 44 | sv_setiv($info_to_test, sbcount(data)); 45 | } 46 | is($info_to_test, 19, 'After popping, buffer reports only 19 elements'); 47 | 48 | cblock { 49 | double * data = INT2PTR(double*, SvIV($sb_pointer)); 50 | sbfree(data); 51 | } 52 | pass 'Freeing data does not segfault'; 53 | 54 | done_testing; 55 | 56 | BEGIN { pass 'Remainder of test script compiled without issue' } 57 | -------------------------------------------------------------------------------- /lib/C/Blocks/Filter/BlockArrowMethods.pm: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | package C::Blocks::Filter::BlockArrowMethods; 3 | ######################################################################## 4 | 5 | use strict; 6 | use warnings; 7 | our $VERSION = '0.42'; 8 | $VERSION = eval $VERSION; 9 | use C::Blocks::Filter (); 10 | our @ISA = qw(C::Blocks::Filter); 11 | 12 | sub c_blocks_filter { 13 | s/(\w+)=>(\w+)\(\)/$1->methods->$2($1)/g; 14 | s/(\w+)=>(\w+)\(/$1->methods->$2($1, /g; 15 | } 16 | 17 | 1; 18 | 19 | __END__ 20 | 21 | =head1 NAME 22 | 23 | C::Blocks::Filter::BlockArrowMethods - invoke methods succinctly 24 | 25 | =head1 SYNOPSIS 26 | 27 | use strict; 28 | use warnings; 29 | use C::Blocks; 30 | use C::Blocks::Filter::BlockArrowMethods; 31 | 32 | cblock { 33 | /* These are equivalent */ 34 | a=>some_thing(arg1, arg2); 35 | a->methods->some_thing(a, arg1, arg2); 36 | } 37 | 38 | =head1 DESCRIPTION 39 | 40 | When invoking methods on vtable-based classes, you need to extract the 41 | method by dereferencing the vtable, and then you have to pass the 42 | object as the first argument of the method. If the vtable pointer is 43 | registered under the name C, you might invoke the method 44 | C as 45 | 46 | obj->methods->some_action(obj, other, args); 47 | 48 | The C filter would let you use the 49 | following more succinct statement: 50 | 51 | obj=>some_action(other, args); 52 | 53 | This would be converted to the previous more verbose example. 54 | 55 | -------------------------------------------------------------------------------- /src/cb_code_parser_extractor.h: -------------------------------------------------------------------------------- 1 | #ifndef CB_CODE_PARSER_EXTRACTOR_H_ 2 | #define CB_CODE_PARSER_EXTRACTOR_H_ 3 | 4 | /* Logic related to scanning, parsing, and extracting the C code in 5 | * clex/cblock/csub/.... In future will likely include the C function 6 | * signature parsing logic. */ 7 | 8 | #include 9 | #include 10 | 11 | #include 12 | 13 | /* ---- Zephram's book of preprocessor hacks ---- */ 14 | #define PERL_VERSION_DECIMAL(r,v,s) (r*1000000 + v*1000 + s) 15 | #define PERL_DECIMAL_VERSION \ 16 | PERL_VERSION_DECIMAL(PERL_REVISION,PERL_VERSION,PERL_SUBVERSION) 17 | #define PERL_VERSION_GE(r,v,s) \ 18 | (PERL_DECIMAL_VERSION >= PERL_VERSION_DECIMAL(r,v,s)) 19 | 20 | /* ---- pad_findmy_pv ---- */ 21 | #ifndef pad_findmy_pv 22 | # if PERL_VERSION_GE(5,11,2) 23 | # define pad_findmy_pv(name, flags) pad_findmy(name, strlen(name), flags) 24 | # else /* <5.11.2 */ 25 | # define pad_findmy_pv(name, flags) pad_findmy(name) 26 | # endif /* <5.11.2 */ 27 | #endif /* !pad_findmy_pv */ 28 | 29 | #ifndef pad_compname_type 30 | #define pad_compname_type(a) Perl_pad_compname_type(aTHX_ a) 31 | #endif 32 | 33 | enum { IS_CBLOCK = 1, IS_CSHARE, IS_CLEX, IS_CSUB, IS_CQ } keyword_type_list; 34 | 35 | int cb_identify_keyword (char * keyword_ptr, STRLEN keyword_len); 36 | 37 | void cb_extract_c_code(pTHX_ c_blocks_data *data, int keyword_type); 38 | 39 | /* TODO: ideally, these wouldn't be public. */ 40 | void cb_fixup_xsub_name(pTHX_ c_blocks_data *data); 41 | char * cb_replace_double_colons_with_double_underscores(pTHX_ SV * to_replace); 42 | 43 | #endif 44 | -------------------------------------------------------------------------------- /bench/mandelbrot/mandelbrot3.pdl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use PDL; 4 | 5 | my $w = my $h = shift || 200; 6 | my $limit = 4; 7 | 8 | # PBM image header 9 | print "P4\n$w $h\n"; 10 | 11 | 12 | # Loop through y, the imaginary component of the constant C 13 | for my $y (0 .. $h - 1) { 14 | 15 | # Allocate working memory: 16 | my $Cr = (sequence($w) * 2 / $w - 1.5)->flat; 17 | my $Ci = 2 * $y / $h - 1; 18 | # Complex numbers to which the sequence converges: 19 | my $Zr = zeros($w); 20 | my $Zi = $Zr->copy; 21 | # Temporary complex numbers used in the calculation: 22 | my $Tr = $Zr->copy; 23 | my $Ti = $Zr->copy; 24 | 25 | # bitmap of the locations where we are still working: 26 | my $not_converged = ones($w); 27 | 28 | # Perform 50 iterations 29 | for (1 .. 50) { 30 | $Zi .= 2 * $Zr * $Zi + $Ci; 31 | $Zr .= $Tr - $Ti + $Cr; 32 | $Tr .= $Zr * $Zr; 33 | $Ti .= $Zi * $Zi; 34 | 35 | my $still_not_converged = (($Tr + $Ti) <= $limit); 36 | $not_converged->where($not_converged) .= $still_not_converged; 37 | last if $still_not_converged->sum == 0; 38 | $Zi = $Zi->where($still_not_converged)->sever; 39 | $Zr = $Zr->where($still_not_converged)->sever; 40 | $Cr = $Cr->where($still_not_converged)->sever; 41 | $Tr = $Tr->where($still_not_converged)->sever; 42 | $Ti = $Ti->where($still_not_converged)->sever; 43 | } 44 | 45 | # Collapse the bitmap into one bit per pixel 46 | my $bytes_per_line = $w / 8; 47 | my $to_save = zeros(byte, $bytes_per_line); 48 | for my $bit (0 .. 7) { 49 | $to_save |= $not_converged->slice([$bit, -1, 8]) << 7 - $bit; 50 | } 51 | 52 | print ${$to_save->get_dataref}; 53 | } 54 | -------------------------------------------------------------------------------- /examples/magic-objects/SOS02.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | =head1 NAME 5 | 6 | SOS02.pm - adding Perl -> C 7 | 8 | =head1 QUESTION 9 | 10 | The functionality and reference counting is present for me to make a 11 | C copy of a SOS01 object, but I can't get the C-representation in a 12 | C to perform that action! I need to add the ability to retrieve 13 | the C pointer given the C. How do I do that? 14 | 15 | My solution is to cobble some pieces from XS::Object::Magic (via 16 | C::Blocks::Object::Magic) to retrieve the data pointer from the 17 | underlying magic hash. 18 | 19 | =cut 20 | 21 | package SOS02; 22 | use C::Blocks; 23 | use SOS01; 24 | use C::Blocks::PerlAPI; 25 | use C::Blocks::Filter::BlockArrowMethods; 26 | 27 | cshare { 28 | void * SOS01::Magic::obj_ptr_from_SV_ref (pTHX_ SV* sv_ref) { 29 | entering; 30 | MAGIC *mg; 31 | if (!SvROK(sv_ref)) 32 | croak("obj_ptr_from_SV called with non-ref scalar"); 33 | SV * sv = SvRV(sv_ref); 34 | 35 | if (SvTYPE(sv) >= SVt_PVMG) { 36 | for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) { 37 | if ((mg->mg_type == PERL_MAGIC_ext) 38 | && (mg->mg_virtual == &SOS01::Magic::Vtable)) 39 | { 40 | _leaving("SOS02::Magic::obj_ptr_from_HV, returning non-null"); 41 | return mg->mg_ptr; 42 | } 43 | } 44 | } 45 | _leaving("SOS02::Magic::obj_ptr_from_HV, returning null"); 46 | return NULL; 47 | } 48 | } 49 | 50 | 1; 51 | 52 | =head1 RESULTS 53 | 54 | After learning about the pitfalls of using static global variables, I 55 | have finally got this thing working. 56 | 57 | See F for specific tests and analysis. 58 | 59 | =cut 60 | -------------------------------------------------------------------------------- /examples/magic-objects/sos-02-refcount-inc.pl: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | sos-02-refcount-inc.pl - make sure SOS01 refcounting works as expected 4 | 5 | =head1 QUESTION 6 | 7 | I wanted to test the reference counting more thoroughly. This required 8 | a new function, discussed and implemented in L. Now we can check 9 | C-side reference counting, too. 10 | 11 | =cut 12 | 13 | use strict; 14 | use warnings; 15 | use C::Blocks; 16 | use SOS01; 17 | use SOS02; 18 | use C::Blocks::Filter::BlockArrowMethods; 19 | 20 | clex { 21 | SOS01 c_self; 22 | } 23 | 24 | # Create a Perl-side copy 25 | print "=== creating object ===\n"; 26 | my $thing = SOS01->new; 27 | 28 | # Create a C-side copy in a global variable 29 | print "=== creating C-side copy ===\n"; 30 | cblock { 31 | c_self = SOS01::Magic::obj_ptr_from_SV_ref(aTHX_ $thing); 32 | c_self=>refcount_inc(); 33 | } 34 | 35 | print "=== getting rid of Perl-side copy ===\n"; 36 | undef $thing; 37 | 38 | print "=== getting rid of C-side copy ===\n"; 39 | cblock { 40 | c_self=>refcount_dec(); 41 | } 42 | 43 | print "All done!\n"; 44 | 45 | =head1 RESULTS 46 | 47 | Whereas F exercises the basic creation and 48 | destruction behavior from Perl code, F 49 | exercises reference counting directly on the C representation. 50 | Achieving that required this module to implement the mapping from SV -> 51 | SOS01 pointer, implemented in L. 52 | 53 | The results are wonderfully satisfying. Undefining the Perl-side 54 | variable does not lead to the destruction of the object so long as the 55 | reference count is held up by the C pointer. This is evidenced by the 56 | lack of anything printed between "getting rid of Perl-side copy" and 57 | "getting rid of C-side copy". 58 | 59 | -------------------------------------------------------------------------------- /bench/mandelbrot/mandelbrot.cpl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use C::Blocks; 5 | use C::Blocks::Types qw(uint char_array); 6 | use C::Blocks::PerlAPI; 7 | 8 | my uint $w = my uint $h = shift || 200; 9 | my $bytes_per_line = $w / 8; 10 | 11 | print "P4\n$w $h\n"; # PBM image header 12 | 13 | # Allocate the line contents so that we have something that we can 14 | # easily manipulate. 15 | my char_array $line_contents; 16 | my $N_bytes = $w % 8 == 0 ? $w / 8 : int($w / 8) + 1; 17 | vec ($line_contents, $N_bytes - 1, 8) = 0; 18 | 19 | for my uint $y ( 0 .. $h-1) { 20 | cblock { 21 | int bit_num = 0; 22 | char byte_acc = 0; 23 | int i, iter = 50; 24 | double x, limit = 2.0; 25 | double Zr, Zi, Cr, Ci, Tr, Ti; 26 | 27 | for(x=0; x < $w; ++x) { 28 | Zr = Zi = Tr = Ti = 0.0; 29 | Cr = (2.0 * x / $w - 1.5); 30 | Ci=(2.0*$y/$h - 1.0); 31 | 32 | for (i=0;ix - data->y; 30 | data->x = diff; 31 | data->y = -1; 32 | 33 | /* Set the new name with a string copy by hand */ 34 | char * new_name = "difference"; 35 | int i; 36 | for (i = 0; new_name[i] != 0; i++) data->name[i] = new_name[i]; 37 | data->name[i] = 0; 38 | 39 | /* Send backk all the bytes (including the null) */ 40 | c_blocks_send_bytes(data, 13); 41 | } 42 | BEGIN { pass 'first cblock after lexical block compiles without trouble' } 43 | pass 'first cblock is called and run without trouble'; 44 | 45 | my ($diff, $filler, $description) = unpack('ccZ*', $C::Blocks::_msg); 46 | is($diff, 5, 'Computes and packs the difference'); 47 | is($filler, -1, 'Stores a filler byte'); 48 | is($description, 'difference', 'packs a description'); 49 | 50 | done_testing; 51 | -------------------------------------------------------------------------------- /t/17-clex-define-undefine-series.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks -noPerlAPI; 5 | 6 | # Tell C::Blocks to add rudimentary communications functions for testing 7 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 8 | 9 | ###### Create a lexically scoped macros similar to those in test 15 ###### 10 | 11 | clex { 12 | #define get_dbl ((double*)c_blocks_get_msg())[0] 13 | #define send_dbl(to_send) c_blocks_send_bytes(&to_send, sizeof(double)) 14 | } 15 | 16 | # Generate a random integer between zero and 20, send it 17 | my $number = rand(20) % 20; 18 | $C::Blocks::_msg = pack('d', $number); 19 | 20 | my $double = $number * 2; 21 | # Double it in C 22 | cblock { 23 | double old = get_dbl; 24 | old *= 2.0; 25 | send_dbl(old); 26 | } 27 | my $result = unpack('d', $C::Blocks::_msg); 28 | is($result, $double, 'C defines from previously compiled scope work (as already tested)'); 29 | 30 | ###### Redefine the preprocessor macro in a lexically scoped way ###### 31 | 32 | { 33 | clex { 34 | #undef get_dbl 35 | #define get_dbl -125 36 | } 37 | # invoke the new definition 38 | cblock { 39 | double new_val = get_dbl; 40 | send_dbl(new_val); 41 | } 42 | my $result = unpack('d', $C::Blocks::_msg); 43 | is($result, -125, 'Lexically scoped redefines work'); 44 | } 45 | 46 | ###### Outside the lexical scope, test for the previous preprocessor macro ###### 47 | 48 | # Generate a random integer between zero and 20, send it 49 | $number = rand(20) % 20; 50 | $C::Blocks::_msg = pack('d', $number); 51 | 52 | $double = $number * 2; 53 | # Double it in C 54 | cblock { 55 | double old = get_dbl; 56 | old *= 2.0; 57 | send_dbl(old); 58 | } 59 | $result = unpack('d', $C::Blocks::_msg); 60 | is($result, $double, 'Lexically scoped redefines do not leak'); 61 | 62 | done_testing; 63 | -------------------------------------------------------------------------------- /t/82a-Struct.t: -------------------------------------------------------------------------------- 1 | # The first test for C::Blocks::Types::Struct. This is essentially a 2 | # test version of the synopsis. 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | use C::Blocks; 7 | 8 | # Set up a basic class that overrides rudimentary functions to log 9 | # what's going on... 10 | 11 | use C::Blocks::Types::Struct 'Point'; 12 | clex { 13 | typedef struct Point_t { 14 | int x; 15 | int y; 16 | } Point; 17 | } 18 | 19 | my Point $thing = pack('ii', 3, 4); 20 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 21 | cblock { 22 | if ($thing.x == 3) { 23 | c_blocks_send_msg("worked"); 24 | } 25 | else { 26 | c_blocks_send_msg(""); 27 | } 28 | $thing.y = 5; //== syntax hiliting... grumble grumble 29 | } 30 | 31 | ok $C::Blocks::_msg, "thing's x-value was properly set by pack and reachable via struct member"; 32 | my (undef, $y) = unpack('ii', $thing); 33 | is $y, 5 => "Able to set thing's y-value via struct member assignment"; 34 | 35 | use C::Blocks::Types::Struct [struct_point => 'struct Point_t']; 36 | my struct_point $thing2; # uninitialized!!! 37 | cblock { 38 | $thing2.x = 5; 39 | $thing2.y = -5; 40 | } 41 | (my $x, $y) = unpack ('ii', $thing2); 42 | ok ($x == 5 && $y == -5, "Automatic data allocation works; two-argument declaration works") 43 | or diag "x is $x and y is $y"; 44 | 45 | # Make sure that I cannot change a Perl scalar that has been marked as 46 | # a struct. 47 | my $modified = eval { $thing = 1 }; 48 | ok (!$modified, "Cannot modify a struct from Perl side"); 49 | like ($@, qr/Modification of a read-only/, 50 | "Perl-side change fails due to read-only setting"); 51 | # make it possible to modify thing again 52 | cblock { 53 | SvREADONLY_off(SV_$thing); 54 | } 55 | $thing = 'foo'; 56 | pass("Can modify thing after turning the SvREADONLY flag off"); 57 | 58 | done_testing; 59 | -------------------------------------------------------------------------------- /t/11-clex-series.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks -noPerlAPI; 5 | 6 | # Tell C::Blocks to add rudimentary communications functions for testing 7 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 8 | 9 | # Start with a known (blank) message 10 | $C::Blocks::_msg = ''; 11 | 12 | # Build a single function that calls the messaging interface 13 | clex { 14 | void snd_msg(char * msg) { 15 | c_blocks_send_msg(msg); 16 | } 17 | } 18 | 19 | BEGIN { pass 'Lexical block compiles without trouble' } 20 | pass('At runtime, lexical block gets skipped without trouble'); 21 | 22 | # Test it 23 | cblock { snd_msg("First!"); } 24 | BEGIN { pass 'cblock after first lexical block compiles without trouble' } 25 | pass 'cblock after first lexical block runs without trouble'; 26 | is($C::Blocks::_msg, 'First!', 'Function call in cblock after first lexical block has desired side-effect'); 27 | 28 | ### Second clex ### 29 | clex { 30 | void send_hello () { 31 | c_blocks_send_msg("Hello!"); 32 | } 33 | } 34 | 35 | # Make sure it compiled ok 36 | BEGIN { pass 'Second lexical block compiles without trouble' } 37 | pass('At runtime, second lexical block gets skipped without trouble'); 38 | 39 | # Make sure it didn't screw up previous stuff 40 | cblock { snd_msg("Second!"); } 41 | BEGIN { pass 'cblock after second lexical block compiles without trouble' } 42 | pass 'cblock after second lexical block runs without trouble'; 43 | is($C::Blocks::_msg, 'Second!', 'Function call in cblock after second lexical block has desired side-effect'); 44 | 45 | # Test new function 46 | cblock { send_hello(); } 47 | BEGIN { pass 'second cblock after second lexical block compiles without trouble' } 48 | pass 'cblock is called and run without trouble'; 49 | is($C::Blocks::_msg, 'Hello!', 'Function call in second cblock after second lexical block has desired side-effect'); 50 | 51 | done_testing; 52 | -------------------------------------------------------------------------------- /bench/mandelbrot/mandelbrot3.cpl: -------------------------------------------------------------------------------- 1 | XXX - fails: this is a re-implementation of the Perl version using 2 | C::Blocks, but it crashes hard at the moment. :-( 3 | # The Computer Language Benchmarks Game 4 | # http://benchmarksgame.alioth.debian.org/ 5 | # 6 | # contributed by Mykola Zubach 7 | 8 | use strict; 9 | use threads; 10 | use threads::shared; 11 | use C::Blocks; 12 | use C::Blocks::PerlAPI; 13 | use C::Blocks::Types qw(Int double); 14 | 15 | use constant YMIN => -1; 16 | use constant WHITE => "\0"; 17 | use constant BLACK => "\001"; 18 | 19 | my ($h, @threads, $invN); 20 | my Int $w; 21 | my @jobs :shared; 22 | my @picture :shared; 23 | $w = $h = shift || 200; 24 | 25 | sub draw_line($) { 26 | my Int $y = shift; 27 | my $line; 28 | my double $Ci = $y * $invN + YMIN; 29 | for my Int $x (0 .. $w - 1) { 30 | my Int $is_white = 0; 31 | 32 | cblock { 33 | double Zr = 0, Zi = 0, Tr = 0, Ti = 0; 34 | double Cr = $x * 2.0 / $w - 1.5; 35 | int i; 36 | for (i = 0; i < 50; i++) { 37 | Zi = Zi * 2 * Zr + $Ci; 38 | Zr = Tr - Ti + Cr; 39 | Ti = Zi * Zi; 40 | Tr = Zr * Zr; 41 | if (Tr + Ti > 4) { 42 | $is_white = 1; 43 | break; 44 | } 45 | } 46 | } 47 | $line .= $is_white ? WHITE : BLACK; 48 | } 49 | $picture[$y] = pack 'B*', $line; 50 | } 51 | 52 | sub process_queue() { 53 | while(defined(my $y = pop @jobs)) { 54 | draw_line($y); 55 | } 56 | } 57 | 58 | sub num_cpus() { 59 | open my $fh, ') { 62 | $cpus ++ if /^processor\s+:/; 63 | } 64 | return $cpus; 65 | } 66 | 67 | ## MAIN() 68 | 69 | $invN = 2 / $w; 70 | @jobs = (0 .. $h - 1); 71 | 72 | for (1 .. num_cpus()) { 73 | push @threads, threads->create(\&process_queue); 74 | } 75 | 76 | for (@threads) { 77 | $_->join; 78 | } 79 | 80 | print "P4\n$w $h\n"; # PBM image header 81 | print @picture; 82 | -------------------------------------------------------------------------------- /bench/mandelbrot/mandelbrot4.pdl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use PDL; 4 | 5 | my $w = my $h = shift || 200; 6 | my $limit = 4; 7 | 8 | # PBM image header 9 | print "P4\n$w $h\n"; 10 | 11 | my $tile = 40; 12 | 13 | # Loop through y, the imaginary component of the constant C 14 | for my $y (0 .. $h/$tile - 1) { 15 | 16 | # Allocate working memory: 17 | my $Cr = (zeros($w, $tile)->xvals * 2 / $w - 1.5)->flat; 18 | my $Ci = ((zeros($w, $tile)->yvals + $tile * $y) * 2 / $h - 1)->flat; 19 | # Complex numbers to which the sequence converges: 20 | my $Zr = zeros($w * $tile); 21 | my $Zi = $Zr->copy; 22 | # Temporary complex numbers used in the calculation: 23 | my $Tr = $Zr->copy; 24 | my $Ti = $Zr->copy; 25 | # bitmap of the locations where we are still working: 26 | my $not_converged = $Zr->ones; 27 | my $still_working = $not_converged; # shallow copy 28 | 29 | 30 | # Perform 50 iterations 31 | for (1 .. 50) { 32 | $Zi .= 2 * $Zr * $Zi + $Ci; 33 | $Zr .= $Tr - $Ti + $Cr; 34 | $Tr .= $Zr * $Zr; 35 | $Ti .= $Zi * $Zi; 36 | 37 | my $still_not_converged = (($Tr + $Ti) <= $limit); 38 | $still_working .= $still_not_converged; 39 | last if $still_not_converged->sum == 0; 40 | $Zi = $Zi->where($still_not_converged)->sever; 41 | $Zr = $Zr->where($still_not_converged)->sever; 42 | $Ci = $Ci->where($still_not_converged)->sever; 43 | $Cr = $Cr->where($still_not_converged)->sever; 44 | $Ti = $Ti->where($still_not_converged)->sever; 45 | $Tr = $Tr->where($still_not_converged)->sever; 46 | # preserve data-flow for still_working! 47 | $still_working = $still_working->where($still_not_converged); 48 | } 49 | 50 | # Collapse the bitmap into one bit per pixel 51 | my $bytes_per_line = $w / 8; 52 | my $to_save = zeros(byte, $bytes_per_line * $tile); 53 | for my $bit (0 .. 7) { 54 | $to_save |= $not_converged->slice([$bit, -1, 8]) << 7 - $bit; 55 | } 56 | 57 | print ${$to_save->get_dataref}; 58 | } 59 | -------------------------------------------------------------------------------- /examples/csub-few-macros.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | use C::Blocks::PerlAPI; 5 | 6 | csub csum { 7 | /* Get the top "mark" offset from the stack of marks. */ 8 | I32 ax = *PL_markstack_ptr--; 9 | /* PL_stack_base is the pointer to the bottom of the 10 | * argument stack. */ 11 | SV **mark = PL_stack_base + ax; 12 | 13 | /* Local copy of the global Perl argument stack pointer. 14 | * This is the top of the stack, not the base! */ 15 | SV **sp = PL_stack_sp; 16 | 17 | /* And finally, the number of parameters for this function. */ 18 | I32 items = (I32)(sp - mark); 19 | 20 | int i; 21 | double sum = 0.; 22 | 23 | /* Move stack pointer back by number of arguments. 24 | * Basically, this means argument access by increasing index 25 | * in "first to last" order instead of access in 26 | * "last to first" order by using negative offsets. */ 27 | sp -= items; 28 | 29 | /* Go through arguments (as SVs) and add their *N*umeric *V*alue to 30 | * the output sum. */ 31 | for (i = 0; i < items; ++i) 32 | sum += SvNV( *(sp + i+1) ); /* sp+i+1 is the i-th arg on the stack */ 33 | 34 | const IV num_return_values = 1; 35 | /* Make sure we have space on the stack (in case the function was 36 | * called without arguments) */ 37 | if (PL_stack_max - sp < (ssize_t)num_return_values) { 38 | /* Oops, not enough space, extend. Needs to reset the 39 | * sp variable since it might have caused a proper realloc. */ 40 | sp = Perl_stack_grow(aTHX_ sp, sp, (ssize_t)num_return_values); 41 | } 42 | 43 | /* Push return value on the Perl stack, convert number to Perl SV. */ 44 | /* Also makes the value mortal, that is avoiding a memory leak. */ 45 | *++sp = sv_2mortal( newSVnv(sum) ); 46 | 47 | /* Commit the changes we've done to the stack by setting the global 48 | * top-of-stack pointer to our modified copy. */ 49 | PL_stack_sp = sp; 50 | 51 | return; 52 | } 53 | 54 | my $return = csum(1 .. 5); 55 | print "sum of 1 to 5 is $return\n"; 56 | -------------------------------------------------------------------------------- /t/04-PerlAPI.t: -------------------------------------------------------------------------------- 1 | # This tests PerlAPI to make sure that we can communicate between 2 | # the perl interpreter and the cblocks. This requires a fairly 3 | # substantial amount of the C::Blocks machinery to be functional, so it 4 | # is perhaps not the best thing to rely on for so much of the testing. 5 | # But then again, if it works we know that quite a bit of C::Blocks 6 | # works, too. 7 | 8 | use strict; 9 | use warnings; 10 | use Test::More; 11 | 12 | # Load cblocks and PerlAPI 13 | use C::Blocks; 14 | 15 | # Work with package globals for now 16 | our $shuttle; 17 | 18 | cblock { 19 | SV * shuttle = Perl_get_sv(aTHX_ "shuttle", 0); 20 | Perl_sv_setiv(aTHX_ shuttle, 5); 21 | } 22 | BEGIN { pass 'cblock using basic Perl functions compiles fine' } 23 | is($shuttle, 5, 'Can set Perl data in a cblock using direct function calls'); 24 | 25 | cblock { 26 | SV * shuttle = get_sv("shuttle", 0); 27 | sv_setiv(shuttle, -5); 28 | } 29 | BEGIN { pass 'cblock using Perl function macros compiles fine' } 30 | is($shuttle, -5, 'Can set Perl data using macros'); 31 | 32 | cblock { 33 | SV * shuttle = get_sv("shuttle", 0); 34 | sv_setiv(shuttle, 10); 35 | } 36 | BEGIN { pass 'cblock using Perl function macros again compiles fine' } 37 | is($shuttle, 10, 'Repeated cblocks work correctly'); 38 | 39 | cblock { 40 | sv_setiv(get_sv("shuttle", 0), 15); 41 | } 42 | BEGIN { pass 'cblock using nested Perl function macros compiles fine' } 43 | is ($shuttle, 15, 'nested function calls do not cause segfaults'); 44 | 45 | eval q{ 46 | cblock { 47 | SV * shuttle = get_sv("shuttle", 0); 48 | sv_setiv(shuttle, 50); 49 | } 50 | is($shuttle, 50, 'Simple string eval'); 51 | 1; 52 | } or do { 53 | fail "Simple string eval\n"; 54 | }; 55 | 56 | for (1..3) { 57 | eval qq{ 58 | cblock { 59 | SV * shuttle = get_sv("shuttle", 0); 60 | sv_setiv(shuttle, $_); 61 | } 62 | is(\$shuttle, $_, 'Repeated string eval number $_'); 63 | 1; 64 | } or do { 65 | fail "Repeated string eval number $_\n"; 66 | }; 67 | } 68 | 69 | 70 | done_testing; 71 | -------------------------------------------------------------------------------- /bench/rng/rng4.pl: -------------------------------------------------------------------------------- 1 | # Run with perl rng/rng.pl | tee rng/rng.txt 2 | # plot with perl plot-bench.pl rng/rng.txt 3 | use strict; 4 | use warnings; 5 | 6 | use C::Blocks; 7 | use Inline 'C'; 8 | use C::Blocks::Types qw(uint); 9 | use Benchmark qw(:hireswallclock cmpthese); 10 | 11 | my uint $N; 12 | my $a = 698769069; 13 | my ($x, $y, $z, $c) = (123456789, 362436000, 521288629, 7654321); 14 | my $reps = 10; 15 | for my $log_n (1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 5.5) { 16 | $N = int(10**$log_n); 17 | print "--- For N = $N ---\n"; 18 | cmpthese(-1, { Inline => \&Inline_rng, CBlocks => \&c_blocks_rng, 19 | Perl => \&Perl_rng}); 20 | } 21 | 22 | sub Perl_rng { 23 | my $rand; 24 | for (1 .. $N) { 25 | my $t; 26 | $x = 69069*$x+12345; 27 | $y ^= ($y<<13); $y ^= ($y>>17); $y ^= ($y<<5); 28 | $t = $a*$z+$c; $c = ($t>>32); 29 | $z = $t; 30 | $rand = $x+$y+$z; 31 | } 32 | return $rand; 33 | } 34 | 35 | clex { 36 | /* Note: y must never be set to zero; 37 | * z and c must not be simultaneously zero */ 38 | unsigned int x = 123456789,y = 362436000, 39 | z = 521288629,c = 7654321; /* State variables */ 40 | 41 | unsigned int KISS() { 42 | unsigned long long t, a = 698769069ULL; 43 | x = 69069*x+12345; 44 | y ^= (y<<13); y ^= (y>>17); y ^= (y<<5); 45 | t = a*z+c; c = (t>>32); 46 | return x+y+(z=t); 47 | } 48 | } 49 | 50 | sub c_blocks_rng { 51 | my uint $to_return = 0; 52 | cblock { 53 | for (int i = 0; i < $N; i++) $to_return = KISS(); 54 | } 55 | return $to_return; 56 | } 57 | 58 | sub Inline_rng { 59 | inl_rng($N); 60 | } 61 | 62 | __END__ 63 | 64 | __C__ 65 | 66 | /* Note: y must never be set to zero; 67 | * z and c must not be simultaneously zero */ 68 | static unsigned int x = 123456789,y = 362436000, 69 | z = 521288629,c = 7654321; /* State variables */ 70 | 71 | unsigned int inline_KISS() { 72 | unsigned long long t, a = 698769069ULL; 73 | x = 69069*x+12345; 74 | y ^= (y<<13); y ^= (y>>17); y ^= (y<<5); 75 | t = a*z+c; c = (t>>32); 76 | return x+y+(z=t); 77 | } 78 | 79 | unsigned int inl_rng(unsigned int N) { 80 | int i; 81 | unsigned int to_return; 82 | for (i = 0; i < N; i++) to_return = inline_KISS(); 83 | return to_return; 84 | } 85 | -------------------------------------------------------------------------------- /examples/prima-lib-ellipse.pl: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | prima-lib-ellipse.pl - testing how C::Blocks handles the C interface to the Prima GUI toolkit 4 | 5 | =head1 TO RUN 6 | 7 | In order to get the proper paths for Cing libprima, be sure to invoke 8 | this script from the distribution's root directory. It should look 9 | something like this: 10 | 11 | perl -Mblib examples/prima-lib-ellispe.pl 12 | 13 | =cut 14 | 15 | use strict; 16 | use warnings; 17 | use Prima qw(Application); 18 | use C::Blocks; 19 | 20 | # Declared elsewhere in the current folder 21 | use examples::libprima; 22 | 23 | # Create the globals. 24 | clex { 25 | #define N_POINTS 500 26 | Point points_to_plot[N_POINTS]; 27 | double A, B; 28 | } 29 | 30 | # Initialize the constants 31 | cblock { 32 | A = 40; 33 | B = 20; 34 | } 35 | 36 | my ($x, $y) = (1, 0); 37 | 38 | my $main = Prima::MainWindow-> new( text => 'Ellipse Animation', 39 | buffered => 1, 40 | onPaint => sub { 41 | my ($self, $canvas) = @_; 42 | return $self->repaint if $self->get_paint_state != 1; 43 | $self->clear; 44 | my $rotation = atan2($y - 250, $x - 250); 45 | cblock { 46 | Handle widget_handle = gimme_the_mate($self); 47 | /* Draw an ellipse tilted toward the mouse. Thanks to 48 | * http://www.uwgb.edu/dutchs/Geometry/HTMLCanvas/ObliqueEllipses5.HTM 49 | * for the formula. */ 50 | int i; 51 | double theta, theta_inc, theta_0, sin_theta_0, cos_theta_0; 52 | 53 | /* get the rotation, set the per-step theta increment */ 54 | theta_0 = SvNV($rotation); 55 | theta_inc = 2 * M_PI / N_POINTS; 56 | sin_theta_0 = sin(theta_0); 57 | cos_theta_0 = cos(theta_0); 58 | 59 | /* Build the set of points */ 60 | for (i = 0; i < N_POINTS; i++) { 61 | theta = i*theta_inc; 62 | points_to_plot[i].x = 250 + A * cos(theta)*cos_theta_0 63 | - B * sin(theta)*sin_theta_0; 64 | points_to_plot[i].y = 250 + A * cos(theta)*sin_theta_0 /* === */ 65 | + B * sin(theta)*cos_theta_0; 66 | } 67 | apc_gp_fill_poly (widget_handle, N_POINTS, points_to_plot); 68 | } 69 | }, 70 | onMouseMove => sub { 71 | (my $self, undef, $x, $y) = @_; 72 | $self->notify('Paint'); 73 | }, 74 | ); 75 | 76 | Prima->run; 77 | -------------------------------------------------------------------------------- /examples/pdl-periodogram.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks; 4 | use C::Blocks::PerlAPI; 5 | use PDL; 6 | 7 | # Build a sample dataset 8 | my $dt = 0.1; 9 | my $N_entries = 1000; 10 | my $data_pdl = sin(sequence($N_entries) * $dt); 11 | $data_pdl += $data_pdl->grandom; 12 | 13 | # Here is a 'function' that unpacks a piddle's dataref for me 14 | clex { 15 | #define get_data_pointer_from_ref(dataref) (double *)(SvPVbyte_nolen(SvRV(dataref))) 16 | } 17 | 18 | # Construct the frequencies to query 19 | my $N_frequencies = 1000; 20 | my $power = zeros($N_frequencies); 21 | my $frequencies = $power->xlogvals(1e-3, 100); 22 | 23 | # Set up the data and compute the periodogram 24 | my $data_ref = $data_pdl->get_dataref; 25 | my $frequencies_ref = $frequencies->get_dataref; 26 | my $power_ref = $power->get_dataref; 27 | cblock { 28 | /* Unpack the data */ 29 | int N_data = SvIV($N_entries); 30 | int N_oms = SvIV($N_frequencies); 31 | double * data = get_data_pointer_from_ref($data_ref); 32 | double * oms = get_data_pointer_from_ref($frequencies_ref); 33 | double * power = get_data_pointer_from_ref($power_ref); 34 | double t_step = SvNV($dt); 35 | 36 | /* Compute the value for each frequency */ 37 | int i, j; 38 | for (i = 0; i < N_oms; i++) { 39 | double om = oms[i]; 40 | 41 | /* compute tau */ 42 | double sin_sum = 0; 43 | double cos_sum = 0; 44 | for (j = 0; j < N_data; j++) { 45 | sin_sum += sin(2 * om * j * t_step); 46 | cos_sum += cos(2 * om * j * t_step); 47 | } 48 | double tau = atan(sin_sum / cos_sum) / 2 / om; 49 | 50 | /* compute the power at this frequency */ 51 | sin_sum = cos_sum = 0; 52 | double cos_sq_sum = 0; 53 | double sin_sq_sum = 0; 54 | double rel_t, sin_t, cos_t; 55 | for (j = 0; j < N_data; j++) { 56 | rel_t = j * t_step - tau; 57 | sin_t = sin(om * rel_t); 58 | cos_t = cos(om * rel_t); 59 | sin_sum += data[j] * sin_t; 60 | cos_sum += data[j] * cos_t; 61 | sin_sq_sum += sin_t*sin_t; 62 | cos_sq_sum += cos_t*cos_t; 63 | } 64 | power[i] = (sin_sum*sin_sum / sin_sq_sum + cos_sum*cos_sum / cos_sq_sum) / 2; 65 | } 66 | } 67 | $power->upd_data; 68 | 69 | use PDL::Graphics::Prima::Simple; 70 | line_plot($frequencies, $power); 71 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use File::Spec; 5 | use Module::Build; 6 | use Alien::TinyCCx; 7 | 8 | #### --( Make the builder )-- #### 9 | 10 | my $build = Module::Build->subclass(code => q{ 11 | sub link_c { 12 | my ($self, $spec) = @_; 13 | if ($spec->{module_name} eq 'C::Blocks') { 14 | return $self->SUPER::link_c($spec, @_); 15 | } 16 | else { 17 | # Don't link C source file objects to anything but the main lib 18 | local $self->{properties}->{objects} = []; 19 | return $self->SUPER::link_c($spec, @_); 20 | } 21 | } 22 | 23 | })->new( 24 | module_name => 'C::Blocks', 25 | license => 'perl', 26 | dist_author => q{David Mertens }, 27 | configure_requires => { 28 | 'Alien::TinyCCx' => '0.12', 29 | # meta_merge was added in v 0.28: 30 | 'Module::Build' => 0.28, 31 | }, 32 | build_requires => { 33 | 'Test::More' => 0.88, 34 | # For configuration, path to tcc, etc 35 | 'Alien::TinyCCx' => '0.12', 36 | # For PerlAPI 37 | 'Capture::Tiny' => 0, 38 | 'ExtUtils::CBuilder' => 0, 39 | 'ExtUtils::Config' => 0, 40 | 'ExtUtils::Embed' => 0, 41 | 'ExtUtils::ParseXS' => 3.0, 42 | 'File::Spec' => 0, 43 | 'File::Basename' => 0, 44 | 'File::Temp' => 0, 45 | 'File::Spec' => 0, 46 | 'Test::Warn' => 0, 47 | }, 48 | requires => { 49 | 'Alien::TinyCCx' => '0.12', 50 | 'File::ShareDir' => 0, 51 | 'File::Spec' => 0, 52 | }, 53 | c_source => 'src', 54 | needs_compiler => 1, 55 | dynamic_config => 1, 56 | include_dirs => [Alien::TinyCCx->libtcc_include_path, '.', 'src'], 57 | extra_linker_flags => [Alien::TinyCCx->MB_linker_flags], 58 | meta_merge => { 59 | resources => { 60 | repository => "http://github.com/run4flat/C-Blocks", 61 | bugtracker => "http://github.com/run4flat/C-Blocks/issues", 62 | }, 63 | no_index => { 64 | file => [ 'README.pod' ], 65 | }, 66 | }, 67 | share_dir => 'share', 68 | add_to_cleanup => [ 69 | 'names.txt', 70 | File::Spec->catfile(qw(share perl.h.cache)), 71 | ], 72 | ); 73 | 74 | $build->create_build_script; 75 | 76 | # Explicit cleanup of these, just in case, to avoid unnecessary confusion 77 | unlink('names.txt'); 78 | unlink File::Spec->catfile(qw(share perl.h.cache)); 79 | -------------------------------------------------------------------------------- /lib/C/Blocks/PerlAPI.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package C::Blocks::PerlAPI; 5 | 6 | # Figure out where the symbol table serialization file lives 7 | use File::ShareDir; 8 | use File::Spec; 9 | our $symtab_file_location; 10 | BEGIN { 11 | $symtab_file_location = File::Spec->catfile( 12 | File::ShareDir::dist_dir('C-Blocks'),'perl.h.cache' 13 | ); 14 | } 15 | 16 | require DynaLoader; 17 | our @ISA = qw( DynaLoader ); 18 | use C::Blocks (); 19 | *import = \&C::Blocks::load_lib; 20 | 21 | our $VERSION = '0.42'; 22 | bootstrap C::Blocks::PerlAPI $VERSION; 23 | $VERSION = eval $VERSION; 24 | 25 | 1; 26 | 27 | __END__ 28 | 29 | =head1 NAME 30 | 31 | C::Blocks::PerlAPI - C interface for interacting with Perl 32 | 33 | =head1 SYNOPSIS 34 | 35 | # implicitly loaded with C::Blocks: 36 | use C::Blocks; 37 | 38 | cshare { 39 | void say_hi() { 40 | PerlIO_stdoutf("hi!"); 41 | } 42 | } 43 | 44 | # Can be explicitly not loaded with C::Blocks via 45 | use C::Blocks -noPerlAPI; 46 | 47 | # Can later be explicitly loaded via 48 | use C::Blocks::PerlAPI; 49 | 50 | 51 | =head1 DESCRIPTION 52 | 53 | This C::Blocks module provides access to the Perl C library. The Perl C 54 | library includes most of the C standard library, and so is a convenient 55 | means for pulling in that functionality. 56 | 57 | Originally the PerlAPI was not loaded automatically, except when a 58 | sigiled variable was detected. It has become clear that the presence of 59 | the PerlAPI is the rule, not the exception. As such, it is automatically 60 | loaded when you C, unless you explicitly request it not 61 | load with C. 62 | 63 | Using C::Blocks::PerlaPI is roughly equivalent to including these lines 64 | at the top of your cblocks: 65 | 66 | #define PERL_NO_GET_CONTEXT 67 | #include "EXTERN.h" 68 | #include "perl.h" 69 | #include "XSUB.h" 70 | 71 | as well as linking to F. Of course, as a C::Blocks module, it also 72 | avoids the re-parsing necessary if you were to include those at the top of each 73 | of your cblocks. 74 | 75 | The Perl C library is vast, and a tutorial for it may be useful at some point. 76 | Until that time, I will simply refer you to L and L. 77 | 78 | =cut 79 | -------------------------------------------------------------------------------- /t/01-basics.t: -------------------------------------------------------------------------------- 1 | # This tests the basic operation of C::Blocks. It uses a special, simplified 2 | # communication interface that lets the C code communicate with Perl without 3 | # having to load libperl. 4 | 5 | use strict; 6 | use warnings; 7 | use Test::More; 8 | 9 | # Load cblocks 10 | use C::Blocks -noPerlAPI; 11 | # Tell C::Blocks to add rudimentary communications functions for testing 12 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 13 | 14 | # See if basic communicaton works 15 | $C::Blocks::_msg = ''; 16 | 17 | cblock { 18 | c_blocks_send_msg("Hello!"); 19 | } 20 | 21 | BEGIN { pass("First cblock compiles") } 22 | 23 | is($C::Blocks::_msg, 'Hello!', 'First cblock has desired side-effect'); 24 | 25 | # Pick a random digit between 0 and 4, to be doubled. I am restricting my 26 | # attention to 0 through 4 so that the doubled value is still a single digit. 27 | my @sample_data = (0 .. 4); 28 | my $datum = $sample_data[rand(@sample_data)]; 29 | $C::Blocks::_msg = $datum; 30 | 31 | cblock { 32 | char * msg = c_blocks_get_msg(); 33 | // convert the first char to a number 34 | int num = (int)(msg[0] - '0'); 35 | // double and store back in the string 36 | msg[0] = (char)(2 * num) + '0'; 37 | // send back the result 38 | c_blocks_send_msg(msg); 39 | } 40 | 41 | BEGIN { pass("Second cblock compiles") } 42 | 43 | is($C::Blocks::_msg, 2*$datum, 'Second cblock can retrieve and manipulate data'); 44 | 45 | # Test string evals with simple manipulation test 46 | eval q{ 47 | cblock { 48 | c_blocks_send_msg("50"); 49 | } 50 | BEGIN { pass "cblock compiles within string eval" } 51 | is($C::Blocks::_msg, 50, 'Simple string eval'); 52 | 1; 53 | } or do { 54 | fail 'Simple string eval'; 55 | diag($@); 56 | }; 57 | 58 | for (1..3) { 59 | eval qq{ 60 | cblock { 61 | c_blocks_send_msg("$_"); 62 | } 63 | is(\$C::Blocks::_msg, $_, 'Repeated string eval number $_'); 64 | 1; 65 | } or do { 66 | fail "Repeated string eval number $_\n"; 67 | }; 68 | } 69 | 70 | $C::Blocks::cq_line_directives = 1; 71 | my $code = cq { 72 | printf("Hello, world!\n"); 73 | }; 74 | 75 | like($code, qr/#line \d+/, "cq code string has line directive"); 76 | like($code, qr/printf\("Hello, world!\\n"\);/, "cq code string contains correct code"); 77 | 78 | done_testing; 79 | -------------------------------------------------------------------------------- /t/09-cleanup.t: -------------------------------------------------------------------------------- 1 | # For now, this tests two things. First, if a compilation fails, all the 2 | # memory associated with the compilation must be freed. Second, all 3 | # global variables are properly localized, namely $_. Eventually I would 4 | # also like to test that a string-eval'd cblock gets cleaned up, but 5 | # that's not part of this test yet. 6 | 7 | use strict; 8 | use warnings; 9 | use Test::More; 10 | 11 | # Load cblocks 12 | use C::Blocks -noPerlAPI; 13 | $C::Blocks::_add_msg_functions = 1; 14 | 15 | ######################################################################## 16 | # syntax error 17 | ######################################################################## 18 | 19 | undef $C::Blocks::_cleanup_called; 20 | eval q{ 21 | cblock { 22 | int i ( 23 | } 24 | }; 25 | my $death_note = $@; 26 | subtest "C syntax error" => sub { 27 | like($death_note, qr/C::Blocks compiler error/, "triggerred syntax error"); 28 | is ($C::Blocks::_cleanup_called, 1, "calls low-level cleanup method"); 29 | }; 30 | 31 | ######################################################################## 32 | # type croak 33 | ######################################################################## 34 | 35 | sub Foo::c_blocks_init_cleanup { die "What happens now?" } 36 | 37 | undef $C::Blocks::_cleanup_called; 38 | eval q{ 39 | my Foo $thing; 40 | cblock { 41 | $thing = 5; 42 | } 43 | }; 44 | $death_note = $@; 45 | subtest "type with c_blocks_init_cleanup function that croaks" => sub { 46 | like($death_note, qr/What happens now/, "triggerred croak in type"); 47 | is ($C::Blocks::_cleanup_called, 1, "calls low-level cleanup method"); 48 | }; 49 | 50 | ######################################################################## 51 | # croaking filter 52 | ######################################################################## 53 | 54 | undef $C::Blocks::_cleanup_called; 55 | $_ = 'not clobbered'; 56 | sub my_filter { 57 | die "What happens now?"; 58 | } 59 | eval q{ 60 | use C::Blocks::Filter '&my_filter'; 61 | cblock {} 62 | }; 63 | $death_note = $@; 64 | subtest "Croaking filter" => sub { 65 | like ($death_note, qr/What happens now/, "Die propogated/caught"); 66 | is ($_, 'not clobbered', 'does not clobber $_'); 67 | is ($C::Blocks::_cleanup_called, 1, "calls low-level cleanup method"); 68 | }; 69 | 70 | done_testing; 71 | -------------------------------------------------------------------------------- /t/60-filters.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | 5 | use C::Blocks; 6 | 7 | { 8 | #################################################################### 9 | # test C::Blocks::Filter # 10 | #################################################################### 11 | use Capture::Tiny qw(capture); 12 | my ($stdout, $stderr, @result) = capture { 13 | eval q{ 14 | use C::Blocks::Filter; 15 | cblock {} 16 | } 17 | }; 18 | is($stderr, '', "C::Blocks::Filter does not issue anything to stderr"); 19 | like($stdout, qr/void op_func/, "C::Blocks::Filter sends full C source to stdout"); 20 | } 21 | 22 | 23 | { 24 | #################################################################### 25 | # test BlockArrowMethods # 26 | #################################################################### 27 | 28 | use C::Blocks::Filter::BlockArrowMethods; 29 | 30 | # Build the vtable and object layouts 31 | clex { 32 | /* typedef for the object layout */ 33 | typedef struct bar_t bar; 34 | /* typedef for vtable */ 35 | typedef struct foo_t { 36 | int (*silly)(bar * obj); 37 | } foo; 38 | /* lone method */ 39 | int my_silly(bar * obj) { 40 | /* not do anything here */ 41 | } 42 | /* object layout */ 43 | struct bar_t { 44 | foo * methods; 45 | }; 46 | } 47 | 48 | cblock { 49 | foo my_foo; 50 | my_foo.silly = my_silly; 51 | 52 | bar my_bar_actual; 53 | bar* my_bar = &my_bar_actual; 54 | my_bar->methods = &my_foo; 55 | 56 | /* As written, this is invalid C code. If the filter works correctly 57 | * then this will compile and turn this whole block into a boring 58 | * no-op. */ 59 | my_bar=>silly(); 60 | } 61 | pass('BlockArrowMethods produces good code (when used appropriately)'); 62 | } 63 | 64 | { 65 | ################################################################### 66 | # test simple sub installer # 67 | ################################################################### 68 | my $contents; 69 | sub copy_contents { 70 | $contents = $_; 71 | } 72 | use C::Blocks::Filter qw(©_contents); 73 | # String eval, so we guarantee that this runs at runtime, not 74 | # compile time 75 | eval q{ 76 | cblock {} 77 | }; 78 | like($contents, qr/void op_func/, "Installing filter sub by name works"); 79 | } 80 | 81 | done_testing; 82 | -------------------------------------------------------------------------------- /bench/mandelbrot/mandelbrot2.cpl: -------------------------------------------------------------------------------- 1 | # The Computer Language Benchmarks Game 2 | # http://benchmarksgame.alioth.debian.org/ 3 | # 4 | # contributed by Mykola Zubach 5 | # modified by David Mertens to use C::Blocks 6 | 7 | use strict; 8 | use warnings; 9 | use C::Blocks; 10 | use C::Blocks::Types qw(uint char_array); 11 | use C::Blocks::PerlAPI; 12 | 13 | 14 | my uint ($w, $h); 15 | my (@threads, $invN); 16 | 17 | sub draw_line($) { 18 | my uint $y = shift; 19 | my char_array $line_contents; 20 | vec ($line_contents, $w / 8 - 1, 8) = 0; 21 | cblock { 22 | int bit_num = 0; 23 | char byte_acc = 0; 24 | int i, iter = 50; 25 | double x, limit = 2.0; 26 | double Zr, Zi, Cr, Ci, Tr, Ti; 27 | 28 | for(x=0; x < $w; ++x) { 29 | Zr = Zi = Tr = Ti = 0.0; 30 | Cr = (2.0 * x / $w - 1.5); 31 | Ci=(2.0*$y/$h - 1.0); 32 | 33 | for (i=0;i) { 78 | $cpus ++ if /^processor\s+:/; 79 | } 80 | return $cpus; 81 | } 82 | 83 | ## MAIN() 84 | 85 | $w = $h = shift || 200; 86 | $invN = 2 / $w; 87 | @jobs = (0 .. $h - 1); 88 | 89 | for (1 .. num_cpus()) { 90 | push @threads, threads->create(\&process_queue); 91 | } 92 | 93 | for (@threads) { 94 | $_->join; 95 | } 96 | 97 | print "P4\n$w $h\n"; # PBM image header 98 | print @picture; 99 | -------------------------------------------------------------------------------- /t/06-interpolation.t: -------------------------------------------------------------------------------- 1 | # This tests interpolation blocks. 2 | 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | # Load cblocks 8 | use C::Blocks; 9 | 10 | cblock { 11 | ${''} 12 | } 13 | BEGIN { pass 'cblock using empty-string interpolation compiles fine' } 14 | is($@, '', 'Executing empty block is fine'); 15 | 16 | our $package_var; 17 | my $lexical_var; 18 | BEGIN { 19 | is($package_var, undef, 'package_var is not initially defined'); 20 | is($lexical_var, undef, 'lexical_var is not initially defined'); 21 | } 22 | cblock { 23 | ${ 24 | $package_var = 2; 25 | $lexical_var = 2; 26 | '' 27 | } 28 | } 29 | 30 | BEGIN { 31 | is($package_var, 2, 'Assignment to package variables in interpolation blocks occurs at BEGIN time'); 32 | TODO: { 33 | local $TODO = 'Lexical vars get reset after parse and before BEGIN blocks for older Perls' 34 | if $^V le v5.18.1; 35 | is($lexical_var, 2, 'Assignment to lexical variables in interpolation blocks occurs at BEGIN time'); 36 | } 37 | } 38 | 39 | # Actually use and test the code interpolation 40 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 41 | $C::Blocks::_msg = ''; 42 | for (1 .. 3) { 43 | cblock { 44 | c_blocks_send_msg("block " ${ 45 | '"' . (++$package_var) . (++$lexical_var) . '"' 46 | }); 47 | } 48 | } 49 | BEGIN { 50 | is($package_var, 3, 'Modification of package variables in interpolation blocks occurs at BEGIN time'); 51 | TODO: { 52 | local $TODO = 'Lexical vars get reset after parse and before BEGIN blocks for older Perls' 53 | if $^V le v5.18.1; 54 | is($lexical_var, 3, 'Modification of lexical variables in interpolation blocks occurs at BEGIN time'); 55 | } 56 | } 57 | is ($C::Blocks::_msg, 'block 33', "Interpolation occurs at compile time with modified variable values"); 58 | 59 | ######################################################################## 60 | # Package of interpolation block 61 | ######################################################################## 62 | # Interpolation blocks should operate within the current package. It 63 | # turns out that the obvious mechanism for calling interpolation blocks, 64 | # namely eval_pv, uses the main package. This test ensures that the 65 | # proper work-arounds are in place so that the package is right. 66 | 67 | our $caller; 68 | sub note_caller { 69 | $caller = caller; 70 | } 71 | package OtherPackage; 72 | cblock { 73 | ${ 74 | main::note_caller(); 75 | '' 76 | } 77 | } 78 | 79 | package main; 80 | 81 | is($caller, 'OtherPackage', 'Interpolation blocks are executed in local package'); 82 | 83 | done_testing; 84 | -------------------------------------------------------------------------------- /examples/magic-objects/SOS05.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | =head1 NAME 5 | 6 | SOS05.pm - testing the REAL SOS.pm 7 | 8 | =head1 QUESTION 9 | 10 | My work from SOS01 to SOS04 informed my creation of C::Blocks::SOS. 11 | This is my first test of that module. This module creates a point class 12 | and implements a few basic functions: vector addition and subtraction, 13 | and magnitude and direction (angle). 14 | 15 | =cut 16 | 17 | package SOS05; 18 | use C::Blocks; 19 | use C::Blocks::Types qw; 20 | use C::Blocks::PerlAPI; 21 | use C::Blocks::Filter::BlockArrowMethods; 22 | #use C::Blocks::Filter; 23 | use C::Blocks::SOS sub { 24 | has (x => isa => float); 25 | has (y => isa => float); 26 | method (add => 27 | returns => 'SOS05', 28 | expects => ['SOS05' => 'other_point'], 29 | language => 'C', 30 | ); 31 | method (subtract => 32 | returns => 'SOS05', 33 | expects => ['SOS05' => 'other_point'], 34 | language => 'C', 35 | ); 36 | method (magnitude => 37 | returns => float, 38 | language => 'C', 39 | ); 40 | method (direction => 41 | returns => float, 42 | language => 'C', 43 | ); 44 | }; 45 | 46 | cshare { 47 | ${ SOS05->_declare } 48 | 49 | ${ SOS05->_signature('add') } { 50 | C::Blocks::SOS::Class::new(SOS05, to_return); 51 | to_return=>set_x(self=>get_x() + other_point=>get_x()); 52 | to_return=>set_y(self=>get_y() + other_point=>get_y()); 53 | return to_return; 54 | } 55 | 56 | ${ SOS05->_signature('subtract') } { 57 | C::Blocks::SOS::Class::new(SOS05, to_return); 58 | to_return=>set_x(self=>get_x() - other_point=>get_x()); 59 | to_return=>set_y(self=>get_y() - other_point=>get_y()); 60 | return to_return; 61 | } 62 | 63 | ${ SOS05->_signature('magnitude') } { 64 | float x = self=>get_x(); 65 | float y = self=>get_y(); 66 | return sqrt(x*x + y*y); //** 67 | } 68 | 69 | ${ SOS05->_signature('direction') } { 70 | return atan2f(self=>get_y(), self=>get_x()); 71 | } 72 | } 73 | 74 | cblock { 75 | ${ SOS05->_initialize } 76 | } 77 | 78 | sub new { 79 | my $to_return; 80 | cblock { 81 | /* Create and attach the object */ 82 | C::Blocks::SOS::Class::new(SOS05, self); 83 | self=>attach_SV($to_return); 84 | /* the constructor double-counts the refcount, so backup by 1 */ 85 | self=>refcount_dec(); 86 | } 87 | return $to_return; 88 | } 89 | 1; 90 | 91 | =head1 RESULTS 92 | 93 | F verifies that this works. This module uncovered a 94 | couple of bugs in the low-level C::Blocks interpolation block code, as 95 | well as a couple of bugs in SOS. Having resolved them, the code seems 96 | to function! 97 | 98 | =cut 99 | -------------------------------------------------------------------------------- /examples/prima-ellipse.pl: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | primatest.pl - testing how C::Blocks handles the C interface to the Prima GUI toolkit 4 | 5 | =cut 6 | 7 | use strict; 8 | use warnings; 9 | use blib; 10 | use Prima qw(Application); 11 | use Prima::Config; 12 | use ExtUtils::Embed; 13 | 14 | use C::Blocks; 15 | 16 | # Link to the Prima library: 17 | BEGIN { 18 | # Utilize ExtUtils::Embed to get some build info 19 | $C::Blocks::compiler_options = join(' ', $Prima::Config::Config{inc}, ccopts); 20 | 21 | # tcc doesn't know how to use quotes in -I paths; remove them if found. 22 | $C::Blocks::compiler_options =~ s/-I"([^"]*)"/-I$1/g if $^O =~ /MSWin/; 23 | 24 | # Set the Prima library 25 | @C::Blocks::libraries_to_link = ($Prima::Config::Config{dlname}); 26 | } 27 | clex { 28 | #include 29 | #include 30 | } 31 | 32 | # Create the globals. These must be declared in a separate block because 33 | # the previous block is linked to a library, which will be checked for 34 | # symbols instead of the compiler context. So, create a new context: 35 | clex { 36 | #define N_POINTS 500 37 | Point points_to_plot[N_POINTS]; 38 | double A, B; 39 | } 40 | 41 | # Initialize the constants 42 | cblock { 43 | A = 40; 44 | B = 20; 45 | } 46 | 47 | my ($x, $y) = (1, 0); 48 | 49 | my $main = Prima::MainWindow-> new( text => 'Ellipse Animation', 50 | buffered => 1, 51 | onPaint => sub { 52 | my ($self, $canvas) = @_; 53 | return $self->repaint if $self->get_paint_state != 1; 54 | $self->clear; 55 | my $rotation = atan2($y - 250, $x - 250); 56 | cblock { 57 | Handle widget_handle = gimme_the_mate($self); 58 | /* Draw an ellipse tilted toward the mouse. Thanks to 59 | * http://www.uwgb.edu/dutchs/Geometry/HTMLCanvas/ObliqueEllipses5.HTM 60 | * for the formula. */ 61 | int i; 62 | double theta, theta_inc, theta_0, sin_theta_0, cos_theta_0; 63 | 64 | /* get the rotation, set the per-step theta increment */ 65 | theta_0 = SvNV($rotation); 66 | theta_inc = 2 * M_PI / N_POINTS; 67 | sin_theta_0 = sin(theta_0); 68 | cos_theta_0 = cos(theta_0); 69 | 70 | /* Build the set of points */ 71 | for (i = 0; i < N_POINTS; i++) { 72 | theta = i*theta_inc; 73 | points_to_plot[i].x = 250 + A * cos(theta)*cos_theta_0 74 | - B * sin(theta)*sin_theta_0; 75 | points_to_plot[i].y = 250 + A * cos(theta)*sin_theta_0 /* === */ 76 | + B * sin(theta)*cos_theta_0; 77 | } 78 | apc_gp_fill_poly (widget_handle, N_POINTS, points_to_plot); 79 | } 80 | }, 81 | onMouseMove => sub { 82 | (my $self, undef, $x, $y) = @_; 83 | $self->notify('Paint'); 84 | }, 85 | ); 86 | 87 | Prima->run; 88 | -------------------------------------------------------------------------------- /t/19-clex-binds-correct-scope.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks -noPerlAPI; 5 | 6 | { 7 | local $TODO = 'Fix visiblity for clex following loop'; 8 | ok(eval q{ 9 | for (1) {} 10 | clex { int foo() {} } 11 | cblock { foo(); } 12 | 1; 13 | }, "Declarations in clex immediately following for-loop are visible") 14 | or diag "**Error message was** $@"; 15 | 16 | ok(eval q{ 17 | while (0) {} 18 | clex { int foo() {} } 19 | cblock { foo(); } 20 | 1; 21 | }, "Declarations in clex immediately following while-loop are visible") 22 | or diag "**Error message was** $@"; 23 | 24 | ok(eval q{ 25 | until (1) {} 26 | clex { int foo() {} } 27 | cblock { foo(); } 28 | 1; 29 | }, "Declarations in clex immediately following until-loop are visible") 30 | or diag "**Error message was** $@"; 31 | 32 | ok(eval q{ 33 | if (0) {} 34 | clex { int foo() {} } 35 | cblock { foo(); } 36 | 1; 37 | }, "Declarations in clex immediately following if block are visible") 38 | or diag "**Error message was** $@"; 39 | 40 | ok(eval q{ 41 | unless (1) {} 42 | clex { int foo() {} } 43 | cblock { foo(); } 44 | 1; 45 | }, "Declarations in clex immediately following unless block are visible") 46 | or diag "**Error message was** $@"; 47 | 48 | ok(eval q{ 49 | if (0) {} 50 | elsif (0) {} 51 | clex { int foo() {} } 52 | cblock { foo(); } 53 | 1; 54 | }, "Declarations in clex immediately following if-elsif block are visible") 55 | or diag "**Error message was** $@"; 56 | } 57 | 58 | ok(eval q{ 59 | if (0) {} 60 | else {} 61 | clex { int foo() {} } 62 | cblock { foo(); } 63 | 1; 64 | }, "Declarations in clex immediately following if-else block are visible") 65 | or diag "**Error message was** $@"; 66 | 67 | ok(eval q{ 68 | do {}; 69 | clex { int foo() {} } 70 | cblock { foo(); } 71 | 1; 72 | }, "Declarations in clex immediately following do block are visible") 73 | or diag "**Error message was** $@"; 74 | 75 | ok(eval q{ 76 | SOME_LABEL: { 77 | my $a = 5; 78 | redo SOME_LABEL if $a > 6; 79 | } 80 | continue { 81 | $a--; 82 | } 83 | clex { int foo() {} } 84 | cblock { foo(); } 85 | 1; 86 | }, "Declarations in clex immediately following bare block with continue are visible") 87 | or diag "**Error message was** $@"; 88 | 89 | ok(eval q{ 90 | SOME_LABEL: { 91 | my $a = 5; 92 | next SOME_LABEL if $a > 6; 93 | } 94 | clex { int foo() {} } 95 | cblock { foo(); } 96 | 1; 97 | }, "Declarations in clex immediately following bare block are visible") 98 | or diag "**Error message was** $@"; 99 | 100 | done_testing; 101 | -------------------------------------------------------------------------------- /src/cb_mem_mgmt.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | /* XXX I am 99% certain that this code can be undone. I generally like 4 | * the idea of consolidating memory allocations, but this was all 5 | * written in response to cache miss issues before feature creep ensued. 6 | * Cache issues have been resolved upstream (in tcc itself), so this 7 | * can probably be removed and the old approach in C/Blocks.xs should be 8 | * fine: 9 | * SV * machine_code_SV = newSV(machine_code_size); 10 | * ... 11 | * av_push(machine_code_cache, machine_code_SV); 12 | */ 13 | 14 | typedef struct executable_memory executable_memory; 15 | struct executable_memory { 16 | uintptr_t curr_address; 17 | uintptr_t bytes_remaining; 18 | executable_memory * next; 19 | char base_address[0]; 20 | }; 21 | 22 | executable_memory * my_mem_root; 23 | executable_memory * my_mem_tail; 24 | 25 | void *cb_mem_alloc(size_t n_bytes) { 26 | if (n_bytes > my_mem_tail->bytes_remaining) { 27 | /* allocate requested plus 16K of memory */ 28 | my_mem_tail->next = malloc(sizeof(executable_memory) + n_bytes + 16384); 29 | my_mem_tail = my_mem_tail->next; 30 | my_mem_tail->curr_address = (uintptr_t)my_mem_tail->base_address; 31 | my_mem_tail->bytes_remaining = n_bytes + 16384; 32 | /* check alignment */ 33 | if ((my_mem_tail->curr_address & 63) != 0) { 34 | my_mem_tail->curr_address &= ~63; 35 | my_mem_tail->curr_address += 64; 36 | my_mem_tail->bytes_remaining 37 | -= my_mem_tail->curr_address - (uintptr_t)my_mem_tail->base_address; 38 | } 39 | my_mem_tail->next = 0; 40 | } 41 | void * to_return = (void*)my_mem_tail->curr_address; 42 | 43 | /* update and align curr_address */ 44 | my_mem_tail->curr_address += n_bytes; 45 | if ((my_mem_tail->curr_address & 63) != 0) { 46 | my_mem_tail->curr_address &= ~63; 47 | my_mem_tail->curr_address += 64; 48 | } 49 | my_mem_tail->bytes_remaining 50 | -= my_mem_tail->curr_address - (uintptr_t)to_return; 51 | return to_return; 52 | } 53 | 54 | void cb_mem_mgmt_init() { 55 | my_mem_tail = my_mem_root = malloc(sizeof(executable_memory) + 16384); 56 | my_mem_tail->curr_address = (uintptr_t)my_mem_tail->base_address; 57 | my_mem_tail->bytes_remaining = 16384; 58 | if ((my_mem_tail->curr_address & 0x63) != 0) { 59 | my_mem_tail->curr_address &= ~63; 60 | my_mem_tail->curr_address += 64; 61 | my_mem_tail->bytes_remaining 62 | -= my_mem_tail->curr_address - (uintptr_t)my_mem_tail->base_address; 63 | } 64 | my_mem_tail->next = 0; 65 | } 66 | 67 | void cb_mem_mgmt_cleanup() { 68 | /* Remove all the code pages */ 69 | executable_memory * to_cleanup = my_mem_root; 70 | while(to_cleanup) { 71 | executable_memory * tmp = to_cleanup->next; 72 | free(to_cleanup); 73 | to_cleanup = tmp; 74 | } 75 | } 76 | 77 | -------------------------------------------------------------------------------- /bench/prime-numbers.pl: -------------------------------------------------------------------------------- 1 | # This calculates the first N prime numbers. 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use C::Blocks; 7 | use C::Blocks::PerlAPI; 8 | use Benchmark qw(timethese :hireswallclock); 9 | 10 | # Generate some data 11 | my ($N, $printout); 12 | $printout = 0; 13 | for my $log_n (1, 1.5, 2, 2.5, 3) { 14 | $N = int(10**$log_n); 15 | print "--- For N = $N ---\n"; 16 | 17 | timethese(1000, { 18 | perl_primes => \&perl_primes, 19 | CBlocks_primes => \&c_blocks_primes, 20 | }); 21 | $printout = 1 if $log_n == 2; 22 | print "Perl function gave ", perl_primes(), " and C::Blocks function gave ", 23 | c_blocks_primes(), "\n"; 24 | $printout = 0; 25 | } 26 | 27 | # Finds the Nth prime 28 | sub perl_primes { 29 | my @primes = (2); 30 | my $candidate = 1; # so that with increment, it'll go to 3 31 | CANDIDATE: while (@primes < $N) { 32 | $candidate += 2; 33 | my $sqrt_candidate = sqrt($candidate); 34 | PRIME: for my $prime (@primes) { 35 | last PRIME if $sqrt_candidate < $prime; 36 | my $div = $candidate / $prime; 37 | next CANDIDATE if $div == int($div); 38 | } 39 | # Out here means it's prime! 40 | push @primes, $candidate; 41 | } 42 | print "Perl primes: @primes\n" if $printout; 43 | return $primes[-1]; 44 | } 45 | 46 | sub c_blocks_primes { 47 | my $to_return; 48 | cblock { 49 | /* Set up variables */ 50 | int N = SvIV($N); 51 | int i, j, candidate, sqrt_candidate, N_found; 52 | int * prime_list; 53 | Newx(prime_list, N, int); 54 | 55 | /* Always start with 2 */ 56 | prime_list[0] = 2; 57 | candidate = 1; /* so that with increment, it'll go to 3 */ 58 | N_found = 1; 59 | 60 | /* mostly equivalent to Perl code above */ 61 | NEXT_CANDIDATE: while(N_found < N) { 62 | candidate += 2; 63 | sqrt_candidate = sqrt(candidate); 64 | for (j = 0; j < N_found; j++) { 65 | int curr_prime = prime_list[j]; 66 | if (sqrt_candidate < curr_prime) { 67 | /* if none of the primes below sqrt_candidate divide 68 | * into it, it must be prime. */ 69 | prime_list[N_found] = candidate; 70 | N_found++; 71 | goto NEXT_CANDIDATE; 72 | } 73 | 74 | /* if curr_prime divides evenly into the candidate, then 75 | * the candidate is not prime. */ 76 | if ((double)candidate / (double)curr_prime 77 | == (double)(candidate / curr_prime)) break; 78 | } 79 | /* Not a prime, move on to the next */ 80 | } 81 | 82 | if (SvIV($printout)) { 83 | printf("C::Blocks primes: "); 84 | for (i = 0; i < N-1; i++) printf("%d ", prime_list[i]); 85 | printf("%d\n", candidate); 86 | } 87 | 88 | /* Clean up memory and set the to-return variable based on the 89 | * last candidate */ 90 | Safefree(prime_list); 91 | sv_setiv($to_return, candidate); 92 | } 93 | return $to_return; 94 | } 95 | -------------------------------------------------------------------------------- /t/16-clex-scoping.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks -noPerlAPI; 5 | 6 | # Tell C::Blocks to add rudimentary communications functions for testing 7 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 8 | 9 | # Define a function to be used later 10 | clex { 11 | double subtract(double first, double second) { 12 | return first - second; 13 | } 14 | double * get_numbers() { 15 | return (double*)c_blocks_get_msg(); 16 | } 17 | } 18 | 19 | BEGIN { pass 'outer clex compiles fine' } 20 | 21 | # Generate two random numbers; make it easy to msg them 22 | my @numbers = map { rand() } (1 .. 2); 23 | sub copy_numbers_to_msg { 24 | $C::Blocks::_msg = pack('d*', @numbers); 25 | } 26 | 27 | # Enter a block; clex material should stay within the block 28 | { 29 | # Ensure the cblock works as expected 30 | copy_numbers_to_msg; # send data 31 | cblock { 32 | double * numbers = get_numbers(); // get data 33 | double result = subtract(numbers[0], numbers[1]); // subtract 34 | c_blocks_send_bytes(&result, sizeof(double)); // send result 35 | } 36 | 37 | BEGIN { pass 'inner cblock compiles fine' } 38 | 39 | my $answer = unpack('d', $C::Blocks::_msg); 40 | is($answer, $numbers[0] - $numbers[1], 'get_numbers and subtract work in nested block'); 41 | 42 | # Define a function that performs the check for us 43 | clex { 44 | void perform_subtract_check() { 45 | double * numbers = get_numbers(); // get data 46 | double result = subtract(numbers[0], numbers[1]); // subtract 47 | c_blocks_send_bytes(&result, sizeof(double)); // send result 48 | } 49 | } 50 | BEGIN { pass 'inner clex compiles fine' } 51 | # Send the data, call the subtraction function 52 | copy_numbers_to_msg; 53 | cblock { perform_subtract_check(); } 54 | BEGIN { pass 'inner cblock compiles fine' } 55 | 56 | $answer = unpack('d', $C::Blocks::_msg); 57 | is($answer, $numbers[0] - $numbers[1], 'get_numbers and subtract work in nested function'); 58 | } 59 | 60 | BEGIN { pass 'exiting block works fine' } 61 | eval q{ 62 | copy_numbers_to_msg; 63 | cblock { perform_subtract_check(); } 64 | fail('Cannot call a function outside its lexical scope'); 65 | 1; 66 | } or do { 67 | like($@, qr/undeclared function/, 'Cannot call a function outside its lexical scope'); 68 | }; 69 | 70 | eval q{ 71 | use C::Blocks::PerlAPI; 72 | copy_numbers_to_msg; # send data 73 | cblock { 74 | double * numbers = get_numbers(); // get data 75 | double result = subtract(numbers[0], numbers[1]); // subtract 76 | c_blocks_send_bytes(&result, sizeof(double)); // send result 77 | } 78 | 79 | BEGIN { pass 'inner cblock compiles fine' } 80 | 81 | my $answer = unpack('d', $C::Blocks::_msg); 82 | is($answer, $numbers[0] - $numbers[1], 'C::Blocks::PerlAPI does not clobber clex'); 83 | } 84 | or fail('C::Blocks::PerlAPI does not clobber clex'); 85 | 86 | done_testing; 87 | -------------------------------------------------------------------------------- /lib/C/Blocks/Types/Pointers.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package C::Blocks::Types::Pointers; 5 | our $VERSION = '0.42'; 6 | $VERSION = eval $VERSION; 7 | 8 | # XXXXXXXX use Package::Generator for better control? 9 | 10 | sub import { 11 | my ($package, @args) = @_; 12 | 13 | while (@args) { 14 | my ($name, $signature) = splice @args, 0, 2; 15 | my $pointer_package = $name; 16 | $pointer_package = "C::Blocks::Types::Pointers::$name" 17 | if $name !~ /::/; 18 | my $short_name = $name; 19 | $short_name =~ s/.*:://; 20 | 21 | # create the type's package 22 | no strict 'refs'; 23 | *{"${pointer_package}::c_blocks_init_cleanup"} 24 | = generate_init_cleanup($signature); 25 | *{"${pointer_package}::c_blocks_pack_SV"} 26 | = generate_pack($signature); 27 | *{"${pointer_package}::c_blocks_unpack_SV"} 28 | = generate_unpack($signature); 29 | *{"${pointer_package}::c_blocks_new_SV"} 30 | = \&c_blocks_new_SV; 31 | *{"${pointer_package}::c_blocks_data_type"} = sub { $signature }; 32 | 33 | # Shove the short name into the caller's context. Creating a 34 | # separate variable $long_name is part of the trick to getting 35 | # Perl to believe that this is actually a constant sub. 36 | my $pkg = caller; 37 | my $long_name = $pointer_package; 38 | *{"${pkg}::${short_name}"} = sub () { $long_name }; 39 | } 40 | } 41 | 42 | sub generate_init_cleanup { 43 | my $pointer_type = shift; 44 | return sub { 45 | my ($package, $C_name, $sigil_type, $pad_offset) = @_; 46 | 47 | my $init_code = qq{ 48 | $sigil_type * SV_$C_name = ($sigil_type*)PAD_SV($pad_offset); 49 | #define $C_name (*POINTER_TO_$C_name) 50 | if (!SvIOK(SV_$C_name)) SvUPGRADE(SV_$C_name, SVt_IV); 51 | $pointer_type * POINTER_TO_$C_name = INT2PTR($pointer_type *, &SvIVX(SV_$C_name)); 52 | }; 53 | 54 | return $init_code; 55 | }; 56 | } 57 | 58 | sub generate_pack { 59 | my $pointer_type = shift; 60 | return sub { 61 | my ($package, $C_name, $SV_name, $must_declare_SV) = @_; 62 | return "SV * $SV_name = newSViv(PTR2IV($C_name));" 63 | if $must_declare_SV; 64 | return "sv_setiv($SV_name, PTR2IV($C_name));"; 65 | }; 66 | } 67 | 68 | sub c_blocks_new_SV { "newSViv(PTR2IV($_[1]))" } 69 | 70 | sub generate_unpack { 71 | my $pointer_type = shift; 72 | return sub { 73 | my ($package, $SV_name, $C_name, $must_declare_name) = @_; 74 | my $declare = ''; 75 | $declare = "$pointer_type " if $must_declare_name; 76 | return "$declare$C_name = INT2PTR($pointer_type, SvIV($SV_name));"; 77 | }; 78 | } 79 | 80 | __END__ 81 | 82 | =head1 NAME 83 | 84 | C::Blocks::Types::Pointers - declare pointer types for C::Blocks 85 | 86 | =head1 VERSION 87 | 88 | This documentation is for v0.42 89 | 90 | =head1 SYNOPSIS 91 | 92 | use C::Blocks; 93 | use C::Blocks::Types::Pointers MyStruct => 'MyStruct*'; 94 | 95 | # Later along in code 96 | my MyStruct $foo = 0; 97 | 98 | ... needs more documentation ... 99 | -------------------------------------------------------------------------------- /t/12-clex-struct.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks -noPerlAPI; 5 | 6 | # Tell C::Blocks to add rudimentary communications functions for testing 7 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 8 | 9 | # Build a few functions that call the messaging interface 10 | clex { 11 | /* Note that I must use c_blocks_send_bytes to send data from C 12 | * back to Perl. */ 13 | struct my_data { 14 | double x; 15 | double y; 16 | }; 17 | } 18 | 19 | $C::Blocks::_msg = pack('d', 0); 20 | my $double_size = length($C::Blocks::_msg); 21 | 22 | cblock { 23 | int x_offset = ((int)(&((struct my_data*)0)->x)); 24 | c_blocks_send_bytes(&x_offset, sizeof(int)); 25 | } 26 | my ($offset) = unpack('i', $C::Blocks::_msg); 27 | is($offset, 0, 'Sensible offset for x member'); 28 | 29 | cblock { 30 | int y_offset = ((int)(&((struct my_data*)0)->y)); 31 | c_blocks_send_bytes(&y_offset, sizeof(int)); 32 | } 33 | ($offset) = unpack('i', $C::Blocks::_msg); 34 | is($offset, $double_size, 'Sensible offset for y member'); 35 | 36 | cblock { 37 | int x_offset = ((int)(&((struct my_data*)0)->x)); 38 | c_blocks_send_bytes(&x_offset, sizeof(int)); 39 | } 40 | ($offset) = unpack('i', $C::Blocks::_msg); 41 | is($offset, 0, 'Sensible offset for x member (again)'); 42 | 43 | cblock { 44 | int y_offset = ((int)(&((struct my_data*)0)->y)); 45 | c_blocks_send_bytes(&y_offset, sizeof(int)); 46 | } 47 | ($offset) = unpack('i', $C::Blocks::_msg); 48 | is($offset, $double_size, 'Sensible offset for y member (again)'); 49 | 50 | 51 | 52 | 53 | 54 | BEGIN { pass 'Lexical block with struct definition compiles without trouble' } 55 | pass('At runtime, lexical block with struct gets skipped without trouble'); 56 | 57 | # Start by packing in an interesting piece of data (gotta end with a null byte) 58 | $C::Blocks::_msg = pack('dd', 10, 5); 59 | 60 | #### Unpack that data, perform the subtraction, and send back the result 61 | cblock { 62 | struct my_data * data = (void*) c_blocks_get_msg(); 63 | double prod = data->x * data->y; 64 | double div = data->x / data->y; 65 | data->x = prod; 66 | data->y = div; 67 | } 68 | BEGIN { pass 'first cblock after lexical block compiles without trouble' } 69 | pass 'first cblock is called and run without trouble'; 70 | my ($x, $y) = unpack('dd', $C::Blocks::_msg); 71 | is($x, 50, 'Computes and packs the product'); 72 | is($y, 2, 'Computes and packs the ratio'); 73 | 74 | # Ensure we have enough memory for the next step. There's no simple way for me 75 | # to allocate memory within a cblock, so I have to preallocate it here. 76 | $C::Blocks::_msg = pack('dd', 0.3, 0.1); 77 | 78 | #### Modify with another cblock 79 | cblock { 80 | struct my_data new_data; 81 | new_data.x = -10; 82 | new_data.y = -5; 83 | c_blocks_send_bytes(&new_data, sizeof(struct my_data)); 84 | } 85 | BEGIN { pass 'second cblock after lexical block compiles without trouble' } 86 | pass 'second cblock is called and run without incident'; 87 | ($x, $y) = unpack('dd', $C::Blocks::_msg); 88 | 89 | is($x, -10, 'Second modification works'); 90 | is($y, -5, 'Second modification works'); 91 | 92 | done_testing; 93 | -------------------------------------------------------------------------------- /examples/magic-objects/SOS03.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | =head1 NAME 5 | 6 | SOS03.pm - subclassing SOS01 7 | 8 | =head1 QUESTION 9 | 10 | How do I subclass SOS01? More specifically, what is the minimum amount 11 | of work I need to do to create a new class with a different method, but 12 | same structure? 13 | 14 | Thankfully, I will not need to worry about implementing the magic again. 15 | That is a problem I only need to solve once. 16 | 17 | If I wanted to add a new method, I would need to create a new vtable, 18 | and if I had a new vtable, I would need to create a new class with a 19 | vtable pointer of the correct type. I would have to go through the same 20 | effort if I wanted to add a new attribute (whether or not I created 21 | accessors for that attribute). 22 | 23 | But, for now, I just want a different implementation of a method. What 24 | can I get away with? 25 | 26 | =cut 27 | 28 | package SOS03; 29 | use C::Blocks; 30 | use SOS01; 31 | use C::Blocks::PerlAPI; 32 | use C::Blocks::Filter::BlockArrowMethods; 33 | our @ISA = qw(SOS01); 34 | 35 | cshare { 36 | /* create new refcount_dec that simply wraps the parent method, 37 | * after logging its presence */ 38 | void SOS03::refcount_dec(SOS01 self) { 39 | entering; 40 | /* call parent method */ 41 | SOS01::refcount_dec(self); 42 | leaving; 43 | } 44 | 45 | /* In order to initialize (most of) the vtable instance statically, 46 | * the new() method needs to be *declared* before the vtable 47 | * and *defined* afterwrd. All other methods should be defined 48 | * earleir. */ 49 | SOS01 SOS03::new(); 50 | 51 | /* We'll need a new vtable instance, but the structure is identical */ 52 | SOS01::VTABLE_LAYOUT SOS03::VTABLE_INSTANCE = { 53 | SOS03::new, 54 | SOS01::refcount_inc, 55 | SOS03::refcount_dec, 56 | SOS01::destroy, 57 | sizeof(struct SOS01_t), 58 | NULL, 59 | SOS01::get_HV, 60 | SOS01::attach_SV 61 | }; 62 | typedef SOS01 SOS03; 63 | 64 | /* create a constructor that properly "blesses" this object */ 65 | SOS01 SOS03::new() { 66 | /* just allocate memory for object */ 67 | return SOS01::alloc(SOS03); 68 | } 69 | } 70 | 71 | cblock { 72 | _entering("SOS03 Initialization block"); 73 | /* Initialize the only dynamic element of the table. Everything else 74 | * was already assigned statically. */ 75 | SOS03::VTABLE_INSTANCE._class_stash = gv_stashpv("SOS01", GV_ADD); 76 | _leaving("SOS03 Initialization block"); 77 | } 78 | 79 | # Perl-side constructor 80 | sub new { 81 | print "Entering Perl-side SOS03 new()\n"; 82 | my $to_return; 83 | cblock { 84 | _entering("C-side SOS03 new()"); 85 | /* Create and attach the object */ 86 | SOS01 self = SOS03::new(); 87 | self=>attach_SV(aTHX_ $to_return); 88 | /* the constructor double-counts the refcount, so backup by 1 */ 89 | self=>refcount_dec(); 90 | _leaving("C-side SOS03 new()"); 91 | } 92 | print "Leaving Perl-side SOS03 new()\n"; 93 | return $to_return; 94 | } 95 | 96 | 1; 97 | 98 | =head1 RESULTS 99 | 100 | F verifies that this works. The answer to my 101 | question is that it takes about 60 lines of code to create a subclass 102 | that simply overrides one C method with another. 103 | 104 | =cut 105 | -------------------------------------------------------------------------------- /bench/random-access/random-access.pl: -------------------------------------------------------------------------------- 1 | # Run with perl random-access/random-access.pl | tee random-access/results.txt 2 | # plot with perl plot-bench.pl random-access/results.txt 3 | use strict; 4 | use warnings; 5 | 6 | use File::Path qw(remove_tree); 7 | END { 8 | # Keep things from getting messy 9 | remove_tree('_Inline'); 10 | } 11 | 12 | BEGIN { print "Compiling...\n" } 13 | print "Here we go!\n"; 14 | use C::Blocks; 15 | use Inline 'C'; 16 | use C::Blocks::Types qw(uint Int int_array); 17 | use Time::HiRes qw(time); 18 | 19 | my uint $N; 20 | my int_array $random_data; 21 | vec($random_data, 100_000_000, 32) = 0; 22 | setup_random_data(); 23 | my $reps = 100; 24 | for my $log_n (1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 5.5, 6) { 25 | $N = int(10**$log_n); 26 | print "--- For N = $N ---\n"; 27 | my ($cblocks_result, $inline_result, $start); 28 | my $cblocks_duration = 0; 29 | my $inline_duration = 0; 30 | for (1 .. $reps) { 31 | # Time a single C::Blocks call 32 | my $start = time; 33 | $cblocks_result = c_blocks_rng(); 34 | $cblocks_duration += time() - $start; 35 | $start = time; 36 | $inline_result = Inline_rng(); 37 | $inline_duration += time() - $start; 38 | # if ($cblocks_result != $inline_result) { 39 | # print "For cblocks I got $cblocks_result but for inline I got $inline_result\n"; 40 | # } 41 | } 42 | print "CBlocks: $cblocks_duration wallclock seconds\n"; 43 | print " Inline: $inline_duration wallclock seconds\n"; 44 | } 45 | 46 | sub Inline_rng { 47 | inl_rng($N, $random_data); 48 | } 49 | 50 | clex { 51 | /* Note: y must never be set to zero; 52 | * z and c must not be simultaneously zero */ 53 | unsigned int x = 123456789,y = 362436000, 54 | z = 521288629,c = 7654321; /* State variables */ 55 | 56 | unsigned int KISS() { 57 | unsigned long long t, a = 698769069ULL; 58 | x = 69069*x+12345; 59 | y ^= (y<<13); y ^= (y>>17); y ^= (y<<5); 60 | t = a*z+c; c = (t>>32); 61 | return x+y+(z=t); 62 | } 63 | } 64 | 65 | sub setup_random_data { 66 | cblock { 67 | for (int i = 0; i < 100000000; i++) { 68 | if (KISS() > 2147483646) { 69 | $random_data[i] = 1; 70 | } 71 | else { 72 | $random_data[i] = -1; 73 | } 74 | } 75 | 76 | /* reset state */ 77 | // x = 123456789, y = 362436000, z = 521288629, c = 7654321; 78 | } 79 | } 80 | 81 | sub c_blocks_rng { 82 | my Int $to_return = 0; 83 | cblock { 84 | for (int i = 0; i < $N; i++) { 85 | $to_return += $random_data[KISS() % 100000000]; 86 | } 87 | } 88 | return $to_return; 89 | } 90 | 91 | __END__ 92 | 93 | __C__ 94 | 95 | /* Note: y must never be set to zero; 96 | * z and c must not be simultaneously zero */ 97 | static unsigned int x = 123456789,y = 362436000, 98 | z = 521288629,c = 7654321; /* State variables */ 99 | 100 | unsigned int inline_KISS() { 101 | unsigned long long t, a = 698769069ULL; 102 | x = 69069*x+12345; 103 | y ^= (y<<13); y ^= (y>>17); y ^= (y<<5); 104 | t = a*z+c; c = (t>>32); 105 | return x+y+(z=t); 106 | } 107 | 108 | int inl_rng(unsigned int N, char * random_data_) { 109 | int i; 110 | int * random_data = (int*)random_data_; 111 | int to_return = 0; 112 | for (i = 0; i < N; i++) { 113 | to_return += random_data[inline_KISS() % 100000000]; 114 | } 115 | return to_return; 116 | } 117 | -------------------------------------------------------------------------------- /bench/rng/rng3.pl: -------------------------------------------------------------------------------- 1 | # Run with perl rng/rng.pl | tee rng/rng.txt 2 | # plot with perl plot-bench.pl rng/rng.txt 3 | use strict; 4 | use warnings; 5 | 6 | # Speed tabulations: 7 | # sfssssssssssssssssffssssssssfsfsfs 8 | 9 | use File::Path qw(remove_tree); 10 | END { 11 | # Keep things from getting messy 12 | remove_tree('_Inline'); 13 | } 14 | 15 | BEGIN { print "Compiling...\n" } 16 | print "Here we go!\n"; 17 | use C::Blocks; 18 | use Inline 'C'; 19 | use C::Blocks::Types qw(uint); 20 | use Time::HiRes qw(time); 21 | 22 | my uint $N; 23 | my $a = 698769069; 24 | my ($x, $y, $z, $c) = (123456789, 362436000, 521288629, 7654321); 25 | my $reps = 10; 26 | for my $log_n (1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 5.5) { 27 | $N = int(10**$log_n); 28 | print "--- For N = $N ---\n"; 29 | 30 | my ($cblocks_result, $inline_result, $perl_result, $start); 31 | my ($cblocks_duration, $inline_duration, $perl_duration) = (0, 0, 0); 32 | for (1 .. $reps) { 33 | # Time a single C::Blocks call 34 | my $start = time; 35 | $cblocks_result = c_blocks_rng(); 36 | $cblocks_duration += time() - $start; 37 | # Inline::C 38 | $start = time; 39 | $inline_result = Inline_rng(); 40 | $inline_duration += time() - $start; 41 | # Pure Perl 42 | $start = time; 43 | $perl_result = Perl_rng(); 44 | $perl_duration += time() - $start; 45 | # Check for consistency 46 | if ($cblocks_result != $inline_result 47 | and $perl_result != $inline_result 48 | and $cblocks_result != $perl_result) 49 | { 50 | print "No agreement! C::Blocks gave $cblocks_result, Inline gave $inline_result, Perl gave $perl_result\n"; 51 | } 52 | elsif ($cblocks_result != $inline_result and $cblocks_result != $perl_result) { 53 | print "C::Blocks result ($cblocks_result) disagrees with Perl and Inline ($inline_result)\n"; 54 | } 55 | elsif ($cblocks_result != $inline_result) { 56 | print "Inline result ($inline_result) disagrees with Perl and C::Blocks ($perl_result)\n"; 57 | } 58 | } 59 | 60 | print "CBlocks: $cblocks_duration wallclock seconds\n"; 61 | print " Inline: $inline_duration wallclock seconds\n"; 62 | print " Perl: $perl_duration wallclock seconds\n"; 63 | } 64 | 65 | 66 | sub Perl_rng { 67 | my $rand; 68 | for (1 .. $N) { 69 | my $t; 70 | $x = 69069*$x+12345; 71 | $y ^= ($y<<13); $y ^= ($y>>17); $y ^= ($y<<5); 72 | $t = $a*$z+$c; $c = ($t>>32); 73 | $z = $t; 74 | $rand = $x+$y+$z; 75 | } 76 | return $rand; 77 | } 78 | 79 | use MyRNG; 80 | sub c_blocks_rng { 81 | my uint $to_return = 0; 82 | cblock { 83 | for (int i = 0; i < $N; i++) $to_return = KISS(); 84 | } 85 | return $to_return; 86 | } 87 | 88 | sub Inline_rng { 89 | inl_rng($N); 90 | } 91 | 92 | __END__ 93 | 94 | __C__ 95 | 96 | /* Note: y must never be set to zero; 97 | * z and c must not be simultaneously zero */ 98 | static unsigned int x = 123456789,y = 362436000, 99 | z = 521288629,c = 7654321; /* State variables */ 100 | 101 | unsigned int inline_KISS() { 102 | unsigned long long t, a = 698769069ULL; 103 | x = 69069*x+12345; 104 | y ^= (y<<13); y ^= (y>>17); y ^= (y<<5); 105 | t = a*z+c; c = (t>>32); 106 | return x+y+(z=t); 107 | } 108 | 109 | unsigned int inl_rng(unsigned int N) { 110 | int i; 111 | unsigned int to_return; 112 | for (i = 0; i < N; i++) to_return = inline_KISS(); 113 | return to_return; 114 | } 115 | -------------------------------------------------------------------------------- /examples/mgpoint.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package mgpoint; 5 | { 6 | use C::Blocks; 7 | use C::Blocks::PerlAPI; 8 | use C::Blocks::Object::Magic; 9 | use C::Blocks::Types qw(double); 10 | 11 | sub c_blocks_init_cleanup { 12 | my ($package, $C_name, $sigil_type, $pad_offset) = @_; 13 | 14 | my $init_code = "$sigil_type * _hidden_$C_name = ($sigil_type*)PAD_SV($pad_offset); " 15 | . "point * $C_name = data_from_SV(_hidden_$C_name); "; 16 | 17 | return $init_code; 18 | } 19 | 20 | cshare { 21 | /* Define a simple x/y data pint using a struct */ 22 | typedef struct point { 23 | double x; 24 | double y; /* ;;; syntax hilite :-( */ 25 | } point; 26 | 27 | /* C-side constructor allocates memory and initializes 28 | * the data to point to the origin. Note the macro 29 | * wrapper, which makes working with threaded perls a 30 | * little bit cleaner. */ 31 | point * new_point(pTHX) { 32 | #define new_point() new_point(aTHX) 33 | point * to_return; 34 | Newx(to_return, 1, point); 35 | to_return->x = 0; 36 | to_return->y = 0; 37 | return to_return; 38 | } 39 | 40 | /* C-side function that retrieves and properly casts 41 | * the struct from the Perl-side SV. */ 42 | point * data_from_SV(pTHX_ SV * perl_side) { 43 | #define data_from_SV(perl_side) data_from_SV(aTHX_ perl_side) 44 | return xs_object_magic_get_struct_rv(aTHX_ perl_side); 45 | } 46 | } 47 | 48 | # Perl-side constructor. Build an empty hash and attach the 49 | # point struct to it. 50 | sub new { 51 | my $class = shift; 52 | my $self = bless {}, $class; 53 | 54 | cblock { 55 | point * to_attach = new_point(); 56 | xs_object_magic_attach_struct(aTHX_ SvRV($self), to_attach); 57 | } 58 | 59 | return $self; 60 | } 61 | 62 | # Perl-side accessor for setting the point's coordinate. 63 | csub set { 64 | dXSARGS; 65 | if (items != 3) croak("set method expects both x and y values"); 66 | point * data = data_from_SV(ST(0)); 67 | data->x = SvNV(ST(1)); 68 | data->y = SvNV(ST(2)); 69 | } 70 | 71 | # Different versions of Perl-side methods for computing the distance. 72 | 73 | # csub, i.e. pure C 74 | csub distance_1 { 75 | dXSARGS; 76 | if (items != 1) croak("distance method does not take any arguments"); 77 | point * data = data_from_SV(ST(0)); 78 | XSprePUSH; 79 | mXPUSHn(sqrt(data->x*data->x + data->y*data->y)); 80 | XSRETURN(1); 81 | } 82 | # Perl-side with type 83 | sub distance_2 { 84 | my mgpoint $self = shift; 85 | my double $to_return = 0; 86 | cblock { 87 | $to_return = sqrt($self->x*$self->x + $self->y*$self->y); 88 | } 89 | return $to_return; 90 | } 91 | # Perl-side without type 92 | sub distance_3 { 93 | my $self = shift; 94 | my $to_return; 95 | cblock { 96 | point * data = data_from_SV($self); 97 | sv_setnv($to_return, sqrt(data->x*data->x + data->y*data->y)); 98 | } 99 | return $to_return; 100 | } 101 | 102 | # Perl-side accessor/method with no counterpart in C 103 | # (illustrating that this really is a hashref-backed object). 104 | sub name { 105 | my $self = shift; 106 | return $self->{name} || 'no-name' if @_ == 0; 107 | $self->{name} = $_[0]; 108 | } 109 | 110 | # Destructor should clean up the allocated struct memory. 111 | csub DESTROY { 112 | dXSARGS; 113 | Safefree(data_from_SV(ST(0))); 114 | } 115 | } 116 | 117 | 1; 118 | -------------------------------------------------------------------------------- /t/50-sigiled-vars.t: -------------------------------------------------------------------------------- 1 | # Ensures that sigiled variables are correctly interpolated into the 2 | # compiling context. 3 | use strict; 4 | use warnings; 5 | use Test::More; 6 | 7 | # Load cblocks; PerlAPI gets loaded implicitly 8 | use C::Blocks; 9 | 10 | # lexical scalars are properly interpreted 11 | eval q{ 12 | my $lexical = 5; 13 | 14 | cblock { 15 | sv_setiv($lexical, 15); 16 | } 17 | is($lexical, 15, 'Sigil substitution'); 18 | 19 | cblock { 20 | sv_setpv($lexical, "fun times"); 21 | } 22 | is($lexical, 'fun times', 'More sigil substitution'); 23 | } or do { 24 | fail('Unexpected croak during sigil substitution'); 25 | diag($@); 26 | }; 27 | 28 | # sigils need not be carefully wrapped 29 | eval q{ 30 | my $shuttle; 31 | cblock { 32 | sv_setpv($shuttle, "$money"); 33 | } 34 | BEGIN{ pass 'Sigils need not be carefully wrapped' } 35 | is($shuttle, '$money', 'Successfully set string with dollar sign in it'); 36 | 1; 37 | } or do { 38 | fail 'Sigils need not be carefully wrapped'; 39 | diag($@); 40 | }; 41 | 42 | # C variable names can be identical to Perl variable names 43 | eval q{ 44 | my $N; 45 | cblock { 46 | int N = 12; 47 | sv_setiv($N, N); 48 | } 49 | is($N, 12, 'C variable names can be identical to Perl variable names') 50 | } or do { 51 | fail 'C variable names can be identical to Perl variable names'; 52 | diag($@); 53 | }; 54 | 55 | # lexical arrays are properly interpreted 56 | eval q{ 57 | my @array = (1, 3, 5); 58 | 59 | cblock { 60 | /* Append another element to the array */ 61 | av_push(@array, newSViv(7)); 62 | } 63 | is(0+@array, 4, 'Array was appended to') and 64 | is($array[-1], 7, 'Correct value was placed onto the array'); 65 | } or do { 66 | fail('Lexical arrays are properly interpreted'); 67 | diag($@); 68 | }; 69 | 70 | # lexical hashes are properly interpreted 71 | eval q{ 72 | my %hash = (one => 1, two => 2); 73 | 74 | cblock { 75 | /* delete the "second" entry */ 76 | hv_delete(%hash, "two", 3, G_DISCARD); 77 | } 78 | ok((not exists $hash{two}), "Hash member was removed"); 79 | } or do { 80 | fail('Lexical hashes are properly interpreted'); 81 | diag($@); 82 | }; 83 | 84 | eval q{ 85 | my $lexical = 5; 86 | 87 | cblock { 88 | sv_setpvf($lexical, "Integer is %d", 8); 89 | } 90 | is($lexical, 'Integer is 8', 'printf-style stuff usually works'); 91 | 92 | cblock { 93 | /* Throw off the parser with this double-quote: " */ 94 | sv_setpvf($lexical, "Integer is %d", 10); 95 | } 96 | is($lexical, 'Integer is 10', 'Errant double-quotes do not mess things up'); 97 | 1; 98 | } or do { 99 | fail('Proper double-quote and sigil interactions failed to compile'); 100 | diag($@); 101 | }; 102 | 103 | eval q{ 104 | $Some::Package::Variable = 5; 105 | 106 | cblock { 107 | sv_setiv($Some::Package::Variable, 8); 108 | } 109 | is($Some::Package::Variable, 8, 'Package variables are properly resolved'); 110 | 1; 111 | } or do { 112 | fail('Package variable name resolution failed to compile'); 113 | diag($@); 114 | }; 115 | 116 | 117 | TODO: { 118 | our $test_name = '"our $bar" gets detected as a package var'; 119 | local $TODO = "pad_find_my returns a pad slot for package vars declared with our() (it's an alias of sorts)"; 120 | unless(eval qq[ 121 | use C::Blocks::Types qw(double); 122 | our double \$bar = 12; 123 | cblock { 124 | \$bar = 13; 125 | } 126 | is(\$bar, 13, '$::test_name'); 127 | 1; 128 | ]) 129 | { 130 | # can only happen if the eval failed to compile: 131 | fail("$test_name failed to compile"); 132 | diag($@); 133 | } 134 | } 135 | 136 | done_testing; 137 | -------------------------------------------------------------------------------- /bench/rng/rng2.pl: -------------------------------------------------------------------------------- 1 | # Run with perl rng/rng.pl | tee rng/rng.txt 2 | # plot with perl plot-bench.pl rng/rng.txt 3 | use strict; 4 | use warnings; 5 | 6 | # Speed tabulations: 7 | # sfssssssssssssssssffssssssssfsfsfs 8 | 9 | use File::Path qw(remove_tree); 10 | END { 11 | # Keep things from getting messy 12 | remove_tree('_Inline'); 13 | } 14 | 15 | BEGIN { print "Compiling...\n" } 16 | print "Here we go!\n"; 17 | use C::Blocks; 18 | use Inline 'C'; 19 | use C::Blocks::Types qw(uint); 20 | use Time::HiRes qw(time); 21 | 22 | my uint $N; 23 | my $a = 698769069; 24 | my ($x, $y, $z, $c) = (123456789, 362436000, 521288629, 7654321); 25 | my $reps = 10; 26 | for my $log_n (1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 5.5) { 27 | $N = int(10**$log_n); 28 | print "--- For N = $N ---\n"; 29 | 30 | my ($cblocks_result, $inline_result, $perl_result, $start); 31 | my ($cblocks_duration, $inline_duration, $perl_duration) = (0, 0, 0); 32 | for (1 .. $reps) { 33 | # Time a single C::Blocks call 34 | my $start = time; 35 | $cblocks_result = c_blocks_rng(); 36 | $cblocks_duration += time() - $start; 37 | # Inline::C 38 | $start = time; 39 | $inline_result = Inline_rng(); 40 | $inline_duration += time() - $start; 41 | # Pure Perl 42 | $start = time; 43 | $perl_result = Perl_rng(); 44 | $perl_duration += time() - $start; 45 | # Check for consistency 46 | if ($cblocks_result != $inline_result 47 | and $perl_result != $inline_result 48 | and $cblocks_result != $perl_result) 49 | { 50 | print "No agreement! C::Blocks gave $cblocks_result, Inline gave $inline_result, Perl gave $perl_result\n"; 51 | } 52 | elsif ($cblocks_result != $inline_result and $cblocks_result != $perl_result) { 53 | print "C::Blocks result ($cblocks_result) disagrees with Perl and Inline ($inline_result)\n"; 54 | } 55 | elsif ($cblocks_result != $inline_result) { 56 | print "Inline result ($inline_result) disagrees with Perl and C::Blocks ($perl_result)\n"; 57 | } 58 | } 59 | 60 | print "CBlocks: $cblocks_duration wallclock seconds\n"; 61 | print " Inline: $inline_duration wallclock seconds\n"; 62 | print " Perl: $perl_duration wallclock seconds\n"; 63 | } 64 | 65 | 66 | sub Perl_rng { 67 | my $rand; 68 | for (1 .. $N) { 69 | my $t; 70 | $x = 69069*$x+12345; 71 | $y ^= ($y<<13); $y ^= ($y>>17); $y ^= ($y<<5); 72 | $t = $a*$z+$c; $c = ($t>>32); 73 | $z = $t; 74 | $rand = $x+$y+$z; 75 | } 76 | return $rand; 77 | } 78 | 79 | { 80 | my uint ($x, $y, $z, $c); 81 | sub c_blocks_rng { 82 | ($x, $y, $z, $c) = (123456789, 362436000, 521288629, 7654321) 83 | if not defined $x; 84 | my uint $to_return = 0; 85 | cblock { 86 | for (int i = 0; i < $N; i++) { 87 | unsigned long long t, a = 698769069ULL; 88 | $x = 69069*$x+12345; 89 | $y ^= ($y<<13); $y ^= ($y>>17); $y ^= ($y<<5); 90 | t = a*$z+$c; $c = (t>>32); 91 | $to_return = $x+$y+($z=t); 92 | } 93 | } 94 | return $to_return; 95 | } 96 | } 97 | 98 | sub Inline_rng { 99 | inl_rng($N); 100 | } 101 | 102 | __END__ 103 | 104 | __C__ 105 | 106 | /* Note: y must never be set to zero; 107 | * z and c must not be simultaneously zero */ 108 | static unsigned int x = 123456789,y = 362436000, 109 | z = 521288629,c = 7654321; /* State variables */ 110 | 111 | unsigned int inline_KISS() { 112 | unsigned long long t, a = 698769069ULL; 113 | x = 69069*x+12345; 114 | y ^= (y<<13); y ^= (y>>17); y ^= (y<<5); 115 | t = a*z+c; c = (t>>32); 116 | return x+y+(z=t); 117 | } 118 | 119 | unsigned int inl_rng(unsigned int N) { 120 | int i; 121 | unsigned int to_return; 122 | for (i = 0; i < N; i++) to_return = inline_KISS(); 123 | return to_return; 124 | } 125 | -------------------------------------------------------------------------------- /examples/primatest.pl: -------------------------------------------------------------------------------- 1 | =head1 NAME 2 | 3 | primatest.pl - testing how C::Blocks handles the C interface to the Prima GUI toolkit 4 | 5 | =cut 6 | 7 | use strict; 8 | use warnings; 9 | use blib; 10 | use Prima qw(Application); 11 | use Prima::Config; 12 | use ExtUtils::Embed; 13 | 14 | use C::Blocks; 15 | 16 | BEGIN { 17 | # Utilize ExtUtils::Embed to get some build info 18 | $C::Blocks::compiler_options = join(' ', $Prima::Config::Config{inc}, ccopts); 19 | 20 | # tcc doesn't know how to use quotes in -I paths; remove them if found. 21 | $C::Blocks::compiler_options =~ s/-I"([^"]*)"/-I$1/g if $^O =~ /MSWin/; 22 | 23 | # Set the Prima library 24 | @C::Blocks::libraries_to_link = ($Prima::Config::Config{dlname}); 25 | } 26 | 27 | clex { 28 | #include 29 | #include 30 | } 31 | 32 | my ($x, $y) = (1, 0); 33 | my ($N_x, $N_y) = (30, 30); 34 | my ($A, $B) = (20, 40); 35 | 36 | Prima::MainWindow-> new( text => 'C::Blocks', 37 | # buffer => 1, 38 | onPaint => sub { 39 | my ($self, $canvas) = @_; 40 | return $self->repaint if $self->get_paint_state != 1; 41 | $self->clear; 42 | my $rotation = atan2($y - 250, $x - 250); 43 | cblock { 44 | Point points_to_plot[200]; 45 | int x_pt, y_pt, C_N_x, C_N_y, N_points; 46 | double A_rad, B_rad; 47 | A_rad = SvNV($A); 48 | B_rad = SvNV($B); 49 | x_pt = SvIV($x); 50 | y_pt = SvIV($y); 51 | C_N_x = SvIV($N_x); 52 | C_N_y = SvIV($N_y); 53 | N_points = 200; 54 | 55 | Handle widget_handle = gimme_the_mate($self); 56 | /* Draw an ellipse tilted toward the mouse. Thanks to 57 | * http://www.uwgb.edu/dutchs/Geometry/HTMLCanvas/ObliqueEllipses5.HTM 58 | * for the formula. */ 59 | int i, j, k; 60 | double theta, theta_inc, theta_0, sin_theta_0, cos_theta_0; 61 | 62 | /* set the per-step theta increment */ 63 | theta_inc = 2 * M_PI / N_points; 64 | 65 | /* Iterate through the number of x and y ellipses to draw */ 66 | for (i = 0; i < C_N_x; i++) { 67 | //int x_pos = ... 68 | for (j = 0; j < C_N_y; j++) { 69 | theta_0 = SvNV($rotation); 70 | sin_theta_0 = sin(theta_0); 71 | cos_theta_0 = cos(theta_0); 72 | 73 | /* Build the set of points */ 74 | for (i = 0; i < N_points; i++) { 75 | theta = i*theta_inc; 76 | points_to_plot[i].x = 250 + A_rad * cos(theta)*cos_theta_0 77 | - B_rad * sin(theta)*sin_theta_0; 78 | points_to_plot[i].y = 250 + A_rad * cos(theta)*sin_theta_0 /* === syntax hilite :-( */ 79 | + B_rad * sin(theta)*cos_theta_0; 80 | } 81 | apc_gp_fill_poly (widget_handle, N_points, points_to_plot); 82 | } 83 | } 84 | } 85 | }, 86 | onMouseMove => sub { 87 | (my $self, undef, $x, $y) = @_; 88 | $self->notify('Paint'); 89 | }, 90 | ); 91 | 92 | my @points; 93 | my $pi = 2*atan2(1, 0); 94 | my $N_points = 200; 95 | 96 | Prima::MainWindow-> new( text => 'Pure Perl', 97 | onPaint => sub { 98 | my ($self, $canvas) = @_; 99 | return $self->repaint if $self->get_paint_state != 1; 100 | $self->clear; 101 | 102 | # Some pre-calculations 103 | my $rotation = atan2($y - 250, $x - 250); 104 | my $sin_theta_0 = sin($rotation); 105 | my $cos_theta_0 = cos($rotation); 106 | my $theta_inc = $pi / $N_points * 2; 107 | 108 | for my $i (0 .. $N_points - 1) { 109 | my $theta = $i * $theta_inc; 110 | $points[2*$i] = 250 + $A * cos($theta)*$cos_theta_0 111 | - $B * sin($theta)*$sin_theta_0; 112 | $points[2*$i+1] = 250 + $A * cos($theta)*$sin_theta_0 113 | + $B * sin($theta)*$cos_theta_0; 114 | 115 | } 116 | 117 | $self->fillpoly(\@points); 118 | }, 119 | onMouseMove => sub { 120 | (my $self, undef, $x, $y) = @_; 121 | $self->notify('Paint'); 122 | }, 123 | ); 124 | 125 | Prima->run; 126 | -------------------------------------------------------------------------------- /t/20-cshare.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks -noPerlAPI; 5 | 6 | # This tests the ability to create functions and struct definitions in 7 | # one package and share them with other packages. It does not rely on 8 | # libperl. 9 | 10 | # Start with a known (blank) message 11 | $C::Blocks::_msg = ''; 12 | 13 | ############################### 14 | # Basic communication package # 15 | ############################### 16 | 17 | package My::Basic::Comm; 18 | { 19 | # The functions defined in this package will allow for easy communication 20 | # for the rest of the test script. It is lexically scoped so that it does 21 | # not leak to other declarations automatically. 22 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 23 | 24 | cshare { 25 | void* get_data() { 26 | return c_blocks_get_msg(); 27 | } 28 | } 29 | cshare { 30 | void send_data(void * bytes_to_send, int N_bytes) { 31 | c_blocks_send_bytes(bytes_to_send, N_bytes); 32 | } 33 | } 34 | } 35 | 36 | ##################### 37 | # Compilation tests # 38 | ##################### 39 | 40 | package main; 41 | 42 | # Make sure things compile without trouble 43 | BEGIN { pass 'Shared block compiles without trouble' } 44 | pass('At runtime, shared block gets skipped without trouble'); 45 | 46 | ############### 47 | # Scope tests # 48 | ############### 49 | 50 | # Make sure we cannot access the functions where they're not supposed to live 51 | eval q{ 52 | cblock { void * foo = get_data(); } 53 | fail('Cannot call a cshare function outside its lexical scope without package import'); 54 | 1; 55 | } or do { 56 | like($@, qr/undeclared function/, 'Cannot call a cshare function outside its lexical scope without package import'); 57 | }; 58 | 59 | { 60 | BEGIN { My::Basic::Comm->import } 61 | cblock { void * foo = get_data(); } 62 | pass('use (or equivalent thereof) makes functions available'); 63 | } 64 | 65 | ######################### 66 | # Derived Functionality # 67 | ######################### 68 | 69 | package My::Struct::Comm; 70 | { 71 | BEGIN { My::Basic::Comm->import } 72 | 73 | } 74 | 75 | package main; 76 | 77 | done_testing; 78 | 79 | __END__ 80 | ###### Create a lexically scoped macros similar to those in test 15 ###### 81 | 82 | clex { 83 | #define get_dbl ((double*)c_blocks_get_msg())[0] 84 | #define send_dbl(to_send) c_blocks_send_bytes(&to_send, sizeof(double)) 85 | } 86 | 87 | # Generate a random integer between zero and 20, send it 88 | my $number = rand(20) % 20; 89 | $C::Blocks::_msg = pack('d', $number); 90 | 91 | my $double = $number * 2; 92 | # Double it in C 93 | cblock { 94 | double old = get_dbl; 95 | old *= 2.0; 96 | send_dbl(old); 97 | } 98 | my $result = unpack('d', $C::Blocks::_msg); 99 | is($result, $double, 'C defines from previously compiled scope work (as already tested)'); 100 | 101 | ###### Redefine the preprocessor macro in a lexically scoped way ###### 102 | 103 | { 104 | clex { 105 | #undef get_dbl 106 | #define get_dbl -125 107 | } 108 | # invoke the new definition 109 | cblock { 110 | double new_val = get_dbl; 111 | send_dbl(new_val); 112 | } 113 | my $result = unpack('d', $C::Blocks::_msg); 114 | is($result, -125, 'Lexically scoped redefines work'); 115 | } 116 | 117 | ###### Outside the lexical scope, test for the previous preprocessor macro ###### 118 | 119 | # Generate a random integer between zero and 20, send it 120 | $number = rand(20) % 20; 121 | $C::Blocks::_msg = pack('d', $number); 122 | 123 | $double = $number * 2; 124 | # Double it in C 125 | cblock { 126 | double old = get_dbl; 127 | old *= 2.0; 128 | send_dbl(old); 129 | } 130 | $result = unpack('d', $C::Blocks::_msg); 131 | is($result, $double, 'Lexically scoped redefines do not leak'); 132 | 133 | done_testing; 134 | -------------------------------------------------------------------------------- /bench/rng/rng.pl: -------------------------------------------------------------------------------- 1 | # Run with perl rng/rng.pl | tee rng/rng.txt 2 | # plot with perl plot-bench.pl rng/rng.txt 3 | use strict; 4 | use warnings; 5 | 6 | # Speed tabulations: 7 | # sfssssssssssssssssffssssssssfsfsfs 8 | 9 | use File::Path qw(remove_tree); 10 | END { 11 | # Keep things from getting messy 12 | remove_tree('_Inline'); 13 | } 14 | 15 | BEGIN { print "Compiling...\n" } 16 | print "Here we go!\n"; 17 | use C::Blocks; 18 | use Inline 'C'; 19 | use C::Blocks::Types qw(uint); 20 | use Time::HiRes qw(time); 21 | 22 | my uint $N; 23 | my $a = 698769069; 24 | my ($x, $y, $z, $c) = (123456789, 362436000, 521288629, 7654321); 25 | my $reps = 10; 26 | for my $log_n (1, 1.5, 2, 2.5, 3, 3.5, 4, 4.5, 5, 5.5) { 27 | $N = int(10**$log_n); 28 | print "--- For N = $N ---\n"; 29 | 30 | my ($cblocks_result, $inline_result, $perl_result, $start); 31 | my ($cblocks_duration, $inline_duration, $perl_duration) = (0, 0, 0); 32 | for (1 .. $reps) { 33 | # Time a single C::Blocks call 34 | my $start = time; 35 | $cblocks_result = c_blocks_rng(); 36 | $cblocks_duration += time() - $start; 37 | # Inline::C 38 | $start = time; 39 | $inline_result = Inline_rng(); 40 | $inline_duration += time() - $start; 41 | # Pure Perl 42 | $start = time; 43 | $perl_result = Perl_rng(); 44 | $perl_duration += time() - $start; 45 | # Check for consistency 46 | if ($cblocks_result != $inline_result 47 | and $perl_result != $inline_result 48 | and $cblocks_result != $perl_result) 49 | { 50 | print "No agreement! C::Blocks gave $cblocks_result, Inline gave $inline_result, Perl gave $perl_result\n"; 51 | } 52 | elsif ($cblocks_result != $inline_result and $cblocks_result != $perl_result) { 53 | print "C::Blocks result ($cblocks_result) disagrees with Perl and Inline ($inline_result)\n"; 54 | } 55 | elsif ($cblocks_result != $inline_result) { 56 | print "Inline result ($inline_result) disagrees with Perl and C::Blocks ($perl_result)\n"; 57 | } 58 | } 59 | 60 | print "CBlocks: $cblocks_duration wallclock seconds\n"; 61 | print " Inline: $inline_duration wallclock seconds\n"; 62 | print " Perl: $perl_duration wallclock seconds\n"; 63 | } 64 | 65 | 66 | sub Perl_rng { 67 | my $rand; 68 | for (1 .. $N) { 69 | my $t; 70 | $x = 69069*$x+12345; 71 | $y ^= ($y<<13); $y ^= ($y>>17); $y ^= ($y<<5); 72 | $t = $a*$z+$c; $c = ($t>>32); 73 | $z = $t; 74 | $rand = $x+$y+$z; 75 | } 76 | return $rand; 77 | } 78 | 79 | clex { 80 | /* Note: y must never be set to zero; 81 | * z and c must not be simultaneously zero */ 82 | unsigned int x = 123456789,y = 362436000, 83 | z = 521288629,c = 7654321; /* State variables */ 84 | 85 | unsigned int KISS() { 86 | unsigned long long t, a = 698769069ULL; 87 | x = 69069*x+12345; 88 | y ^= (y<<13); y ^= (y>>17); y ^= (y<<5); 89 | t = a*z+c; c = (t>>32); 90 | return x+y+(z=t); 91 | } 92 | } 93 | 94 | sub c_blocks_rng { 95 | my uint $to_return = 0; 96 | cblock { 97 | for (int i = 0; i < $N; i++) $to_return = KISS(); 98 | } 99 | return $to_return; 100 | } 101 | 102 | sub Inline_rng { 103 | inl_rng($N); 104 | } 105 | 106 | __END__ 107 | 108 | __C__ 109 | 110 | /* Note: y must never be set to zero; 111 | * z and c must not be simultaneously zero */ 112 | static unsigned int x = 123456789,y = 362436000, 113 | z = 521288629,c = 7654321; /* State variables */ 114 | 115 | unsigned int inline_KISS() { 116 | unsigned long long t, a = 698769069ULL; 117 | x = 69069*x+12345; 118 | y ^= (y<<13); y ^= (y>>17); y ^= (y<<5); 119 | t = a*z+c; c = (t>>32); 120 | return x+y+(z=t); 121 | } 122 | 123 | unsigned int inl_rng(unsigned int N) { 124 | int i; 125 | unsigned int to_return; 126 | for (i = 0; i < N; i++) to_return = inline_KISS(); 127 | return to_return; 128 | } 129 | -------------------------------------------------------------------------------- /t/10-clex.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks -noPerlAPI; 5 | 6 | # Tell C::Blocks to add rudimentary communications functions for testing 7 | BEGIN { $C::Blocks::_add_msg_functions = 1 } 8 | 9 | # Start with a known (blank) message 10 | $C::Blocks::_msg = ''; 11 | 12 | # Build a few functions that call the messaging interface 13 | clex { 14 | void snd_msg(char * msg) { 15 | c_blocks_send_msg(msg); 16 | } 17 | void Send::Hello () { 18 | c_blocks_send_msg("Hello!"); 19 | } 20 | void send_second() { 21 | c_blocks_send_msg("Second"); 22 | } 23 | int some_data; 24 | } 25 | 26 | BEGIN { pass 'Lexical block compiles without trouble' } 27 | pass('At runtime, lexical block gets skipped without trouble'); 28 | 29 | # Don't need the basic communication function any more; we'll be accessing 30 | # that functionality through the newly written functions instead. 31 | #BEGIN { $C::Blocks::_add_msg_functions = 0 } 32 | 33 | #### Invoke hello for the first time #### 34 | cblock { 35 | Send::Hello(); 36 | } 37 | BEGIN { pass 'cblock after lexical block compiles without trouble' } 38 | pass 'cblock is called and run without trouble'; 39 | is($C::Blocks::_msg, 'Hello!', 'Function call in cblock has desired side-effect'); 40 | 41 | #### Invoke second for the first time #### 42 | cblock { 43 | send_second(); 44 | } 45 | BEGIN { pass 'second cblock after lexical block compiles without trouble' } 46 | pass 'second cblock is called and run without trouble'; 47 | is($C::Blocks::_msg, 'Second', 'Function call in second cblock has desired side-effect'); 48 | 49 | #### Invoke snd_msg three times in a row #### 50 | cblock { 51 | snd_msg("foo"); 52 | } 53 | BEGIN { pass 'Nth cblock after lexical block compiles without trouble' } 54 | pass 'Nth cblock is called and run without trouble'; 55 | is($C::Blocks::_msg, 'foo', 'sendign foo works'); 56 | cblock { 57 | snd_msg("bar"); 58 | } 59 | BEGIN { pass 'Nth cblock after lexical block compiles without trouble' } 60 | pass 'Nth cblock is called and run without trouble'; 61 | is($C::Blocks::_msg, 'bar', 'sending bar works'); 62 | cblock { 63 | snd_msg("baz"); 64 | } 65 | BEGIN { pass 'Nth cblock after lexical block compiles without trouble' } 66 | pass 'Nth cblock is called and run without trouble'; 67 | is($C::Blocks::_msg, 'baz', 'sending baz works'); 68 | 69 | #### Invoke hello for the second time #### 70 | cblock { 71 | Send::Hello(); 72 | } 73 | BEGIN { pass 'Nth cblock after lexical block compiles without trouble' } 74 | pass 'Nth cblock is called and run without trouble'; 75 | is($C::Blocks::_msg, 'Hello!', 'Function call in third cblock has desired side-effect'); 76 | 77 | $C::Blocks::_msg = ''; 78 | eval q{ 79 | cblock { 80 | // call hello again 81 | Send::Hello(); 82 | } 83 | BEGIN { pass "string-eval'd code with lexical block compiles without trouble" } 84 | pass "string-eval'd code with lexical block runs without trouble"; 85 | is($C::Blocks::_msg, 'Hello!', "string-eval'd code has desired side-effect"); 86 | 1; 87 | } or do { 88 | fail "string-eval'd code has access to lexically scoped functions"; 89 | diag $@; 90 | }; 91 | 92 | #### Twiddle with some_data #### 93 | cblock { some_data = 5; } 94 | BEGIN { pass 'cblock with global variable modification compiles without trouble' } 95 | pass 'cblock with global variable modification is called and run without trouble'; 96 | 97 | # Pack a random integer and set some_data to it 98 | my $rand_int = int(rand(10_000)); 99 | $C::Blocks::_msg = pack('i', $rand_int); 100 | cblock { some_data = *((int*)c_blocks_get_msg()); } 101 | BEGIN { pass 'cblock with global variable modification compiles without trouble' } 102 | pass 'cblock with global variable modification is called and run without trouble'; 103 | 104 | # Double and then unpack the random integer 105 | cblock { 106 | some_data *= 2; 107 | c_blocks_send_bytes(&some_data, sizeof(int)); 108 | } 109 | BEGIN { pass 'second cblock with global variable modification compiles without trouble' } 110 | pass 'second cblock with global variable modification is called and run without trouble'; 111 | 112 | my $modified_rand = unpack('i', $C::Blocks::_msg); 113 | is($modified_rand, $rand_int * 2, 'Shared integer data between cblocks using global int'); 114 | 115 | done_testing; 116 | -------------------------------------------------------------------------------- /t/81-Object-Magic.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | ######################################################################## 5 | package mgpoint; 6 | ######################################################################## 7 | # The package using Object::Magic, which we will exercise shortly 8 | use C::Blocks; 9 | use C::Blocks::Object::Magic; 10 | use C::Blocks::Types qw(double); 11 | 12 | sub c_blocks_init_cleanup { 13 | my ($package, $C_name, $sigil_type, $pad_offset) = @_; 14 | 15 | my $init_code = "$sigil_type * _hidden_$C_name = ($sigil_type*)PAD_SV($pad_offset); " 16 | . "point * $C_name = data_from_SV(_hidden_$C_name); "; 17 | 18 | return $init_code; 19 | } 20 | 21 | cshare { 22 | /* Define a simple x/y data pint using a struct */ 23 | typedef struct point { 24 | double x; 25 | double y; /* ;;; syntax hilite :-( */ 26 | } point; 27 | 28 | /* C-side constructor allocates memory and initializes 29 | * the data to point to the origin. Note the macro 30 | * wrapper, which makes working with threaded perls a 31 | * little bit cleaner. */ 32 | point * new_point(pTHX) { 33 | #define new_point() new_point(aTHX) 34 | point * to_return; 35 | Newx(to_return, 1, point); 36 | to_return->x = 0; 37 | to_return->y = 0; 38 | return to_return; 39 | } 40 | 41 | /* C-side function that retrieves and properly casts 42 | * the struct from the Perl-side SV. */ 43 | point * data_from_SV(pTHX_ SV * perl_side) { 44 | #define data_from_SV(perl_side) data_from_SV(aTHX_ perl_side) 45 | return xs_object_magic_get_struct_rv(aTHX_ perl_side); 46 | } 47 | } 48 | 49 | # Perl-side constructor. Build an empty hash and attach the 50 | # point struct to it. 51 | sub new { 52 | my $class = shift; 53 | my $self = bless {}, $class; 54 | 55 | cblock { 56 | point * to_attach = new_point(); 57 | xs_object_magic_attach_struct(aTHX_ SvRV($self), to_attach); 58 | } 59 | 60 | return $self; 61 | } 62 | 63 | # Perl-side accessor for setting the point's coordinate. 64 | csub set { 65 | dXSARGS; 66 | if (items != 3) croak("set method expects both x and y values"); 67 | point * data = data_from_SV(ST(0)); 68 | data->x = SvNV(ST(1)); 69 | data->y = SvNV(ST(2)); 70 | } 71 | 72 | # Different versions of Perl-side methods for computing the distance. 73 | 74 | # csub, i.e. pure C 75 | csub distance_1 { 76 | dXSARGS; 77 | if (items != 1) croak("distance method does not take any arguments"); 78 | point * data = data_from_SV(ST(0)); 79 | XSprePUSH; 80 | mXPUSHn(sqrt(data->x*data->x + data->y*data->y)); 81 | XSRETURN(1); 82 | } 83 | # Perl-side with type 84 | sub distance_2 { 85 | my mgpoint $self = shift; 86 | my double $to_return = 0; 87 | cblock { 88 | $to_return = sqrt($self->x*$self->x + $self->y*$self->y); 89 | } 90 | return $to_return; 91 | } 92 | # Perl-side without type 93 | sub distance_3 { 94 | my $self = shift; 95 | my $to_return; 96 | cblock { 97 | point * data = data_from_SV($self); 98 | sv_setnv($to_return, sqrt(data->x*data->x + data->y*data->y)); 99 | } 100 | return $to_return; 101 | } 102 | 103 | # Perl-side accessor/method with no counterpart in C 104 | # (illustrating that this really is a hashref-backed object). 105 | sub name { 106 | my $self = shift; 107 | return $self->{name} || 'no-name' if @_ == 0; 108 | $self->{name} = $_[0]; 109 | } 110 | 111 | # Destructor should clean up the allocated struct memory. 112 | csub DESTROY { 113 | dXSARGS; 114 | Safefree(data_from_SV(ST(0))); 115 | } 116 | 117 | ######################################################################## 118 | package main; 119 | ######################################################################## 120 | # Test code 121 | 122 | use Test::More; 123 | 124 | # Perl-side constructor and methods 125 | my $thing = mgpoint->new; 126 | $thing->set(3, 4); 127 | is($thing->distance_1, 5, 'First distance method returns correct distance'); 128 | is($thing->name, 'no-name', 'Default (Perl-side) name works'); 129 | 130 | $thing->name('Random Point'); 131 | is($thing->name, 'Random Point', 'Changing name works'); 132 | 133 | # Access data from C-side... 134 | cblock { 135 | point * thing = data_from_SV($thing); 136 | thing->x = 6; 137 | thing->y = 8; 138 | } 139 | is($thing->distance_2, 10, 'C-side set works; second distance method returns correct distance'); 140 | 141 | # Use cisa to make data manipulation code even cleaner 142 | { 143 | # A typed alias 144 | my mgpoint $thing2 = $thing; 145 | cblock { 146 | $thing2->x = 5; 147 | $thing2->y = 12; 148 | } 149 | } 150 | is($thing->distance_3, 13, 'C-side access via typing works; third distance method returns correct distance'); 151 | 152 | done_testing; 153 | -------------------------------------------------------------------------------- /lib/C/Blocks/Filter.pm: -------------------------------------------------------------------------------- 1 | ######################################################################## 2 | package C::Blocks::Filter; 3 | ######################################################################## 4 | 5 | use strict; 6 | use warnings; 7 | our $VERSION = '0.42'; 8 | $VERSION = eval $VERSION; 9 | 10 | # Any filter will need to add itself to the list of filters. These 11 | # methods can be inherited by other filters so they can focus on the 12 | # actual filtering, and not worry about the import/unimport. 13 | sub import { 14 | # Get the name of the module that is being imported. 15 | my ($package, @filters) = @_; 16 | if (@filters == 0 or $package ne __PACKAGE__) { 17 | # add the package to the list of filters 18 | $^H{"C::Blocks/filters"} .= "$package|"; 19 | } 20 | for my $filter (@filters) { 21 | if (ref($filter)) { 22 | warn("C::Blocks does not support references as filters"); 23 | } 24 | else { 25 | $^H{"C::Blocks/filters"} .= "$filter|"; 26 | } 27 | } 28 | } 29 | 30 | sub unimport { 31 | # Get the name of the module that is being unimported. 32 | my ($package) = @_; 33 | 34 | # remove the package from the list of filters 35 | $^H{"C::Blocks/filters"} =~ s/$package\|//; 36 | } 37 | 38 | sub c_blocks_filter { 39 | print '#' x 50, 40 | "\n$_\n", 41 | '#' x 50, 42 | "\n"; 43 | } 44 | 45 | 1; 46 | 47 | __END__ 48 | 49 | =head1 NAME 50 | 51 | C::Blocks::Filter - base package for writing filters for C::Blocks 52 | 53 | =head1 SYNOPSIS 54 | 55 | If you want to see the actual code sent to the compiler, apply this 56 | module at the command-line: 57 | 58 | $ perl -MC::Blocks::Filter your-script.pl 59 | 60 | Or include it in your script: 61 | 62 | use strict; 63 | use warnings; 64 | use C::Blocks; 65 | use C::Blocks::Filter; 66 | 67 | cblock { 68 | ... /* this code will be printed */ 69 | } 70 | 71 | You can apply your own filter function: 72 | 73 | # Replace loop {} with while(1) {} 74 | sub my_filter { 75 | s/loop/while(1)/g; 76 | } 77 | use C::Blocks::Filter qw(&my_filter); 78 | 79 | cblock { 80 | loop { 81 | ... infinite loop code... 82 | ... hopefully you have a break in here somewhere 83 | } 84 | } 85 | 86 | Or you can write your own filter module: 87 | 88 | package My::Filter; 89 | use C::Blocks::Filter (); 90 | our @ISA = qw(C::Blocks::Filter); # for import/unimport 91 | 92 | # Your module must include this function: 93 | sub c_blocks_filter { 94 | s/loop/while(1)/g; 95 | } 96 | 97 | You can then use that module: 98 | 99 | use strict; 100 | use warnings; 101 | use C::Blocks; 102 | use My::Filter; 103 | 104 | cblock { 105 | int i; 106 | for (i = 0; i < 10; i++) { 107 | printf("i = %d\n", i); 108 | } 109 | loop { 110 | i++; 111 | printf("i = %d\n", i); 112 | if (i > 20) break; 113 | } 114 | } 115 | 116 | =head1 DESCRIPTION 117 | 118 | L supports lexically-scoped source filters. This module makes 119 | it easy to install source filters and write modules that serve as 120 | source filters. 121 | 122 | Source filters are called without any arguments. The C code to be 123 | filtered is simply in C<$_>, and the filter function should modify the 124 | contents of C<$_> directly. Any return value from the filter function 125 | will be ignored. 126 | 127 | =head2 Writing a one-time filter 128 | 129 | The simplest way to write a filter is to create a C that modifies 130 | the contents of C<$_> however you want. Then, you install the filter 131 | by passing the string C<&your_filter_funcion> as an argument to 132 | C. The ampersand is important! An example is 133 | given in the synopsis with C. 134 | 135 | One caveat with this approach: the sub must be I before the 136 | L block that uses it. The reason for this is that the funcion 137 | is called at code compile time. If your function is defined below the 138 | block, it will not have been compiled by the time it is needed. Unless 139 | you are using string evals, this means it needs to be defined "above" 140 | your block, or in some module that is Cd before your block. 141 | 142 | =head2 Writing a reusable filter 143 | 144 | If you want to write a filter that can be easily used in many different 145 | modules or scripts, it is easiest to create a filter module. Such a 146 | module needs to have an import method that correctly adds the package to 147 | the L list of filter packages. The specific symantics are 148 | still subject to change, so the best future-proof way to do this is to 149 | have your filter module inherit from C::Blocks::Filter. Other than that, 150 | you simply need to provide a C sub in your module. Note 151 | that your module must contain this function; it cannot inherit it from 152 | a parent module. 153 | -------------------------------------------------------------------------------- /bench/c-blocks-vs-inline.pl: -------------------------------------------------------------------------------- 1 | # This is a customized benchmark that compares prime number calculation 2 | # by C::Blocks and Inline::C. 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use File::Path qw(remove_tree); 8 | END { 9 | # Keep things from getting messy 10 | remove_tree('_Inline'); 11 | } 12 | 13 | use C::Blocks; 14 | use C::Blocks::PerlAPI; 15 | use Inline 'C'; 16 | 17 | # First, our C::Blocks function to perform the prime number calculation. 18 | # The Inline::C version is given below, a copy of this one. 19 | clex { 20 | 21 | /* Note: no need for aTHX_ because Newx and Safefree do not need 22 | * them. */ 23 | int get_Nth_prime(int n) { 24 | /* Set up variables */ 25 | int i, j, candidate, sqrt_candidate, N_found; 26 | int * prime_list; 27 | Newx(prime_list, n, int); 28 | 29 | /* Always start with 2 */ 30 | prime_list[0] = 2; 31 | candidate = 1; /* so that with increment, it'll go to 3 */ 32 | N_found = 1; 33 | 34 | /* mostly equivalent to Perl code above */ 35 | NEXT_CANDIDATE: while(N_found < n) { 36 | candidate += 2; 37 | sqrt_candidate = sqrt(candidate); 38 | for (j = 0; j < N_found; j++) { 39 | int curr_prime = prime_list[j]; 40 | if (sqrt_candidate < curr_prime) { 41 | /* if none of the primes below sqrt_candidate divide 42 | * into it, it must be prime. */ 43 | prime_list[N_found] = candidate; 44 | N_found++; 45 | goto NEXT_CANDIDATE; 46 | } 47 | 48 | /* if curr_prime divides evenly into the candidate, then 49 | * the candidate is not prime. */ 50 | if ((double)candidate / (double)curr_prime 51 | == (double)(candidate / curr_prime)) break; 52 | } 53 | /* Not a prime, move on to the next */ 54 | } 55 | 56 | /* Clean up memory and set the to-return variable based on the 57 | * last candidate */ 58 | Safefree(prime_list); 59 | return candidate; 60 | } 61 | } 62 | 63 | sub c_blocks_sub_Nth_prime { 64 | my $N = shift; 65 | my $to_return; 66 | cblock { sv_setiv($to_return, get_Nth_prime(SvIV($N))); } 67 | return $to_return; 68 | } 69 | 70 | use Time::HiRes qw(gettimeofday tv_interval); 71 | 72 | my $N_iterations = 1000; 73 | for my $log_N (1, 1.5, 2, 2.5, 3, 3.5, 4) { 74 | my $N = int(10**$log_N); 75 | print "--- N = $N ---\n"; 76 | 77 | # C::Blocks test 78 | my $C_Blocks_accum = 0; 79 | my $C_Blocks_result; 80 | for (1 .. $N_iterations) { 81 | my $t0 = [gettimeofday]; 82 | cblock { sv_setiv($C_Blocks_result, get_Nth_prime(SvIV($N))); } 83 | my $ellapsed = tv_interval ($t0); 84 | $C_Blocks_accum += $ellapsed; 85 | } 86 | my $C_Blocks_time = $C_Blocks_accum / $N_iterations; 87 | 88 | # C::Blocks sub test 89 | my $C_Blocks_sub_accum = 0; 90 | my $C_Blocks_sub_result; 91 | for (1 .. $N_iterations) { 92 | my $t0 = [gettimeofday]; 93 | $C_Blocks_sub_result = c_blocks_sub_Nth_prime($N); 94 | my $ellapsed = tv_interval ($t0); 95 | $C_Blocks_sub_accum += $ellapsed; 96 | } 97 | my $C_Blocks_sub_time = $C_Blocks_sub_accum / $N_iterations; 98 | 99 | # Inline::C test 100 | my $Inline_C_accum = 0; 101 | my $Inline_C_result; 102 | for (1 .. $N_iterations) { 103 | my $t0 = [gettimeofday]; 104 | $Inline_C_result = get_Nth_prime($N); 105 | my $ellapsed = tv_interval ($t0); 106 | $Inline_C_accum += $ellapsed; 107 | } 108 | my $Inline_C_time = $Inline_C_accum / $N_iterations; 109 | 110 | print "C::Blocks/sub took $C_Blocks_sub_accum seconds, $C_Blocks_sub_time on average\n"; 111 | print "C::Blocks took $C_Blocks_accum seconds, $C_Blocks_time on average\n"; 112 | print "Inline::C took $Inline_C_accum seconds, $Inline_C_time on average\n"; 113 | print "C::Blocks gave $C_Blocks_result; C::Blocks/sub gave $C_Blocks_sub_result; Inline::C gave $Inline_C_result\n"; 114 | } 115 | 116 | __END__ 117 | 118 | __C__ 119 | 120 | int get_Nth_prime(int n) { 121 | /* Set up variables */ 122 | int i, j, candidate, sqrt_candidate, N_found; 123 | int * prime_list; 124 | Newx(prime_list, n, int); 125 | 126 | /* Always start with 2 */ 127 | prime_list[0] = 2; 128 | candidate = 1; /* so that with increment, it'll go to 3 */ 129 | N_found = 1; 130 | 131 | /* mostly equivalent to Perl code above */ 132 | NEXT_CANDIDATE: while(N_found < n) { 133 | candidate += 2; 134 | sqrt_candidate = sqrt(candidate); 135 | for (j = 0; j < N_found; j++) { 136 | int curr_prime = prime_list[j]; 137 | if (sqrt_candidate < curr_prime) { 138 | /* if none of the primes below sqrt_candidate divide 139 | * into it, it must be prime. */ 140 | prime_list[N_found] = candidate; 141 | N_found++; 142 | goto NEXT_CANDIDATE; 143 | } 144 | 145 | /* if curr_prime divides evenly into the candidate, then 146 | * the candidate is not prime. */ 147 | if ((double)candidate / (double)curr_prime 148 | == (double)(candidate / curr_prime)) break; 149 | } 150 | /* Not a prime, move on to the next */ 151 | } 152 | 153 | /* Clean up memory and set the to-return variable based on the 154 | * last candidate */ 155 | Safefree(prime_list); 156 | return candidate; 157 | } 158 | -------------------------------------------------------------------------------- /valgrind-suppressions.supp: -------------------------------------------------------------------------------- 1 | { 2 | perl_main_memory_allocation_01 3 | Memcheck:Leak 4 | match-leak-kinds: definite 5 | fun:malloc 6 | fun:Perl_safesysmalloc 7 | fun:Perl_savepvn 8 | fun:perl_construct 9 | fun:main 10 | } 11 | 12 | { 13 | perl_main_memory_allocation_02 14 | Memcheck:Leak 15 | match-leak-kinds: definite 16 | fun:malloc 17 | fun:Perl_safesysmalloc 18 | fun:Perl_sv_grow 19 | fun:Perl_sv_setpvn 20 | fun:perl_construct 21 | fun:main 22 | } 23 | { 24 | perl_main_memory_allocation_03 25 | Memcheck:Leak 26 | match-leak-kinds: definite 27 | fun:malloc 28 | fun:Perl_safesysmalloc 29 | fun:Perl_savepv 30 | fun:Perl_new_collate 31 | fun:Perl_init_i18nl10n 32 | fun:perl_construct 33 | fun:main 34 | } 35 | { 36 | perl_main_memory_allocation_04 37 | Memcheck:Leak 38 | match-leak-kinds: definite 39 | fun:malloc 40 | fun:Perl_safesysmalloc 41 | fun:Perl_savepv 42 | fun:Perl_new_numeric 43 | fun:Perl_init_i18nl10n 44 | fun:perl_construct 45 | fun:main 46 | } 47 | { 48 | perl_main_memory_allocation_05 49 | Memcheck:Leak 50 | match-leak-kinds: definite 51 | fun:malloc 52 | fun:Perl_safesysmalloc 53 | fun:Perl_savepv 54 | fun:Perl_find_script 55 | fun:perl_parse 56 | fun:main 57 | } 58 | { 59 | perl_main_memory_allocation_06 60 | Memcheck:Leak 61 | match-leak-kinds: definite 62 | fun:malloc 63 | fun:Perl_safesysmalloc 64 | fun:Perl_init_stacks 65 | fun:perl_construct 66 | fun:main 67 | } 68 | { 69 | perl_dynaloader_startup_01 70 | Memcheck:Leak 71 | match-leak-kinds: definite 72 | fun:malloc 73 | fun:Perl_safesysmalloc 74 | fun:Perl_my_cxt_init 75 | fun:boot_DynaLoader 76 | fun:Perl_pp_entersub 77 | fun:Perl_runops_standard 78 | fun:Perl_call_sv 79 | fun:Perl_call_list 80 | fun:S_process_special_blocks 81 | fun:Perl_newATTRSUB_x 82 | fun:Perl_utilize 83 | fun:Perl_yyparse 84 | } 85 | { 86 | perl_suppression_01 87 | Memcheck:Leak 88 | match-leak-kinds: definite 89 | fun:realloc 90 | fun:Perl_safesysrealloc 91 | fun:Perl_push_scope 92 | fun:Perl_yylex 93 | fun:Perl_yyparse 94 | fun:S_doeval 95 | fun:Perl_pp_require 96 | fun:Perl_runops_standard 97 | fun:Perl_call_sv 98 | fun:Perl_call_list 99 | fun:S_process_special_blocks 100 | fun:Perl_newATTRSUB_x 101 | } 102 | { 103 | perl_suppression_02 104 | Memcheck:Leak 105 | match-leak-kinds: definite 106 | fun:malloc 107 | fun:Perl_safesysmalloc 108 | fun:Perl_bytes_from_utf8 109 | fun:Perl_pad_findmy_pvn 110 | fun:Perl_yylex 111 | fun:Perl_yyparse 112 | fun:S_doeval 113 | fun:Perl_pp_require 114 | fun:Perl_runops_standard 115 | fun:Perl_call_sv 116 | fun:Perl_call_list 117 | fun:S_process_special_blocks 118 | } 119 | { 120 | perl_suppression_03 121 | Memcheck:Leak 122 | match-leak-kinds: definite 123 | fun:calloc 124 | fun:Perl_safesyscalloc 125 | fun:Perl_gv_fetchpvn_flags 126 | fun:Perl_yylex 127 | fun:Perl_yyparse 128 | fun:S_doeval 129 | fun:Perl_pp_require 130 | fun:Perl_runops_standard 131 | fun:Perl_call_sv 132 | fun:Perl_call_list 133 | fun:S_process_special_blocks 134 | fun:Perl_newATTRSUB_x 135 | } 136 | { 137 | perl_suppression_04 138 | Memcheck:Leak 139 | match-leak-kinds: definite 140 | fun:malloc 141 | fun:Perl_safesysmalloc 142 | fun:Perl_bytes_from_utf8 143 | fun:Perl_pad_add_name_pvn 144 | fun:Perl_allocmy 145 | fun:Perl_yylex 146 | fun:Perl_yyparse 147 | fun:S_doeval 148 | fun:Perl_pp_require 149 | fun:Perl_runops_standard 150 | fun:Perl_call_sv 151 | fun:Perl_call_list 152 | } 153 | { 154 | perl_suppression_05 155 | Memcheck:Leak 156 | match-leak-kinds: definite 157 | fun:calloc 158 | fun:Perl_safesyscalloc 159 | fun:perl_construct 160 | fun:main 161 | } 162 | { 163 | perl_suppression_06 164 | Memcheck:Leak 165 | match-leak-kinds: definite 166 | fun:realloc 167 | fun:Perl_safesysrealloc 168 | fun:Perl_tmps_grow 169 | fun:Perl_sv_2mortal 170 | fun:Perl__invlist_union_maybe_complement_2nd 171 | fun:Perl__add_range_to_invlist 172 | fun:S_get_ANYOF_cp_list_for_ssc 173 | fun:S_ssc_or 174 | fun:S_study_chunk.constprop.11 175 | fun:Perl_re_op_compile 176 | fun:Perl_pmruntime 177 | fun:Perl_yyparse 178 | } 179 | { 180 | perl_suppression_07 181 | Memcheck:Leak 182 | match-leak-kinds: definite 183 | fun:realloc 184 | fun:Perl_safesysrealloc 185 | fun:Perl_savestack_grow 186 | fun:Perl_yylex 187 | fun:Perl_yyparse 188 | fun:S_doeval 189 | fun:Perl_pp_require 190 | fun:Perl_runops_standard 191 | fun:Perl_call_sv 192 | fun:Perl_call_list 193 | fun:S_process_special_blocks 194 | fun:Perl_newATTRSUB_x 195 | } 196 | { 197 | perl_suppression_08 198 | Memcheck:Leak 199 | match-leak-kinds: definite 200 | fun:malloc 201 | fun:Perl_safesysmalloc 202 | fun:Perl_new_stackinfo 203 | fun:Perl_init_stacks 204 | fun:perl_construct 205 | fun:main 206 | } 207 | { 208 | perl_suppression_09 209 | Memcheck:Leak 210 | match-leak-kinds: definite 211 | fun:malloc 212 | fun:Perl_safesysmalloc 213 | fun:Perl_reentrant_init 214 | fun:perl_construct 215 | fun:main 216 | } 217 | { 218 | perl_suppression_10 219 | Memcheck:Leak 220 | match-leak-kinds: definite 221 | fun:calloc 222 | fun:Perl_safesyscalloc 223 | fun:Perl_more_bodies 224 | fun:S_new_body 225 | fun:Perl_init_constants 226 | fun:perl_construct 227 | fun:main 228 | } 229 | -------------------------------------------------------------------------------- /examples/magic-objects/SOS04.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | =head1 NAME 5 | 6 | SOS04.pm - full-blown subclass of SOS01 7 | 8 | =head1 QUESTION 9 | 10 | Continuing from SOS03, how many lines of code are involved if add a new 11 | attribute, including implementing the Perl-side metehods in "XS"? 12 | 13 | I will keep all other aspects the same but add an attribute, and XS 14 | implementations of the Perl-methods. Let's see how that goes. 15 | 16 | =cut 17 | 18 | package SOS04; 19 | use C::Blocks; 20 | use C::Blocks::Types qw(Int); 21 | use SOS01; 22 | use SOS02; # for SV -> C-obj 23 | use C::Blocks::PerlAPI; 24 | use C::Blocks::Filter::BlockArrowMethods; 25 | our @ISA = qw(SOS01); 26 | 27 | cshare { 28 | /* vtable and object layouts */ 29 | typedef struct SOS04_t * SOS04; 30 | /* vtable struct declaration */ 31 | typedef struct SOS04::VTABLE_LAYOUT_t { 32 | SOS04 (*new)(); 33 | void (*refcount_inc)(SOS04 self); 34 | void (*refcount_dec)(SOS04 self); 35 | void (*destroy)(SOS04 self); 36 | int _class_size; 37 | HV * _class_stash; 38 | HV * (*get_HV)(pTHX_ SOS04 self); 39 | void (*attach_SV)(SOS04 self, pTHX_ SV* to_attach); 40 | // new accessors for "val", an integer 41 | int (*get_val)(SOS04 self); 42 | void (*set_val)(SOS04 self, int new_value); 43 | } SOS04::VTABLE_LAYOUT; 44 | /* object layout */ 45 | struct SOS04_t { 46 | SOS04::VTABLE_LAYOUT * methods; 47 | HV * perl_obj; 48 | int val; 49 | }; 50 | 51 | /* accessor methods new for this class */ 52 | int SOS04::get_val(SOS04 self) { 53 | entering; 54 | leaving; 55 | return self->val; 56 | } 57 | XSPROTO(from_perl::SOS04::get_val) { 58 | entering; 59 | dXSARGS; 60 | /* get the Perl self from the stack */ 61 | SV * SV_self = POPs; 62 | /* get C representation */ 63 | SOS04 c_self = SOS01::Magic::obj_ptr_from_SV_ref(aTHX_ SV_self); 64 | /* Prepare stack to receive return values. */ 65 | XSprePUSH; 66 | /* push integer onto the stack */ 67 | mXPUSHi(c_self=>get_val()); 68 | /* Indicate we're returning a single value on the stack. */ 69 | leaving; 70 | XSRETURN(1); 71 | } 72 | void SOS04::set_val(SOS04 self, int new_value) { 73 | entering; 74 | leaving; 75 | self->val = new_value; 76 | } 77 | XSPROTO(from_perl::SOS04::set_val) { 78 | entering; 79 | dXSARGS; 80 | /* get the Perl self from the stack */ 81 | SV * SV_self = ST(0); 82 | /* get the new value from the stack */ 83 | int new_val = SvIV(ST(1)); 84 | /* get C representation */ 85 | SOS04 c_self = SOS01::Magic::obj_ptr_from_SV_ref(aTHX_ SV_self); 86 | /* set the value */ 87 | c_self=>set_val(new_val); 88 | /* Indicate we're not returning anything. */ 89 | leaving; 90 | XSRETURN_EMPTY; 91 | } 92 | 93 | /* In order to initialize (most of) the vtable instance statically, 94 | * the new() method needs to be *declared* before the vtable 95 | * and *defined* afterwrd. All other methods should be defined 96 | * earleir. */ 97 | SOS04 SOS04::new(); 98 | 99 | /* We'll need a new vtable instance, but the structure is identical */ 100 | SOS04::VTABLE_LAYOUT SOS04::VTABLE_INSTANCE = { 101 | SOS04::new, 102 | (void (*)(SOS04 self))SOS01::refcount_inc, 103 | (void (*)(SOS04 self))SOS01::refcount_dec, 104 | (void (*)(SOS04 self))SOS01::destroy, 105 | sizeof(struct SOS04_t), 106 | NULL, 107 | (HV * (*)(pTHX_ SOS04 self))SOS01::get_HV, 108 | (void (*)(SOS04 self, pTHX_ SV* to_attach))SOS01::attach_SV, 109 | SOS04::get_val, 110 | SOS04::set_val 111 | }; 112 | 113 | /* create a constructor that allocates the memory */ 114 | SOS04 SOS04::new() { 115 | entering; 116 | /* just allocate memory for object */ 117 | SOS04 to_return = SOS01::alloc(SOS04); 118 | leaving; 119 | return to_return; 120 | } 121 | 122 | XSPROTO(from_perl::SOS04::new) { 123 | entering; 124 | dXSARGS; 125 | /* create the C representation of self */ 126 | SOS04 self = SOS04::new(); 127 | /* create an mortal SV ref attached to self */ 128 | SV * SV_ret = sv_newmortal(); 129 | self=>attach_SV(aTHX_ SV_ret); 130 | /* fix the refcount */ 131 | self=>refcount_dec(); 132 | /* Prepare stack to receive return values. */ 133 | XSprePUSH; 134 | /* push the SV to return onto the stack. */ 135 | XPUSHs(SV_ret); 136 | /* Indicate we're returning a single value on the stack. */ 137 | leaving; 138 | XSRETURN(1); 139 | } 140 | } 141 | 142 | cblock { 143 | _entering("SOS04 Initialization block"); 144 | /* Initialize the only dynamic element of the table. Everything else 145 | * was already assigned statically. */ 146 | SOS04::VTABLE_INSTANCE._class_stash = gv_stashpv("SOS04", GV_ADD); 147 | /* import the xsubs */ 148 | newXS("SOS04::new", from_perl::SOS04::new, __FILE__); 149 | newXS("SOS04::set_val", from_perl::SOS04::set_val, __FILE__); 150 | newXS("SOS04::get_val", from_perl::SOS04::get_val, __FILE__); 151 | _leaving("SOS04 Initialization block"); 152 | } 153 | 154 | 1; 155 | 156 | =head1 RESULTS 157 | 158 | F verifies that this works. The answer to my 159 | question is that it takes about 130 lines of code to create a subclass 160 | that adds a new C attribute to a previous class. 161 | 162 | Far and away the most verbose portions of these 130 lines are the 163 | Perl-side xsubs. It is important to remember, however, that these xsubs 164 | are "thunks" that will call the C-side method under all circumstances. 165 | If a derived class overrides a previous class with a C implementation, 166 | it can reuse this thunk. Thus, I can implement a single Perl thunk for 167 | each attribute the first time it is declared, and later classes with C 168 | implementations can copy this method into their packages. 169 | 170 | Presumably, the same kind of approach should work for C-calling-Perl 171 | thunks. 172 | 173 | =cut 174 | -------------------------------------------------------------------------------- /t/30-API-SV.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Test::More; 4 | use C::Blocks; 5 | 6 | our ($scalar, $result); 7 | 8 | clex { 9 | #define get_vars SV * scalar = get_sv("scalar", 0); SV * result = get_sv("result", 0); 10 | } 11 | 12 | # A basic test: can I use get_sv and sv_setiv? 13 | cblock { 14 | get_vars; 15 | sv_setiv(result, 1); 16 | } 17 | BEGIN { pass 'get_sv and sv_setiv compile without issue' } 18 | is($result, 1, 'Successfuly set the result package variable'); 19 | 20 | ################# test_API ################# 21 | # A testing sub so I can succinctly write the tests that follow. 22 | # This test closes over a couple of variables whose values are meant to 23 | # be shared across a number of tests. To use this function, you should: 24 | # 1) Set $final_line, a line of C code that sets the value of $result, 25 | # a package variable that is available for testing after the cblock 26 | # has run. 27 | # 2) Call test_API with the following arguments: 28 | # input-value: a Perl value that will be accessible as the SV* scalar 29 | # description: a description of the test 30 | # key/value pairs: 31 | # - intermediary_code for manipulations before $final_line 32 | # (if not specified, no code is inserted) 33 | # - expected for the expected value of $result 34 | # if not specified, we use ok($result, $description) 35 | # if specified, we use is($result, $expected, $description) 36 | # - report_compile for whether we should report a successful 37 | # compilation, usually set only for the first function call for 38 | # the API function 39 | my $final_line; 40 | sub test_API { 41 | $scalar = shift @_; 42 | my $description = shift @_; 43 | my %options = ( 44 | intermediary_code => '', 45 | @_ 46 | ); 47 | 48 | undef ($result); 49 | my $to_eval = qq{ 50 | # Hide undefined warnings 51 | my \$stderr = ''; 52 | { 53 | local *STDERR; 54 | open STDERR, '>', \\\$stderr; 55 | cblock { 56 | get_vars; 57 | $options{intermediary_code}; 58 | $final_line; 59 | } 60 | } 61 | 1; 62 | }; 63 | eval $to_eval and do { 64 | pass("Compiles without issue") if $options{report_compile}; 65 | if (exists $options{expected}) { 66 | is($result, $options{expected}, $description); 67 | } 68 | else { 69 | ok($result, $description); 70 | } 71 | 1; 72 | } or do { 73 | fail("\"$description\" compiles ok"); 74 | if ($options{report_compile}) { 75 | diag($@); 76 | diag($to_eval); 77 | } 78 | }; 79 | } 80 | 81 | subtest SvOK => sub { 82 | $final_line = 'sv_setiv(result, SvOK(scalar))'; 83 | 84 | test_API(undef, 'An undefined value is not SvOK', expected => 0, 85 | report_compile => 1); 86 | test_API(25, 'A number is SvOK'); 87 | test_API('foo', 'A string is SvOK'); 88 | test_API('', 'An empty string is SvOK'); 89 | }; 90 | 91 | subtest SvTRUE => sub { 92 | # Not SvTRUE 93 | $final_line = 'sv_setiv(result, !SvTRUE(scalar))'; 94 | test_API(undef, 'An undefined value is not SvTRUE', 95 | report_compile => 1); 96 | test_API(0, '0 is not SvTRUE'); 97 | test_API('', 'An empty string is not SvTRUE'); 98 | test_API('0', 'The string "0" is not SvTRUE'); 99 | 100 | # is SvTRUE 101 | $final_line = 'sv_setiv(result, SvTRUE(scalar))'; 102 | test_API(25, '25 is SvTRUE'); 103 | test_API(-2.5, '-2.5 is SvTRUE'); 104 | test_API('foo', 'A non-empty, non-numeric string is SvTRUE'); 105 | test_API('0 but true', 'The string "0 but true" is SvTRUE'); 106 | }; 107 | 108 | subtest SvIOK => sub { 109 | # Not SvIOK 110 | $final_line = 'sv_setiv(result, !SvIOK(scalar))'; 111 | test_API(undef, 'An undefined value is not SvIOK', 112 | report_compile => 1); 113 | test_API(-2.5, '-2.5 is not SvIOK'); 114 | test_API('foo', 'A string is not SvIOK'); 115 | 116 | # Is SvIOK 117 | $final_line = 'sv_setiv(result, SvIOK(scalar))'; 118 | test_API(25, '25 is SvIOK'); 119 | }; 120 | 121 | subtest SvNOK => sub { 122 | # Not SvNOK 123 | $final_line = 'sv_setiv(result, !SvNOK(scalar))'; 124 | test_API(undef, 'An undefined value is not SvNOK', 125 | report_compile => 1); 126 | test_API(25, '25 is not SvNOK'); 127 | test_API('foo', 'A string is not SvNOK'); 128 | 129 | # is SvNOK 130 | $final_line = 'sv_setiv(result, SvNOK(scalar))'; 131 | test_API(-2.5, '-2.5 is SvNOK'); 132 | }; 133 | 134 | subtest SvPOK => sub { 135 | # not SvPOK 136 | $final_line = 'sv_setiv(result, !SvPOK(scalar))'; 137 | test_API(undef, 'An undefined value is not SvPOK', 138 | report_compile => 1); 139 | test_API(25, '25 is not SvPOK'); 140 | test_API(-2.5, '-2.5 is not SvPOK'); 141 | 142 | # is SvPOK 143 | $final_line = 'sv_setiv(result, SvPOK(scalar))'; 144 | test_API('foo', 'A string is SvPOK'); 145 | test_API('', 'An empty string is SvPOK'); 146 | }; 147 | 148 | subtest SvIV => sub { 149 | $final_line = 'sv_setiv(result, SvIV(scalar))'; 150 | test_API(undef, 'An undefined value has SvIV of 0', expected => 0, 151 | report_compile => 1); 152 | test_API(10, "An integer's SvIV is its value", expected => 10); 153 | test_API(100.4, "A floating-point's SvIV is its value rounded", 154 | expected => 100); 155 | test_API('foo', "A string's SvIV is 0", expected => 0); 156 | 157 | $final_line = 'sv_setiv(result, 5*SvIV(scalar))'; 158 | test_API(10, "Successful integer multiplication in C code", 159 | expected => 50); 160 | }; 161 | 162 | subtest SvNV => sub { 163 | $final_line = 'sv_setnv(result, SvNV(scalar))'; 164 | test_API(undef, 'An undefined value has SvNV of 0', expected => 0, 165 | report_compile => 1); 166 | test_API(10, "An integer's SvNV is its value", expected => 10); 167 | test_API(0.5, "A floating-point's SvNV is its value", 168 | expected => 0.5); 169 | test_API('foo', "A string's SvNV is 0", expected => 0); 170 | 171 | $final_line = 'sv_setnv(result, 5*SvNV(scalar))'; 172 | test_API(10, "Successful floating-point multiplication in C code", 173 | expected => 50); 174 | }; 175 | 176 | subtest dualvar => sub { 177 | pass('to be written'); 178 | }; 179 | 180 | done_testing; 181 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Put changes under the appropriate header. Headers can include API CHANGES, 2 | DIFFERENT BEHAVIOR, BUG FIXES, DEPENDENCIES, ENHANCEMENTS, NEW FEATURES, and 3 | OTHER. Entries should be in chronological order, i.e. oldest at the top 4 | 5 | 0.43 Ddd, Mth #, 201# 6 | 7 | [API CHANGES] 8 | 9 | * The package C::Blocks::libloader contained only a single import function. 10 | That function has been renamed to C::Blocks::load_lib. 11 | 12 | * C::Blocks now includes the Perl API by default. This cleans up a fair bit 13 | of code that auto-loaded it when sigils were detected, and provides C 14 | functions that any reasonable Perl programmer would have expected. 15 | 16 | [BUG FIXES] 17 | 18 | * The hints hash manipulation now uses the correct C API, so that symbol 19 | tables from clex blocks do not get clobbered by modules using standard 20 | hints hash manipulation. 21 | 22 | [NEW FEATURES] 23 | 24 | * C::Blocks::Types::Pointers! It is now easy to declare pointers of 25 | specified types without writing a whole type class. 26 | 27 | * C::Blocks::SOS, the Simple Object System, provides one way to create a 28 | basic class heierarchy with symmetric Perl and C methods. 29 | 30 | * C::Blocks::Types::Struct streamlines creating a type for packed data; 31 | C::Blocks::Types::IsaStruct makes it easy to create a sharable package 32 | with this sort of type information. 33 | 34 | 0.42 Fri, Dec 9, 2016 35 | 36 | [NEW FEATURES] 37 | 38 | * It is now possible to indicate filter functions by name, rather than 39 | by package. 40 | 41 | [BUG FIXES] 42 | 43 | * Build.PL now removes names.txt and share/perl.h.cache. This is not 44 | important for basic installation, but shows up when the distribution 45 | is repeatedly compiled in the same directory against different 46 | versions of Perl. 47 | 48 | * Executable code is now relocated to a location in memory that is 49 | properly aligned with modern CPU page alignments. This is hard-coded 50 | at the moment at 4096 bytes. Without this alignment, code compiled in 51 | clex blocks would sometimes perform dismally. This showed up most 52 | obviously in the rng and random-access benchmarks that were recently 53 | added to the benchmarks folder. Before this fix, the C::Blocks rng 54 | implementation would often perform as slowly as the Perl one. 55 | 56 | 0.41 Mon, Nov 28, 2016 57 | 58 | [API CHANGES] 59 | 60 | * cisa has been removed! C::Blocks now uses the built-in type 61 | annotation facilities of Perl. Short type names are provided by 62 | C::Blocks::Types. 63 | 64 | [DEPENDENCIES] 65 | 66 | * Bumped Alien::TinyCCx dependency to v0.12, which fixes struct 67 | alignment issues and enum handling. 68 | 69 | [ENHANCEMENTS] 70 | 71 | * Perl package globals are now properly resolved. If you make a 72 | reference some $Some::Package::Scalar in your C code, it'll properly 73 | retrieve the SV named $Scalar from the package Some::Package. 74 | 75 | [NEW FEATURES] 76 | 77 | * New module C::Blocks::Types provides short type names 78 | 79 | * Double-colons are now processed by the code extractor and converted 80 | into double-underscores. So if you use Some::Thing in your C code 81 | block, it'll be immediately converted to Some__Thing. 82 | 83 | * Source filters! C::Blocks source filters are given the contents of 84 | the C code, start to finish, to manipulate. While it would be nicer 85 | to hook directly into the parser, this provides 99% of the desired 86 | functionality with 1% of the required effort of a parser hook. 87 | 88 | 0.40 Fri, Aug 12, 2016 89 | 90 | [DEPENDENCIES] 91 | 92 | * Bumped Alien::TinyCCx dependency to v0.11, which should properly 93 | support 64-bit Macs. 94 | 95 | [BUG FIXES] 96 | 97 | * Revised the perl.h symbol table caching in PerlAPI.xs.PL to use the 98 | tcc -run option instead of producing a shared object file. It does 99 | not need to produce anything---it just needs to cache the symbol 100 | table---but in order to get the default tcc to do that, I need to 101 | give it a compile target. Shared objects gave trouble on Macs, but 102 | tcc -run does not. An alternative fix would be to change tcc itself 103 | to add a "no output" target, or some such. In the meantime, this 104 | seems to solve the problem. 105 | 106 | 0.05 Thu, June 2, 2016 107 | 108 | [DIFFERENT BEHAVIOR] 109 | 110 | * When a C::Blocks package has one or more cshare blocks, C::Blocks 111 | used to add C::Blocks::libloader to the package's @ISA list. Now it 112 | directly injects the import method from C::Blocks::libloader into 113 | the current package, or warns if the package already has an import 114 | glob entry in its stash. This makes it possible to use cshare in a 115 | class defined using Moo (and probably many other OO frameworks). 116 | 117 | [DEPENDENCIES] 118 | 119 | * The build process now depends upon Test::Warn, which is used (not 120 | surprisingly) to test warning messages, and the lexical control 121 | thereof. 122 | 123 | * Bumped Alien::TinyCCx dependency to v0.10, which should properly 124 | support Macs. 125 | 126 | [NEW FEATURES] 127 | 128 | * C::Blocks provides lexically-scoped warnings categories of 129 | C::Blocks::import, C::Blocks::compiler, and C::Blocks::linker. 130 | 131 | 0.04 Tue, May 3, 2016 132 | 133 | [API CHANGES] 134 | 135 | * Shared libraries are now indicated with the package array 136 | @C::Blocks::libraries_to_link rather than the package scalar 137 | $C::Blocks::library_to_link. 138 | 139 | [DEPENDENCIES] 140 | 141 | * Bumped Alien::TinyCCx dependency to v0.08. 142 | 143 | [BUG FIXES] 144 | 145 | * csub works! 146 | 147 | [ENHANCEMENTS] 148 | 149 | * Can now link multiple shared libraries to a single block, though 150 | the functionality is not yet tested. 151 | 152 | * Using sigiled variables automatically loads the PerlAPI symtab. 153 | 154 | [NEW FEATURES] 155 | 156 | * Added interpolation blocks! It is now possible to use Perl to 157 | produce C code. They're kinda like fancy C macros, sorta. 158 | 159 | * Added cisa, providing a system akin to typemaps. 160 | 161 | * Added C::Blocks::Object::Magic, a port of XS::Object::Magic. This 162 | makes it much easier to safely attach C structs to Perl variables. 163 | 164 | [OTHER] 165 | 166 | * The use of preprocessor branching in Blocks.xs has been cleaned 167 | up a bit, which will hopefully make the distribution more robust. 168 | 169 | 0.03 Fri, Dec 4, 2015 170 | 171 | [DEPENDENCIES] 172 | 173 | * Added explicit dependency on ExtUtils::ParseXS v3.0. With prior 174 | versions, if you had multiple .xs files, the boot sections would 175 | collide in very, very strange ways. The default EU::PXS for v5.14 176 | (on perlbrew at least) is old, so this ensures correctness. 177 | 178 | [BUG FIXES] 179 | 180 | * Revised symbol detection and building logic for Linux systems 181 | 182 | * Scrubbed various command-line preprocessor defines which sometimes 183 | caused trouble on Debian systems. Similar corrections will surely be 184 | needed for other flavors of linux. 185 | 186 | 0.02 Thu, Aug 6, 2015 187 | 188 | [ENHANCEMENTS] 189 | 190 | * Sigil variable incorporation works for much older Perls 191 | 192 | * Can now incorporate sigiled variables with @ and % sigils 193 | 194 | * Gentle name mangling means C variables can have the same name as 195 | Perl variables 196 | 197 | * Much more robust handling of sigil characters and braces in quoted 198 | strings, as well as braces in comments 199 | 200 | 0.01 Mon, Aug 3, 2015 201 | 202 | Initial release! 203 | -------------------------------------------------------------------------------- /lib/C/Blocks/Types.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | # c_blocks_unpack_SV(SV => C_name, $cname_already_declared) 5 | # c_blocks_pack_SV(name => SV, $SV_already_declared) 6 | # c_blocks_data_type 7 | 8 | package C::Blocks::Types; 9 | our $VERSION = '0.42'; 10 | $VERSION = eval $VERSION; 11 | 12 | # XXXXXXXX use Sub::Exporter for greater granularity and control??? 13 | 14 | # The purpose of this package is to provide short type names that are 15 | # associated with the lengthy package names: 16 | use constant { 17 | # floating point 18 | NV => 'C::Blocks::Type::NV', 19 | double => 'C::Blocks::Type::double', 20 | float => 'C::Blocks::Type::float', 21 | # basic integer types 22 | IV => 'C::Blocks::Type::IV', 23 | short => 'C::Blocks::Type::short', 24 | Int => 'C::Blocks::Type::int', 25 | long => 'C::Blocks::Type::long', 26 | UV => 'C::Blocks::Type::UV', 27 | uint => 'C::Blocks::Type::uint', 28 | ushort => 'C::Blocks::Type::ushort', 29 | ulong => 'C::Blocks::Type::ulong', 30 | # array types 31 | double_array => 'C::Blocks::Type::double_array', 32 | float_array => 'C::Blocks::Type::float_array', 33 | int_array => 'C::Blocks::Type::int_array', 34 | char_array => 'C::Blocks::Type::char_array', 35 | }; 36 | 37 | use Exporter qw(import); 38 | our @EXPORT_OK = qw(NV double float IV short Int long UV uint 39 | double_array float_array int_array char_array); 40 | our %EXPORT_TAGS = ( 41 | basic => [qw(short Int long ushort uint ulong float double)], 42 | perl_num => [qw(NV IV UV)], 43 | all => [@EXPORT_OK], 44 | ); 45 | 46 | ######################################################################## 47 | package C::Blocks::PerlAPI::Type; 48 | ######################################################################## 49 | 50 | sub c_blocks_init_cleanup { 51 | my ($package, $C_name, $sigil_type, $pad_offset) = @_; 52 | my $data_type = $package->c_blocks_data_type; 53 | my $getter = $package->getter; 54 | my $setter = $package->setter; 55 | 56 | my $init_code = "$sigil_type * SV_$C_name = ($sigil_type*)PAD_SV($pad_offset); " 57 | . "$data_type $C_name = $getter(SV_$C_name); "; 58 | my $cleanup_code = "$setter(SV_$C_name, $C_name);"; 59 | 60 | return ($init_code, $cleanup_code); 61 | } 62 | 63 | sub c_blocks_pack_SV { 64 | my ($package, $C_name, $SV_name, $must_declare_SV) = @_; 65 | return "SV * $SV_name = " . $package->make_new . "($C_name);" 66 | if $must_declare_SV; 67 | return $package->setter . "($SV_name, $C_name);"; 68 | } 69 | 70 | sub c_blocks_new_SV { 71 | my ($package, $C_name) = @_; 72 | return $package->make_new . "($C_name)"; 73 | } 74 | 75 | sub c_blocks_unpack_SV { 76 | my ($package, $SV_name, $C_name, $must_declare_name) = @_; 77 | my $declaration = ''; 78 | $declaration = $package->c_blocks_data_type . ' ' if $must_declare_name; 79 | my $getter = $package->getter; 80 | return "$declaration$C_name = $getter($SV_name);"; 81 | } 82 | 83 | ######################################################################## 84 | # Floating point 85 | ######################################################################## 86 | package C::Blocks::Type::NV; 87 | our @ISA = qw(C::Blocks::PerlAPI::Type); 88 | sub c_blocks_data_type { 'NV' } 89 | sub getter { 'SvNV' } 90 | sub setter { 'sv_setnv' } 91 | sub make_new { 'newSVnv' } 92 | 93 | package C::Blocks::Type::double; 94 | our @ISA = qw(C::Blocks::Type::NV); 95 | sub c_blocks_data_type { 'double' } 96 | 97 | package C::Blocks::Type::float; 98 | our @ISA = qw(C::Blocks::Type::NV); 99 | sub c_blocks_data_type { 'float' } 100 | 101 | ######################################################################## 102 | # Signed Integers 103 | ######################################################################## 104 | package C::Blocks::Type::IV; 105 | our @ISA = qw(C::Blocks::PerlAPI::Type); 106 | sub c_blocks_data_type { 'IV' } 107 | sub getter { 'SvIV' } 108 | sub setter { 'sv_setiv' } 109 | sub make_new { 'newSViv' } 110 | 111 | package C::Blocks::Type::int; 112 | our @ISA = qw(C::Blocks::Type::IV); 113 | sub c_blocks_data_type { 'int' } 114 | 115 | package C::Blocks::Type::short; 116 | our @ISA = qw(C::Blocks::Type::IV); 117 | sub c_blocks_data_type { 'short' } 118 | 119 | package C::Blocks::Type::long; 120 | our @ISA = qw(C::Blocks::Type::IV); 121 | sub c_blocks_data_type { 'long' } 122 | 123 | ######################################################################## 124 | # Unsigned Integers 125 | ######################################################################## 126 | package C::Blocks::Type::UV; 127 | our @ISA = qw(C::Blocks::PerlAPI::Type); 128 | sub c_blocks_data_type { 'UV' } 129 | sub getter { 'SvUV' } 130 | sub setter { 'sv_setuv' } 131 | sub make_new { 'newSVuv' } 132 | 133 | package C::Blocks::Type::uint; 134 | our @ISA = qw(C::Blocks::Type::UV); 135 | sub c_blocks_data_type { 'unsigned int' } 136 | 137 | package C::Blocks::Type::ushort; 138 | our @ISA = qw(C::Blocks::Type::UV); 139 | sub c_blocks_data_type { 'unsigned short' } 140 | 141 | package C::Blocks::Type::ulong; 142 | our @ISA = qw(C::Blocks::Type::UV); 143 | sub c_blocks_data_type { 'unsigned long' } 144 | 145 | ######################################################################## 146 | # Arrays 147 | ######################################################################## 148 | package C::Blocks::Type::double_array; 149 | sub data_type { 'double' } 150 | sub c_blocks_init_cleanup { 151 | my ($package, $C_name, $sigil_type, $pad_offset) = @_; 152 | my $data_type = $package->data_type; 153 | 154 | my $init_code = join(";\n", 155 | "$sigil_type * SV_$C_name = ($sigil_type*)PAD_SV($pad_offset)", 156 | "STRLEN length_$C_name", 157 | "$data_type * $C_name = ($data_type*)SvPVbyte(SV_$C_name, length_$C_name)", 158 | "length_$C_name /= sizeof($data_type)", 159 | '', 160 | ); 161 | 162 | return $init_code; 163 | } 164 | 165 | package C::Blocks::Type::float_array; 166 | our @ISA = qw(C::Blocks::Type::double_array); 167 | sub data_type { 'float' } 168 | 169 | package C::Blocks::Type::int_array; 170 | our @ISA = qw(C::Blocks::Type::double_array); 171 | sub data_type { 'int' } 172 | 173 | package C::Blocks::Type::char_array; 174 | our @ISA = qw(C::Blocks::Type::double_array); 175 | sub data_type { 'char' } 176 | 177 | __END__ 178 | 179 | =head1 NAME 180 | 181 | C::Blocks::Types - type classes for basic C data types for C::Blocks 182 | 183 | =head1 VERSION 184 | 185 | This documentation is for v0.42 186 | 187 | =head1 SYNOPSIS 188 | 189 | use C::Blocks; 190 | use C::Blocks::Types qw(double double_array Int); 191 | 192 | # Generate some synthetic data; 193 | my @data = map { rand() } 1 .. 10; 194 | print "data are @data\n"; 195 | 196 | # Pack this data into a C array 197 | my double_array $points = pack 'd*', @data; 198 | 199 | # Calculate the rms (root mean square) 200 | my double $rms = 0; 201 | cblock { 202 | for (int i = 0; i < length_$points; i++) { 203 | $rms += $points[i]*$points[i]; 204 | } 205 | $rms = sqrt($rms / length_$points); 206 | } 207 | 208 | print "data rms is $rms\n"; 209 | 210 | # Note that Int is capitalized, unlike the other type names 211 | my Int $foo = 4; 212 | cblock { 213 | printf("$foo is %d\n", $foo); 214 | } 215 | 216 | =head1 DESCRIPTION 217 | 218 | L lets you intersperse blocks of C code directly among your 219 | Perl code. To help facilitate the interchange of C and Perl data, you 220 | can indicate that your Perl variable has an associated type package. 221 | This is discussed in L. The purpose of this package is 222 | to provide type packages, and short names, for basic C data types like 223 | L and L, as well as rudimentary packed arrays. 224 | 225 | ... must document provided types as well as "length_" variables. 226 | 227 | Note: For pointers you should use L. 228 | -------------------------------------------------------------------------------- /lib/C/Blocks/Types/IsaStruct.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use C::Blocks::Types::Struct; 4 | 5 | ######################################################################## 6 | package C::Blocks::Types::IsaStruct; 7 | ######################################################################## 8 | our $VERSION = '0.42'; 9 | $VERSION = eval $VERSION; 10 | use Carp; 11 | 12 | # To document: short_name => String [last bareword of caller's package] 13 | # : C_type => same as caller's package 14 | sub import { 15 | my ($package, %args) = @_; 16 | my $caller_package = caller; 17 | 18 | # Figure our short name. Use given, or if none, deduce from package 19 | my $short_name = $args{short_name}; 20 | if (not $short_name) { 21 | $short_name = $caller_package; 22 | $short_name =~ s/.*:://; 23 | } 24 | 25 | # Figure out the C type 26 | my $C_type = $args{C_type} || $caller_package; 27 | 28 | # Add the C type method to caller's package, and make caller's 29 | # package inherit from the struct base class for general reuse 30 | { 31 | no strict 'refs'; 32 | 33 | # Set up the type's data type method 34 | *{"$caller_package\::c_blocks_data_type"} = sub () { $C_type }; 35 | 36 | # Add this package to caller's @ISA 37 | push @{"$caller_package\::ISA"}, 'C::Blocks::Types::Struct'; 38 | 39 | # Set up a method that produces the default short name; make 40 | # copy of short_name to suppress warnings for const subs 41 | my $short_name2 = $short_name; 42 | *{"$caller_package\::default_short_name"} = sub () { $short_name2 }; 43 | 44 | # Explicitly inject import method into calling package 45 | *{"$caller_package\::import"} = \&C::Blocks::Types::IsaStruct::Base::import; 46 | 47 | # Turn off C::Blocks warnings in caller about import method... 48 | warnings->unimport('C::Blocks::import'); 49 | } 50 | } 51 | 52 | ######################################################################## 53 | package C::Blocks::Types::IsaStruct::Base; 54 | ######################################################################## 55 | # The class that implements all of the reusable methods. Actually, 56 | # C::Blocks::Types::Struct implements all of the resuable methods except 57 | # for the import method, so we'll implement that and inheret the rest. 58 | 59 | our @ISA = qw(C::Blocks::Types::Struct); 60 | sub import { 61 | my ($package, %args) = @_; 62 | my $caller_package = caller; 63 | 64 | # install this type's short name in caller's package 65 | my $short_name = $args{short_name} || $package->default_short_name; 66 | no strict 'refs'; 67 | # Suppress a warning by making a very local variable 68 | my $package_const = $package; 69 | *{"$caller_package\::$short_name"} = sub () { $package_const }; 70 | 71 | # Load this package's shared code if there is any 72 | my $symtab = ${"$package\::__cblocks_extended_symtab_list"}; 73 | C::Blocks::load_lib($package) if defined $symtab; 74 | } 75 | 76 | 1; 77 | 78 | __END__ 79 | 80 | =head1 NAME 81 | 82 | C::Blocks::Types::IsaStruct - declare sharable struct types stored as packed data 83 | 84 | =head1 VERSION 85 | 86 | This documentation is for v0.42 87 | 88 | =head1 SYNOPSIS 89 | 90 | ## Basic usage 91 | package My::Struct::Type; 92 | use C::Blocks; 93 | use C::Blocks::Types::IsaStruct; 94 | cshare { 95 | typedef struct My::Struct::Type_t { 96 | int x; 97 | int y; 98 | } My::Struct::Type; 99 | } 100 | 101 | =head1 DESCRIPTION 102 | 103 | The goal of C::Blocks::Types::IsaStruct is to let you create a struct 104 | type that can be easily shared, and then get out of your way. That is, 105 | this is the module you will use to create the C::Blocks type for a 106 | struct that others can use to seamlessly transition their C<$variable> 107 | between Perl and C. 108 | 109 | If you just need to quickly create a type for an internal struct, you 110 | should look into L. That module provides an 111 | interface for creating a type that is more expedient, but less 112 | sharable. 113 | 114 | This module helps you create a I class. This does not create a 115 | full-blown class for your struct, and specifically it does not create 116 | Perl methods to access and modify members. A full-blown class system is 117 | in order for that case, and that is beyond the scope of the approach 118 | provided by C::Blocks::Types::IsaStruct. 119 | 120 | There are two basic approaches to creating a module whose job is to 121 | share struct types. The first approach is to create one module file for 122 | each struct type. This approach makes sense when you don't have too 123 | many structs to declare, and also when the structs have a library of 124 | functions for manipulating them. The alternative approach is to place 125 | all of the struct declarations and type classes into a single module 126 | file. This makes sense when you have lots of structs or when you need 127 | to generate struct and/or type information on the fly. In that case, 128 | the package associated with the module file should have an import 129 | method that knows how to parcel out the different struct types that 130 | might or might not be wanted by the caller. 131 | 132 | =head2 One struct per module file 133 | 134 | When you're using C::Blocks::Types::IsaStruct, the simplest approach is 135 | to have one struct per module file. Such a module would: 136 | 137 | =over 138 | 139 | =item declare the package 140 | 141 | The package statement must match the module file name. 142 | 143 | =item use C::Blocks 144 | 145 | This is not imported for you by IsaStruct automatically, and you will 146 | need it to declare a C block with the C struct layout. 147 | 148 | =item use C::Blocks::Types::IsaStruct 149 | 150 | This will endow your package with all of the type methods your package 151 | will need to serve as a type class. There are some use-time arguments 152 | that you might include, discussed below. 153 | 154 | =item cshare with struct 155 | 156 | This will provide the C symbol table that gets shared with callers when 157 | they use this module. It will need the struct layout, and should 158 | include any functions that your caller might find useful for 159 | manipulating the structs you provide. 160 | 161 | =back 162 | 163 | Beyond these bare minimum aspects, you may also feel compelled to 164 | provide Perl methods for manipuating your structs. Your pod will also 165 | document this struct and its interface in detail. That last part may 166 | serve as a litmus test: if you could reduce duplicate documentation or 167 | Perl code by combining many of your structs into a single module, you 168 | might consider the next approach. 169 | 170 | =head2 Many structs in a single module file 171 | 172 | When many structs are declared in a single module file, you need to 173 | provide a mechanism for your caller to C your module and select 174 | which struct symbol tables get pushed into their lexical scope. Such a 175 | module file will likely contain: 176 | 177 | =over 178 | 179 | =item package matching module name 180 | 181 | This package will implement an C method that takes user 182 | arguments and selectively imports the symbol tables and types defined 183 | elsewhere in the module. A sensible way to achieve this is to take a 184 | list of type short-names and delegate to their C method. If 185 | the structs are declared in a C under this package, it will 186 | need to be loaded in the C method with an explicit call to 187 | C. 188 | 189 | =item one package for each struct type 190 | 191 | Each struct will need to have a unique package with a structue matching 192 | the one outlined above for a single module per type. That package will 193 | C C::Blocks::Types::IsaStruct, and so will have a well-defined 194 | C method even though there is no way to C the package 195 | directly. The struct layout will either be part of the package, or it 196 | will be defined in a C block belonging to the main package for 197 | this module. 198 | 199 | =back 200 | --------------------------------------------------------------------------------