1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
#package;
use strict;
use warnings;
# This file contains functions to build .pd from the HDF prototypes
# Define a low-level perl interface to HDF from these definitions.
sub create_low_level
{
# This file must be modified to only include
# netCDF 3 function definitions.
# Also, all C function declarations must be on one line.
my $defn = shift;
my $sub = "create_low_level()";
my @lines = split (/\n/, $defn);
foreach my $line (@lines)
{
next if ( $line =~ /^\#/ ); # Skip commented out lines
next if ( $line =~ /^\s*$/ ); # Skip blank lines
unless ($line =~ /^(\w+\**)\s+(\w+)\((.+)\)(\+*\d*)\;/)
{
die "$sub: Can't parse this line!\n";
}
my ($return_type, $func_name, $params, $add) = ($1, $2, $3, $4);
my @vars;
my @types;
my $output = {};
foreach my $param ( split (/,/, $params) )
{
my ($varname) = ($param =~ /(\w+)$/);
$param =~ s/$varname//; # parm now contains the full C type
$output->{$varname} = 1
if (($param =~ /\*/) && ($param !~ /const/));
$param =~ s/const //; # get rid of 'const' in C type
$param =~ s/^\s+//;
$param =~ s/\s+$//; # pare off the variable type from 'parm'
push (@vars, $varname);
push (@types, $param);
}
# Create the XS header:
my $xsout = '';
$xsout .= "$return_type\n";
$xsout .= "_$func_name (" . join (", ", @vars) . ")\n";
# Add in the variable declarations:
foreach my $i ( 0 .. $#vars )
{
$xsout .= "\t$types[$i]\t$vars[$i]\n";
}
# Add the CODE section:
$xsout .= "CODE:\n";
$xsout .= "\tRETVAL = ";
$xsout .= "$add + "
if defined($add);
$xsout .= "$func_name (";
# Add more variable stuff:
foreach my $i ( 0 .. $#vars )
{
my $type = $types[$i];
if ($type =~ /PDL/)
{
$type =~ s/PDL//; # Get rid of PDL type when writing xs CODE section
$xsout .= "($type)$vars[$i]"."->data,";
}
else
{
$xsout .= "$vars[$i],";
}
}
chop ($xsout); # remove last comma
$xsout .= ");\n";
# Add the OUTPUT section:
$xsout .= "OUTPUT:\n";
$xsout .= "\tRETVAL\n";
foreach my $var ( sort keys %$output )
{
$xsout .= "\t$var\n";
}
$xsout .= "\n\n";
# Add it to the PDL::PP file:
pp_addxs ('', $xsout);
}
} # End of create_low_level()...
1;
|
