#
# Language module for the wrapper generator for octave 2.0. Most of these
# functions are called directly from the wrapper generator.
#
# Octave is a little difficult to handle because (like MATLAB) it can only
# define a single C function per mex file. This means that the C function must
# take an additional argument of which sub-function to call. We provide octave
# functions which supply the extra argument.
#
# Copyright (c) 1997 Gary R. Holt. This is distributed under the terms of the
# perl artistic license (http://language.perl.com/misc/Artistic.html).
#
package octave; # Everything should be in this package.
@function_names = (); # This table translates function names and
# their assigned IDs. The extra numerical
# argument to the mexFunction() indicates
# which function the user actually wanted to
# call.
$max_dimensions = 2; # Maximum number of dimensions in tensors.
*pointer_type_code = *main::pointer_type_code;
# Copy the definition of pointer_type_code
# into this module.
#
# arg_pass(\%function_def, $argname)
#
# A C or C++ expression used to pass the argument to another function
# which does not know anything about the type of the argument. For
# example, in the MATLAB module this function returns an expression for
# the mxArray type for a given argument.
#
sub arg_pass {
my ($faa, $argname) = @_; # Name the arguments.
$faa->{args}{$argname}{oct_expr}; # Return the octave expression.
}
#
# arg_declare("arg_name_in_arglist")
#
# This returns a C/C++ declaration appropriate for the argument passed
# using arg_pass. For example, in the MATLAB module this function returns
# "mxArray *arg_name_in_arglist".
#
sub arg_declare {
"const octave_value &$_[0]";
}
#
# declare_const("constant name", "class name", "<type>", "doc str")
#
# Output routines to make a given constant value accessible from the
# interpreter.
# If "class name" is blank, this is a global constant.
#
sub declare_const {
# This is not currently supported.
}
#
# error_dimension(\%function_def, $argname)
#
# A C statement (including the final semicolon, if not surrounded by braces)
# which indicates that an error has occured because the dimension of argument
# $argname was wrong.
#
sub error_dimension {
"{ error(\"dimension mismatch in argument $_[1]\"); return retval; }"
# Return whatever we've made so far, which
# is probably an empty list.
}
#
# finish()
#
# Called after all functions have been wrapped, to close the output file and do
# whatever other cleanup is necessary.
#
sub finish {
print OUTFILE qq[
//
// The main dispatch function. This function calls the appropriate wrapper
// based on the value of the first argument.
//
DEFUN_DLD($octave_output_file, args, nargout, "See $stub_file for documentation")
{
int function_id = int(args(0).double_value());
// Get the function ID.
switch (function_id)
{
];
# Output the beginning of the definition.
foreach (0 .. @function_names-1) {
print " case $_: return $function_names[$_](args, nargout);\n";
}
# Dispatch appropriately.
print "
default: error(\"Illegal function ID parameter\"); return octave_value();
}
}
";
close(OUTFILE); # Done with this file.
close(STUBFILE); # We're also done with the stub file.
}
#
# Begin the definition of a function. Arguments:
# 1) The %function_def array.
#
sub function_start {
my $faa = $_[0]; # Access the argument.
my $retstr;
my $fname = $faa->{script_name} ||
($faa->{class} ? $faa->{class} . "_" : "") . $faa->{name};
# Get octave's name for the function.
$faa->{octave_name} = $fname; # Remember that for later.
#
# Octave doesn't support modify variables, so we add an extra variable to
# the output argument list for each input modify variable.
#
$retstr = sprintf("octave_value_list _wrap_%s(const octave_value_list &args, int %s)\n",
$fname,
(@{$faa->{outputs}} + @{$faa->{modifies}}) <= 1 ? '' : 'nargout');
# Don't specify nargout unless we actually
# need to test it.
$retstr .= ("{\n" .
" octave_value_list retval(" . @{$faa->{outputs}} . ", octave_value());\n" . # Where we return stuff.
# Make sure we have right # of args:
" if (args.length()-1 != " . (scalar(@{$faa->{inputs}}) +
scalar(@{$faa->{modifies}})));
$retstr .= " ||\n nargout != " . (scalar(@{$faa->{outputs}}) + scalar(@{$faa->{modifies}}))
unless (@{$faa->{outputs}}+@{$faa->{modifies}}) <= 1;
# Permissible not to specify output args
# if there is only one.
$retstr .= (")\n" .
" {\n" .
" print_usage(\"$fname\");\n" . # Give an error.
" return retval;\n" . # Quit now.
" }\n\n");
#
# Now go through and store the octave expression to get each argument, so
# we can access them later:
#
my $idx = 1; # Start input arguments at 1, since the
# first argument is the function ID.
my $arg;
foreach (@{$faa->{inputs}}, @{$faa->{modifies}}) {
$arg = $faa->{args}{$_}; # Point to this argument.
$arg->{oct_expr} = "args(" . $idx++ . ")";
if ($arg->{basic_type} eq 'char *') {
if (@{$arg->{dimension}} != 0) { # A vector of characters?
die("wrap_octave: vectors of strings are not currently supported\n");
}
$arg->{vectorize} = 0; # We don't support vectorization of strings
# since octave only has the klugy char
# matrix for string vectors.
$arg->{source} eq 'modify' and $faa->{vectorize} = 0;
# If a modify argument can't be vectorized,
# we can't vectorize the function.
}
}
$idx = 0; # Now do the same for the outputs.
foreach (@{$faa->{outputs}}) { # These have different indices.
$arg = $faa->{args}{$_}; # Point to this argument.
$arg->{oct_expr_out} = "retval(" . $idx++ . ")";
if ($arg->{basic_type} eq 'char *') {
if (@{$arg->{dimension}} != 0) { # A vector of characters?
die("wrap_octave: vectors of strings are not currently supported\n");
}
$arg->{vectorize} = 0; # We don't support vectorization of strings
# since octave only has the klugy char
# matrix for string vectors.
$faa->{vectorize} = 0; # This function can't be vectorized if its
# output arguments can't be vectorized.
}
}
foreach (@{$faa->{modifies}}) { # Indicate where we're supposed to put the
# modified output as well.
$faa->{args}{$_}{oct_expr_out} = "retval(" . $idx++ . ")";
}
$retstr;
}
#
# function_end(\%function_def)
#
# Return a string which finishes off the definition of a wrapper.
#
sub function_end {
my ($faa) = @_; # Access the argument.
my $fname = $faa->{octave_name}; # Get octave's name for the function.
push(@function_names, "_wrap_$fname"); # Register it in our list of functions.
#
# Add a function to the stub file:
#
my $outargs = join(", ", @{$faa->{outputs}}, # List output arguments.
map { "out_$_" } @{$faa->{modifies}});
# Modify arguments also must appear in the
# output list.
(@{$faa->{outputs}}+@{$faa->{modifies}}) > 1 and $outargs = "[$outargs]";
# If there's more than one, put it in
# brackets.
$outargs ne '' and $outargs .= " = "; # Add an equals sign too.
my $inargs = join(", ", @{$faa->{inputs}}, @{$faa->{modifies}});
# Format the input arguments.
print(STUBFILE
"function $outargs$fname($inargs)\n",
"% $outargs$fname($inargs)\n",
"% No documentation is available yet.\n",
" $outargs$octave_output_file(",
join(", ", scalar(@function_names)-1, @{$faa->{inputs}}, @{$faa->{modifies}}),
");\n",
"endfunction\n\n");
" return retval;\n}\n\n"; # Just close off the opening brace.
}
#
# get_c_arg_scalar(\%function_def, $argname)
#
# Returns C statements to load the current value of the given argument
# into the C variable C<$function_def{args}{$argname}{c_var_name}>. The
# variable is guaranteed to be either a scalar or an array with dimensions
# 1,1,1....
#
sub get_c_arg_scalar {
my ($faa, $argname) = @_; # Name the arguments.
my $arg = $faa->{args}{$argname}; # Access the definition of this argument.
my $argtype = $arg->{basic_type}; # Get the basic type, without any frills.
if (exists($typemap_get_scalar{$argtype})) { # Do we understand this type?
return &{$typemap_get_scalar{$argtype}}($arg, $argname, $argtype); # Do the conversion.
} elsif ($argtype =~ /\*$/) { # Is this a pointer class we don't understand?
return (" if (!_get_pointer((void **)&$arg->{c_var_name},\n" .
" $arg->{oct_expr}.complex_matrix_value(),\n" .
" @{[pointer_type_code($argtype)]})) /* $argtype */\n" .
" {\n" .
" error(\"Expecting type '$argtype' for argument named $argname\");\n" .
" return retval;\n" .
" }\n");
# Treat it as an array of pointers.
} else { # Unrecognized type?
die("wrap_octave: don't understand type '$argtype' as scalar\n");
}
}
#
# get_c_arg_ptr(\%function_def, $argname)
#
# Returns C statements to set up a pointer which points to the first
# value in the given argument. The dimensions are guaranteed to be
# correct. The type of the argument should be checked. The pointer
# value should be stored in the variable
# $function_def{args}{$argname}{c_var_name}.
#
# The pointer should actually point to the array of all the values of
# the variable. The array should have the same number of elements as
# the argument, since to vectorize the function, the wrapper function
# will simply step through this array. If we want a float type and the
# input vector is double or int, then a temporary array must be made
# which is a copy of the double/int arrays.
#
sub get_c_arg_ptr {
my ($faa, $argname) = @_; # Name the arguments.
my $arg = $faa->{args}{$argname}; # Access the definition of this argument.
my $argtype = $arg->{basic_type}; # Get the basic type, without any frills.
if (exists($typemap_get_ptr{$argtype})) { # Do we understand this type?
return &{$typemap_get_ptr{$argtype}}($arg, $argname, $argtype); # Do the conversion.
} elsif ($argtype =~ /\*$/) { # Is this a pointer class we don't understand?
return (" $arg->{c_var_name} =\n" .
" ($argtype *)alloca(sizeof ($argtype)*_arraylen($arg->{oct_expr}));\n" .
" if (!_get_pointer((void **)$arg->{c_var_name},\n" .
" $arg->{oct_expr}.complex_matrix_value(),\n" .
" @{[pointer_type_code($argtype)]})) /* $argtype */\n" .
" {\n" .
" error(\"$faa->{octave_name}: expecting type $argtype for argument $argname\");\n" .
" return retval;\n" .
" }\n");
} else { # Unrecognized type?
die("wrap_octave: don't understand type '$argtype' as scalar/matrix\n");
}
}
#
# Get the name of the output file given the input files. Arguments:
# 1) A reference to a list of input files.
#
sub get_outfile {
die("wrap_octave: must explicitly specify the output file name with -o fname.c\n");
}
#
# get_size(\%function_def, $argname, $n)
#
# Returns a C expression which is the size of the n'th dimension of the given
# argument. Dimension 0 is the least-significant dimension.
#
sub get_size {
my ($faa, $argname, $index) = @_; # Name the arguments.
my $arg = $faa->{args}{$argname}; # Access definition of this argument.
"_dim($arg->{oct_expr}, $index)";
# Always call the general purpose _dim
# subroutine, because
# $arg->{oct_expr}.rows() can return 0 or
# -1 if it is a scalar.
}
#
# Initialize the output file. Arguments:
# 1) The name of the output file.
# 2) A reference to a list of input files explicitly listed.
# 3) A reference to the words passed to the C preprocessor.
# 4) A string that represents our guess as to the #includes which are
# required.
#
sub initialize {
my ($outfile, $infiles, $cpp_cmd, $include_str) = @_; # Name the arguments.
$stub_file or
die("wrap_octave: must specify the name of the stub file on the command line\n");
open(STUBFILE, "> $stub_file") ||
die("wrap_octave: cannot create stub file \"$stub_file\"--$!\n");
print STUBFILE "# Stub subroutines for octave file $outfile.
# This file was automatically generated for octave by wrap_octave on
# ", scalar(localtime(time)), " from
# @{[@$infiles, @$cpp_cmd]}.
#
1; # This is not a function file.
";
open(OUTFILE, "> $outfile") ||
die("wrap_octave: can't open output file $outfile--$!\n");
$octave_output_file = $outfile; # Remember the name of the output file.
$octave_output_file =~ s/\..*$//; # Strip off the extension.
$octave_output_file =~ s@.*/@@; # Strip off the directories.
print OUTFILE "/*
* This file was automatically generated for octave by wrap_octave on
* ", scalar(localtime(time)), "
* from @{[@$infiles, @$cpp_cmd]}.
*/
$include_str
"; # Output a header.
while (defined($_ = <DATA>)) { # Read the rest of the static functions.
print OUTFILE $_;
}
return "octave::OUTFILE"; # Return the file handle.
}
#
# make_output_scalar(\%function_def, $argname)
#
# Return C code to create the given output variable, which is guaranteed
# to be a scalar.
#
sub make_output_scalar {
my ($faa, $argname) = @_;
my $arg = $faa->{args}{$argname}; # Access the definition of this argument.
my $argtype = $arg->{basic_type}; # Get the basic type, without any frills.
if (exists($typemap_output_scalar_make{$argtype})) { # Do we understand this type?
return &{$typemap_output_scalar_make{$argtype}}($arg);
# Do the conversion.
} elsif ($argtype =~ /\*$/) { # Is this a pointer class we don't understand?
return " $arg->{oct_expr_out} = octave_value(Complex(0, 0));\n";
# Make a value.
} else { # Unrecognized type?
die("wrap_octave: don't understand scalar output/modify type '$argtype'\n");
}
}
#
# make_output_ptr(\%function_def, $argname, $n_dimensions, @dimensions)
#
# Return C code to set up the given output variable. $n_dimensions is a C
# expression, not a constant. @dimensions is a list of C expressions that are
# the sizes of each dimension. There may be more values in @dimensions than
# are wanted.
#
sub make_output_ptr {
my ($faa, $argname, $n_dims, @dims) = @_;
my $arg = $faa->{args}{$argname}; # Access the argument info.
my $type = $arg->{basic_type}; # Access the type.
my $retstr = '';
push(@dims, 1) while (@dims < 2); # Make the first two dimensions 1 if it's
# a scalar, since that's the way octave
# represents it.
#
# Make an array containing the appropriate dimensions:
#
#
# Now make an argument of the appropriate type. Note that although octave
# understands RowVector/ColumnVector as different object types from a
# Matrix, when the value gets put into an octave variable these are all
# converted to an octave_matrix, which is just a wrapper around the Matrix
# class. So we just use the Matrix class and don't try to figure out whether
# it's a row or column vector.
#
#
if (exists($typemap_output_array_make{$type})) { # Do we understand this type?
$retstr .= &{$typemap_output_array_make{$type}}($arg, $argname, @dims);
} elsif ($type =~ /\*$/) { # Some random pointer type?
$retstr .= (" $arg->{oct_expr_out} = ComplexMatrix($dims[0],$dims[1]);\n" .
# Allocate an array to store the result.
" $arg->{c_var_name} = ($type *)alloca(_arraylen($arg->{oct_expr_out}) * sizeof ($type));\n");
# Allocate a temporary array to put ptrs into.
} else {
die("wrap_octave: can't handle output of type '$type'\n");
}
$retstr;
}
#
# n_dimensions(\%function_def, $argname)
#
# Returns a C expression which is the number of dimensions of the argument
# whose name is $argname.
#
sub n_dimensions {
my ($faa, $argname) = @_; # Name the arguments.
my $arg = $faa->{args}{$argname}; # Point to argument description.
return ($arg->{basic_type} eq 'char *') ? '0' :
"_n_dims($arg->{oct_expr})";
}
#
# Parse the argument vector for language-specific options. Arguments:
# 1) A reference to the argument vector.
# Any arguments we use should be removed from the argument vector.
#
sub parse_argv {
my ($ARGV) = @_; # Access the arguments.
my $argidx;
for ($argidx = 0; $argidx < @$ARGV; ++$argidx) { # Look at the arguments:
if ($ARGV->[$argidx] eq '-stub') { # Stub file name specified?
$stub_file = $ARGV[$argidx+1]; # Get the file name.
splice(@$ARGV, $argidx, 2); # Remove these two elements from the array.
$argidx--; # Back up to account for the argument we removed.
}
}
}
#
# Returns code to convert to and from pointer types to the languages
# internal representation, if any special code is needed. If this
# subroutine is not called, then there are no class types and pointers
# will not need to be handled.
#
sub pointer_conversion_functions {
($_ = <<"###END") =~ s/^# ?//mg; # Strip the '# ' from beginning of lines.
# //
# // Pointers are stored as double precision numbers (actually, as the real part
# // of a complex number, with the imaginary part being the type). This
# // should work even on 64 bit machines, since a double is at least 64 bits
# // on all machines that I know of.
# //
# union d_to_p {
# double dval; // Double precision value.
# void *pval; // Pointer value.
# };
# //
# // Local functions dealing with pointers:
# //
# // Pointers are stored as complex numbers. The real part is the pointer value,
# // and the complex part is the type code. Since the real part will be a double
# // precision number, the pointer is guaranteed to fit, even on 64-bit machines.
# //
# // Fill an array with pointers. Arguments:
# // 1) A pointer to the array to fill. The array is already the correct size.
# // 2) A complex matrix which contains the pointers.
# // 3) The pointer type code.
# //
# // Returns false if some of the pointers have the wrong type.
# //
# static int
# _get_pointer(void **arr, const ComplexMatrix &c_mat, unsigned typecode)
# {
# for (int i = 0; i < c_mat.dim1(); ++i)
# for (int j = 0; j < c_mat.dim2(); ++j)
# {
# d_to_p c_real;
# Complex cval = c_mat(i,j); // Get the number.
# unsigned this_typecode = unsigned(cval.imag()); // Get the type.
# c_real.dval = cval.real(); // Get the address.
# if (this_typecode != typecode) // Type does not match?
# {
# *arr = __cvt_type(c_real.pval, this_typecode, typecode);
# // Check for inheritance.
# if (*arr++ == 0)
# return false; // Urk! A type error.
# }
# else // Type matches exactly:
# *arr++ = c_real.pval;
# }
# return true; // No type error.
# }
# //
# // Load an octave object with a pointer or an array of pointers:
# //
# static void
# _put_pointer(octave_value &o_obj, void **ptr_array, double type_code) {
# if (_n_dims(o_obj) == 0) // Is this a scalar?
# {
# d_to_p c_real;
# c_real.dval = 0; // Zero out the unused part of the field.
# c_real.pval = *ptr_array; // Get the value.
# o_obj = octave_value(Complex(c_real.dval, type_code)); // Set the object.
# }
# else // It's a vector output. In this case, the
# { // object's dimensions/type are already set.
# ComplexMatrix c_mat = o_obj.complex_matrix_value();
# Complex *c_arr = (Complex *)c_mat.data();
# // Point to the data.
# for (int idx = 0; idx < c_mat.length(); ++idx)
# {
# d_to_p c_real;
# c_real.dval = 0; // Zero out the unused part of the field.
# c_real.pval = *ptr_array++; // Get the value.
# *c_arr++ = Complex(c_real.dval, type_code);
# }
# o_obj = octave_value(c_mat); // Return the value.
# }
# }
###END
$_;
}
#
# put_val_scalar(\%function_def, $argname)
#
# Returns C code to take the value from the C variable whose name is given
# by $function_def{args}{$argname}{c_var_name} and store it back in the
# scripting language scalar variable.
#
sub put_val_scalar {
my ($faa, $argname) = @_;
my $arg = $faa->{args}{$argname}; # Access the definition of this argument.
my $argtype = $arg->{basic_type}; # Get the basic type, without any frills.
if (exists($typemap_put_scalar{$argtype})) { # Do we understand this type?
return &{$typemap_put_scalar{$argtype}}($arg);
# Do the conversion.
} elsif ($argtype =~ /\*$/) { # Is this a pointer class we don't understand?
return " _put_pointer($arg->{oct_expr_out}, (void **)&$arg->{c_var_name}, @{[pointer_type_code($argtype)]}); /* $argtype */\n";
} else { # Unrecognized type?
die("wrap_octave: don't understand scalar output/modify type '$argtype'\n");
}
}
#
# put_val_ptr(\%function_def, $argname)
#
# Returns C code to take the value from the C array whose name is given by
# $function_def{args}{$argname}{c_var_name} and store it back in the scripting
# language array at the specified index. The pointer
# $function_def{args}{$argname}{c_var_name} was set up by either get_c_arg or
# make_output, depending on whether this is an input/modify or an output
# variable.
#
sub put_val_ptr {
my ($faa, $argname) = @_;
my $arg = $faa->{args}{$argname}; # Access the definition of this argument.
my $argtype = $arg->{basic_type}; # Get the basic type, without any frills.
my $argdim = $arg->{dimension}; # Point to the dimensions.
my $retstr;
if (exists($typemap_put_ptr{$argtype})) { # Do we understand this type?
return &{$typemap_put_ptr{$argtype}}($arg, $argname); # Do the conversion.
} elsif ($argtype =~ /\*$/) { # Is this a pointer class we don't understand?
return " _put_pointer($arg->{oct_expr_out}, (void **)$arg->{c_var_name}, @{[pointer_type_code($argtype)]}); /* $argtype */\n";
} else { # Unrecognized type?
die("wrap_octave: don't understand scalar/vector output/modify type '$argtype'\n");
}
}
###############################################################################
#
# Typemap stuff. These are subroutines that do various things depending on the
# type. You can add freely to this to define new types.
#
#
# Get the value of an argument which is guaranteed to be a scalar, and put
# it into a C variable.
#
# All functions in this hash are called with three arguments:
# 1) The $function_def{args}{$argname} associative array.
# The C variable the value is stored in is $args->{c_var_name}.
# 2) The name of the argument.
# 3) The type of the argument.
#
$typemap_get_scalar{'double'} = $typemap_get_scalar{'float'} =
$typemap_get_scalar{'int'} = $typemap_get_scalar{'unsigned'} =
$typemap_get_scalar{'short'} = $typemap_get_scalar{'unsigned short'} = sub {
my ($arg) = @_; # Name the arguments.
" $arg->{c_var_name} = ($arg->{basic_type})$arg->{oct_expr}.double_value();\n";
};
$typemap_get_scalar{'char *'} = sub {
my ($arg, $argname) = @_; # Name the arguments.
(" string _$argname = $arg->{oct_expr}.string_value();\n" .
# Get the string.
" _$argname += '\\0';\n" . # Make sure it's null terminated.
" $arg->{c_var_name} = (char *)_$argname.data();\n");
};
$typemap_get_scalar{'char'} = sub {
my ($arg, $argname) = @_; # Name the arguments.
" $arg->{c_var_name} = *$arg->{oct_expr}.char_matrix_value().data();\n";
};
$typemap_get_scalar{'complex < double >'} = sub {
my ($arg, $argname) = @_; # Name the arguments.
" $arg->{c_var_name} = $arg->{oct_expr}.complex_value();\n";
};
$typemap_get_scalar{'complex < float >'} = sub {
my ($arg, $argname) = @_; # Name the arguments.
(" complex<double> _$arg->{c_var_name} = $arg->{oct_expr}.complex_value();\n" .
" $arg->{c_var_name} = complex<float>(_$arg->{c_var_name}.real(), $arg->{c_var_name}.imag());\n");
};
#
# Get the value of a potentially vector argument and put it into a C variable.
# The dimensions are guaranteed to be proper. Type checking should be done.
# All functions in this hash are called with three arguments:
# 1) The $function_def{args}{$argname} associative array.
# The C variable the value is stored in is $args->{c_var_name}.
# 2) The name of the argument.
# 3) The type of the argument.
#
$typemap_get_ptr{'double'} = # For double precision, if the input array is
# of Real type, we can just return a pointer
# into it. If it's an integer array, we have
# to copy it into a temporary array of double.
sub {
my ($arg, $argname) = @_; # Name the arguments.
my $retstr = " Matrix _$argname = $arg->{oct_expr}.matrix_value();\n";
# Get the argument as a matrix.
if ($arg->{oct_expr_out}) { # Is this a modify variable?
$retstr .= (" _$argname.make_unique();\n" . # Make our modifiable copy.
" $arg->{oct_expr_out} = octave_value(_$argname);\n");
# Set up the output variable.
}
$retstr .= " $arg->{c_var_name} = &_$argname(0,0);\n";
};
$typemap_get_ptr{'float'} = # Floats and ints require a temporary array.
$typemap_get_ptr{'int'} = $typemap_get_ptr{'unsigned'} =
$typemap_get_ptr{'short'} = $typemap_get_ptr{'unsigned short'} = sub {
my ($arg, $argname, $argtype) = @_; # Name the arguments.
my $retstr =
(" Matrix _$argname = $arg->{oct_expr}.matrix_value();\n" .
" $arg->{c_var_name} = ($argtype *)alloca(_$argname.dim1() * _$argname.dim2() * sizeof ($argtype));\n" .
" _cvt_double_to($arg->{c_var_name}, &_$argname(0,0), _$argname.dim1()*_$argname.dim2());\n");
if ($arg->{oct_expr_out}) { # A modify variable?
$retstr .= " $arg->{oct_expr_out} = octave_value(Matrix(_dim(_$argname, 0), _dim(_$argname, 1)));\n";
# Reserve space for the output.
}
$retstr;
};
$typemap_get_ptr{'complex < double >'} = sub {
my ($arg, $argname) = @_; # Name the arguments.
my $retstr = " ComplexMatrix _$argname = $arg->{oct_expr}.complex_matrix_value();\n";
if ($arg->{oct_expr_out}) { # Modify variable?
$retstr .= (" _$argname.make_unique();\n" . # Make a modifiable copy.
" $arg->{oct_expr_out} = octave_value(_$argname);\n");
}
$retstr .= " $arg->{c_var_name} = &_$argname(0,0);\n";
};
$typemap_get_ptr{'complex < float >'} = sub {
my ($arg, $argname) = @_; # Name the arguments.
my $retstr =
(" ComplexMatrix _$argname = $arg->{oct_expr}.complex_matrix_value();\n" .
" $arg->{c_var_name} = (complex<float> *)alloca(_$argname.dim1() * _$argname.dim2() * sizeof (complex<float>));\n" .
" _cvt_double_to((float *)$arg->{c_var_name}, (double *)&_$argname(0,0), 2*_$argname.dim1() * _$argname.dim2());\n");
# Note that this assumes that the internal
# representation of a complex number is the
# real part and then the imaginary part.
if ($arg->{oct_expr_out}) { # Is this a modify variable?
$retstr .= " $arg->{oct_expr_out} = octave_value(ComplexMatrix(_dim($_argname, 0), _dim($argname, 1)));\n";
# Reserve space for the output.
}
$retstr;
};
# $typemap_get_ptr{'char *'} = sub {
# my ($arg, $argname) = @_; # Name the arguments.
#
# if (!defined($string_vector_to_argv_output)) { # Need conversion subroutine?
# # Output a function to do it. We output this
# # with print so it goes before the function
# # we are currently wrapping.
# print OUTFILE "
# //
# // Convert a string vector into an array of char * values. Arguments:
# // 1) The vector of string values.
# // 2) A char ** array which has already been allocated to the correct
# // dimensions.
# //
# static void
# _string_vector_to_argv(string_vector &strvec, char **c_vec) {
# for (int idx = 0; idx < strvec.length(); ++idx)
# {
# strvec(idx) += '\0'; // Make sure this is null terminated.
# c_vec[idx] = (char *)strvec(idx).data(); // Copy the pointer.
# }
# }
# ";
# $string_vector_to_argv_output = 1; # Don't output it again.
# }
#
# my $retstr =
# (" string_vector _$argname = $arg->{oct_expr}.all_strings();\n" .
# # Get it as a string vector.
# " $arg->{c_var_name} = (char **)alloca(_$argname.length() * sizeof (char *));\n" .
# " _string_vector_to_argv(_$argname, $arg->{c_var_name});\n");
# if ($arg->{oct_expr_out}) { # Is this a modify variable?
# $retstr .= " int _${argname}_len = _$argname.length();\n";
# # Store the number of entries for later.
# }
# $retstr;
# };
$typemap_get_ptr{'char'} = sub {
my ($arg, $argname) = @_; # Name the arguments.
my $retstr =
" charMatrix _$argname = $arg->{oct_expr}.char_matrix_value();\n";
# Get the value as a matrix.
if ($arg->{oct_expr_out}) { # Is this a modify variable?
$retstr .= " _$argname.make_unique();\n"; # Make a modifiable copy.
}
$retstr .= " $arg->{c_var_name} = (char *)_$argname.data();\n";
};
#
# Create an output argument vector of a given size, and put a pointer to the
# space into the appropriate C variable. Arguments:
# 1) The argument description associative array.
# 2) The argument name.
# 3-4) The dimensions.
#
$typemap_output_array_make{'double'} = sub {
my ($arg, $argname, @dims) = @_; # Name the arguments.
(" if ($dims[0] == 1 && $dims[1] == 1)\n" .
" $arg->{c_var_name} = (double *)alloca(sizeof (double));\n" .
" else\n" .
" {\n" .
" $arg->{oct_expr_out} = octave_value(Matrix($dims[0], $dims[1]));\n" .
# Allocate the space.
" $arg->{c_var_name} = (double *)$arg->{oct_expr_out}.matrix_value().data();\n" .
" }\n");
};
$typemap_output_array_make{'float'} = # These types require an intermediate
$typemap_output_array_make{'int'} = # temporary vector.
$typemap_output_array_make{'unsigned'} =
$typemap_output_array_make{'short'} =
$typemap_output_array_make{'unsigned short'} = sub {
my ($arg, $argname, @dims) = @_; # Name the arguments.
(" if ($dims[0] != 1 || $dims[1] != 1)\n" .
" $arg->{oct_expr_out} = octave_value(Matrix($dims[0], $dims[1]));\n" .
# Allocate the space. This also lets us
# know the dimension for later.
" $arg->{c_var_name} = ($arg->{basic_type} *)alloca($dims[0] * $dims[1] * sizeof ($arg->{basic_type}));\n");
# Allocate the temporary array.
};
# $typemap_output_array_make{'char *'} = sub {
# my ($arg, $argname, @dims) = @_; # Name the arguments.
#
# (" int _${argname}_len = $dims[0]*$dims[1];\n" . # Save # of entries for later.
# " $arg->{c_var_name} = (char *)alloca(_${argname}_len * sizeof (char *));\n");
# # Allocate the temporary array.
# };
$typemap_output_array_make{'complex < double >'} = sub {
my ($arg, $argname, @dims) = @_; # Name the arguments.
(" if ($dims[0] == 1 && $dims[1] == 1)\n" .
" $arg->{c_var_name} = ($arg->{basic_type} *)alloca(sizeof ($arg->{basic_type}));\n" .
" else\n" .
" {\n" .
" $arg->{oct_expr_out} = octave_value(ComplexMatrix($dims[0], $dims[1]));\n" .
# Allocate the space.
" $arg->{c_var_name} = (Complex *)$arg->{oct_expr_out}.complex_matrix_value().data();\n" .
" }\n");
};
$typemap_output_array_make{'complex < float >'} = sub {
my ($arg, $argname, @dims) = @_; # Name the arguments.
(" if ($dims[0] != 1 || $dims[1] != 1)\n" .
" $arg->{oct_expr_out} = octave_value(ComplexMatrix($dims[0], $dims[1]));\n" .
# Make a matrix so we remember the size.
" $arg->{c_var_name} = ($arg->{basic_type} *)alloca(sizeof ($arg->{basic_type} * $dims[0] * $dims[1]));\n");
# Make a temporary array.
};
$typemap_output_array_make{'char'} = sub {
# An array of characters is represented as a
# CharMatrix object.
my ($arg, $argname, @dims) = @_; # Name the arguments.
(" $arg->{oct_expr_out} = octave_value(charMatrix($dims[0], $dims[1]), true);\n" .
# Allocate the space.
" $arg->{c_var_name} = (char *)$arg->{oct_expr_out}.char_matrix_value().data();\n");
};
#
# Create a scalar value for output. Arguments:
# 1) The associative array describing the argument.
# 2) A C expression for the argument.
#
$typemap_output_scalar_make{'double'} =
$typemap_output_scalar_make{'float'} =
$typemap_output_scalar_make{'unsigned'} =
$typemap_output_scalar_make{'int'} =
$typemap_output_scalar_make{'short'} =
$typemap_output_scalar_make{'unsigned short'} =
$typemap_output_scalar_make{'char *'} =
$typemap_output_scalar_make{'complex < double >'} =
$typemap_output_scalar_make{'complex < float >'} =
$typemap_output_scalar_make{'char'} = sub {
''; # There's nothing to do. retval already
# contains a scalar since that's the way
# it's initialized, and the only thing we
# need to do for sure at this point is to
# make sure that it's a scalar so later on
# we can test to see if it's a scalar or
# vector.
};
#
# Set the value of an output/modify argument which is guaranteed to be a
# scalar. All functions in this hash are called with three arguments:
# 1) The $function_def{args}{$argname} associative array.
#
$typemap_put_scalar{'double'} =
$typemap_put_scalar{'complex < double >'} =
$typemap_put_scalar{'char *'} = sub {
my ($arg) = @_; # Name the arguments.
" $arg->{oct_expr_out} = octave_value($arg->{c_var_name});\n";
};
$typemap_put_scalar{'float'} =
$typemap_put_scalar{'int'} = $typemap_put_scalar{'unsigned'} =
$typemap_put_scalar{'short'} = $typemap_put_scalar{'short'} = sub {
my ($arg) = @_; # Name the arguments.
" $arg->{oct_expr_out} = octave_value((double)$arg->{c_var_name});\n";
};
$typemap_put_scalar{'complex < float >'} = sub {
my ($arg) = @_; # Name the arguments.
(" $arg->{oct_expr_out} = octave_value(Complex($arg->{c_var_name}.real(),\n" .
" $arg->{c_var_name}.imag()));\n");
};
$typemap_put_scalar{'char'} = sub {
# Treat a single character as a charMatrix.
my ($arg) = @_; # Name the arguments.
(" $arg->{oct_expr_out} = octave_value(charMatrix(1,1), true);\n" . # Make the matrix.
" *(char *)$arg->{oct_expr_out}.char_matrix_value().data() = $arg->{c_var_name};\n");
};
#
# Set the value of an output/modify argument which may be an array.
# The type and dimensions are guaranteed to be proper.
# All functions in this hash are called with three arguments:
# 1) The $function_def{args}{$argname} associative array.
# 2) The name of the argument.
#
$typemap_put_ptr{'double'} =
$typemap_put_ptr{'complex < double >'} = sub {
my ($arg) = @_; # Access the arguments.
(" if (_arraylen($arg->{oct_expr_out}) == 1)\n" . # Is this a scalar?
" $arg->{oct_expr_out} = octave_value(*$arg->{c_var_name});\n"); # Perform the assignment.
};
$typemap_put_ptr{'float'} =
$typemap_put_ptr{'int'} = $typemap_put_ptr{'unsigned'} =
$typemap_put_ptr{'short'} = $typemap_put_ptr{'unsigned short'} = sub {
my ($arg) = @_; # Name the arguments.
(" if (_arraylen($arg->{oct_expr_out}) == 1)\n" . # Is this a scalar?
" $arg->{oct_expr_out} = octave_value(double(*$arg->{c_var_name}));\n" .
" else\n" .
" _cvt_to_double($arg->{c_var_name}, (double *)$arg->{oct_expr_out}.matrix_value().data(), _arraylen($arg->{oct_expr_out}));\n");
};
$typemap_put_ptr{'complex < float >'} = sub {
my ($arg) = @_; # Name the arguments.
(" if (_arraylen($arg->{oct_expr_out}) == 1)\n" . # Is this a scalar?
" $arg->{oct_expr_out} = octave_value(Complex($arg->{c_var_name}\->real(), $arg->{c_var_name}\->imag()));\n" .
" else\n" .
" _cvt_to_double((float *)$arg->{c_var_name}, (double *)$arg->{oct_expr_out}.matrix_value().data(), 2*_arraylen($arg->{oct_expr_out}));\n");
# This depends on the fact that complex numbers
# are stored using their real and imaginary
# values.
};
# $typemap_put_ptr{'char *'} = sub {
# my ($arg, $argname) = @_; # Name the arguments.
# (" if (_${argname}_len == 1)\n" .
# " $arg->{oct_expr_out} = octave_value(*$arg->{c_var_name});\n" .
# " else\n" .
# " {\n" .
# " string_vector _temp_vec($arg->{c_var_name}, _${argname});\n" .
# " $arg->{oct_expr_out} = octave_value(_temp_vec);\n" .
# " }\n");
# };
$typemap_put_ptr{'char'} = sub {
''; # Nothing to do--pointer already set up.
}
#
# Below this point are the functions that get copied into the header of every
# module:
#
__DATA__
#include "oct.h"
#ifndef __GNUC__
#include <alloca.h>
#endif
inline int max(int a, int b) { return a >= b ? a : b; }
inline int min(int a, int b) { return a >= b ? a : b; }
//
// Function to get the total length (rows*columns) of an octave object of
// arbitrary type.
// Arguments:
// 1) The octave object.
//
// If the object is a scalar, the array length is 1.
//
static int
_arraylen(const octave_value &o_obj)
{
return max(o_obj.rows(),1) * max(o_obj.columns(),1); // Return the size.
// max is necessary because sometimes
// rows() or columns() return -1 or 0 for
// scalars.
}
//
// Function to get the number of dimensions of an object.
//
static int
_n_dims(const octave_value &o_obj)
{
if (max(o_obj.columns(),1) > 1)
return 2;
// max is necessary because sometimes
// rows() or columns() return -1 or 0 for
// scalars.
else if (max(o_obj.rows(),1) > 1)
return 1;
else
return 0;
}
//
// Return the n'th dimension of an object. Dimension 0 is the 1st dimension.
//
static inline int
_dim(const octave_value &o_obj, int dim_idx)
{
if (dim_idx == 0)
return max(o_obj.rows(), 1);
// max is necessary because sometimes
// rows() or columns() return -1 or 0 for
// scalars.
else if (dim_idx == 1)
return max(o_obj.columns(), 1);
else
return 1;
}
//
// The following function converts an array of doubles into some other
// numeric type. Arguments:
// 1) Where to store the result. The type is determined from the type of
// this pointer.
// 2) A vector of doubles to convert.
// 3) The number of doubles.
//
template <class FLOAT>
static inline void
_cvt_double_to(FLOAT *out_arr, double *in_arr, unsigned n_el)
{
while (n_el-- > 0)
*out_arr++ = (FLOAT)(*in_arr++);
}
template void _cvt_double_to(int *, double *, unsigned);
template void _cvt_double_to(unsigned *, double *, unsigned);
template void _cvt_double_to(short *, double *, unsigned);
template void _cvt_double_to(unsigned short *, double *, unsigned);
template void _cvt_double_to(float *, double *, unsigned);
// Instantiate our templates. Octave uses
// manual template instantiation.
//
// Convert an array of some other type into an array of doubles. Arguments:
// 1) The array of objects of other type.
// 2) The output array of doubles.
// 3) The number of elements to convert.
//
template <class FLOAT>
static inline void
_cvt_to_double(FLOAT *arr, double *d_arr, unsigned n_el)
{
while (n_el-- > 0)
*d_arr++ = double(*arr++);
}
template void _cvt_to_double(int *, double *, unsigned);
template void _cvt_to_double(unsigned *, double *, unsigned);
template void _cvt_to_double(short *, double *, unsigned);
template void _cvt_to_double(unsigned short *, double *, unsigned);
template void _cvt_to_double(float *, double *, unsigned);
// Instantiate our templates. Octave uses
// manual template instantiation.
syntax highlighted by Code2HTML, v. 0.9.1