3
# See the file $PREFIX/lib/matwrap/matwrap.pod for
4
# extensive documentation.
6
# Copyright (c) 1997 Gary R. Holt. This is distributed under the terms of the
7
# perl artistic license (http://language.perl.com/misc/Artistic.html).
13
# Some stuff needed by the automatic install:
16
$PREFIX = &Cwd::cwd();
17
# This is the location of our source tree.
18
unshift(@INC, "$PREFIX"."/matwrap");
19
# Add our library directory.
22
# Parse the command line arguments:
24
@cpp_ignore_dirs = ('/usr/include/', '/usr/local/include/');
25
# Directory hierarchies to ignore when the
26
# -cpp switch is active. These should be
27
# followed by a trailing slash to avoid
28
# matching something like /usr/include_others.
29
%cpp_ignore_files = (); # Files we're specifically supposed to ignore.
30
$include_str = ''; # A list of files to #include.
32
($progname = $0) =~ s@.*/@@; # Format program name for error messages.
34
$dim_type = 'int'; # The C type to use for array indices and
37
@files = (); # No files to parse.
38
$debug = 0; # Not in debug mode.
40
$cpp_flag = 0; # Default to not running the C preprocessor.
41
#@comments = (); # Where we store the comments.
42
@strings = (); # Where we store quoted strings, etc.
43
@brace_strs = (); # Where we store strings surrounded by braces
46
%variables = (); # Type of each global non-static variable.
47
%functions = (); # The prototype, etc., of each global
48
# function, indexed by function name. Elements
49
# are associative arrays (see the .pod file
51
%classes = (); # Elements are indexed by class names and are
52
# associative arrays of members of each class.
53
# If the members are themselves an associative
54
# array, then they are functions (see the .pod
55
# file for details on format); otherwise
56
# they are fields and the type is given by the
58
%derived_classes = (); # For each class, contains an array of names
59
# of classes that derive from this class.
61
@basic_type_keywords = (qw(short long signed unsigned
63
complex Complex const));
64
@basic_types{@basic_type_keywords} = @basic_type_keywords;
67
%typedef = # Contains definitions of types.
68
(%basic_types, # Fill out the types with the known types.
69
# Unknown words in the type field will be
70
# assumed to be argument names (for function
71
# arguments) and will be ignored. We also
72
# ignore some keywords like 'inline' and
73
# 'virtual' and 'extern'.
74
'void' => 'void', # Other type words relevant for functions:
76
'const' => 'const', # Keep 'const' around.
77
'inline' => '' # Delete occurences of 'inline'.
80
%novectorize_types = (); # Non-zero for all types which we don't want
81
# to vectorize at all, even if we could.
83
# Search the argument list for the -language option:
86
if ($ARGV[$_] eq '-language') { # Is the language specified?
87
$language = $ARGV[$_+1]; # Get the language name.
88
splice(@ARGV, $_, 2); # Remove the elements.
90
require "wrap_$language.pl"; # Load the language file.
91
&{"${language}::parse_argv"}(\@ARGV); # Let it see the options first.
92
last; # Stop scannining @ARGV for -language.
96
defined($language) or die("$progname: must specify output language\n");
98
while ($_ = shift(@ARGV)) { # Get the next argument:
99
if (/^-cpp$/) { # Run the C preprocessor?
100
$cpp_flag = 1; # Remember to run the C preprocessor.
101
last; # Remember the arguments.
102
} elsif (/^-cpp_ignore$/) { # More things for the C preprocessor to ignore?
103
$_ = shift(@ARGV); # Get the next argument.
104
if (-d $_) { # Is this a directory?
105
push(@cpp_ignore_dirs, "$_/"); # Remember the directory.
107
$cpp_ignore_files{$_} = 1; # Remember to ignore this file.
109
} elsif (/^-debug$/) { # Dump out definitions?
111
} elsif (/^-language$/) { # A repeated -language qualifier?
112
die("$progname: two -languages specified\n");
113
} elsif (/^-wrap_?only$/) { # Specify explicitly what to wrap:
114
$wraponly_classes = {}; # Indicate that we're only supposed to wrap
115
$wraponly_globals = {}; # selected things.
116
while ($_ = shift(@ARGV)) { # Get the next argument.
117
if ($_ eq 'class') { # Wrap the whole class?
118
$wraponly_classes->{shift(@ARGV)} = 1; # Wrap this class.
120
$wraponly_globals->{$_} = 1; # Wrap this function/variable.
123
} elsif (/^-o$/) { # Specify output file?
124
$outfile = shift(@ARGV); # Next parameter is output file.
127
# Unrecognized switch:
129
elsif (/^-$/) { # Is it an option?
130
die("$progname: illegal option $_\n");
131
} else { # Not an option, must be a file name.
136
unless (defined($outfile)) { # Was an output file name explicitly specified?
138
die("$progname: -o must be explicitly specified before the -cpp flag\n");
140
$outfile = &{"${language}::get_outfile"}(\@files); # Get the file name.
141
print STDERR "$progname: output file is $outfile\n";
145
if (@files) { # Any files explicitly named?
146
local ($/) = undef; # Slurp in files all at once.
147
# This makes parsing much simpler.
149
foreach $file (@files) { # Parse our list of files.
150
if ($file =~ /\.[hH]{1,2}$/) {
151
$include_str .= "#include \"$file\"\n"; # We'll probably need to include
152
# this file in the generated code.
154
warn("$progname: $file is not an include file\n");
157
open(INFILE, $file) || die("$progname: can't open $file--$!\n");
158
$_ = <INFILE>; # Read the whole file.
159
close(INFILE); # Done with the file.
160
eval { &parse_str($_); }; # Parse this string.
161
$@ and warn("In file $file:\n$@");
165
if ($cpp_flag) { # Run the C preprocessor?
166
grep($_ eq '-E', @ARGV) or # If -E isn't already present somewhere,
167
splice(@ARGV, 1, 0, '-E'); # add -E after the first word.
169
# Start up the child process. Don't use the simple OPEN() because that's
170
# likely to get fouled up if any of the arguments had to be quoted because
171
# they contained special characters. Instead, we want to use exec()
172
# with a list argument.
174
my $pid = open(CPP, "-|"); # Fork and open a process.
175
if (!defined($pid)) { # Did the fork succede?
176
die("$progname: can't fork C preprocessor--$!\n");
179
if ($pid == 0) { # We're the child?
180
exec @ARGV; # Execute the preprocessor.
181
die("Exec of C preprocessor failed--$!\n");
184
# We're the parent--read from the C preprocessor and parse the stuff as we
189
my $remember_defs_in_file = 1; # True if we're reading input from a file
190
# for which we want to remember function
192
while (defined($_ = <CPP>)) { # Read another line.
193
if (/^\#(?:line)?\s+(?:\d+)\s+\"(\S+?)\"/) {
194
# Switching to a different include file?
195
$1 eq $fname and next; # Skip if from the same file.
196
if ($remember_defs_in_file) { # Supposed to remember definitions we read?
197
parse_str($accum_str); # Parse them.
199
parse_for_typedefs($accum_str); # Just look for typedefs and other
200
# simple things, ignoring function defs.
203
# Try to figure out whether we need to include this file in the wrapper
204
# code or not. Our rule is that if it is a .h file which was included
205
# from the top level .c or .cxx file, then we want to include it in the
206
# wrapper file. Otherwise, it was included by some other .h file and we
207
# don't need to include it explicitly. This may lead to our including
208
# more than we really need to but it's likely to make code that will work.
210
my $last_fname = $fname; # Remember what file we used to be in.
211
$fname = $1; # Remember the new file name.
212
if ($fname =~ /\.[hH]{1,2}$/ && # Is this a .h file?
213
$last_fname !~ /\.[hH]{1,2}$/) { # Last file was a .c or .cxx file?
214
# Then it must have been included at the
215
# top level. Add it to our list.
216
my $incstr = $fname; # Assume we include the file as is.
217
if ($incstr =~ s@^/usr/include/@@ || # Is it a system include file?
218
$incstr =~ s@^/usr/local/include/@@ ||
219
$incstr =~ s@.*/gcc-lib/.*/include/@@) { # Is it a system include
220
# file that was fixed by gcc?
221
$include_str .= "#include <$incstr>\n"; # Use a different syntax.
223
$include_str .= "#include \"$incstr\"\n"; # Include it normally.
227
if ($cpp_ignore_files{$fname} || # An explicitly disqualified file?
228
grep(substr($fname, 0, length($_)) eq $_, @cpp_ignore_dirs) ||
229
# Or does it begin with the list of forbidden
231
$fname =~ m@/gcc-lib/@) { # Somewhere in gcc fixed includes?
232
$remember_defs_in_file = 0; # We're not really interested in this file.
234
$remember_defs_in_file = 1; # This is a file we are actually
237
$accum_str = ''; # Start accumulating from scratch now.
242
close(CPP); # Done with the C preprocessor.
243
($? >> 8) and die("$progname: C preprocessor exited with error status\n");
245
$remember_defs_in_file and parse_str($accum_str);
246
# Parse the remaining stuff.
251
# DEBUG: dump out the definitions.
254
foreach (sort keys %typedef) {
255
print " $_ => $typedef{$_}\n";
258
print "\nVariables:\n";
259
foreach (sort keys %variables) {
260
print " $variables{$_} $_\n"; # Print the type and name.
263
print "\nFunctions:\n";
264
foreach (sort keys %functions) {
265
dump_function(" ", $functions{$_});
268
print "\nClasses:\n";
269
foreach $cls (sort keys %classes) {
271
my $members = $classes{$cls};
272
foreach (sort keys %$members) {
273
if (ref($members->{$_}) eq '') { # Is it a member field?
274
print " $members->{$_} $_;\n"; # Print it as such.
275
} else { # It's a member function:
276
dump_function(" ", $members->{$_});
283
# Now write the output file:
285
$fh = &{"${language}::initialize"}($outfile, \@files, \@ARGV, $include_str);
286
# Initialize the output file.
287
select($fh); # Make the output file be the default file
290
&output_vectorizing_subs; # Output a couple of special C functions for
293
if (%wraponly_classes) { # Only wrapping a few classes?
294
output_class_conversion_func(keys %wraponly_classes);
295
# Only allow inheritance relationships between
297
print &{"${language}::pointer_conversion_functions"}; # We'll need the functions to
299
} elsif (keys %classes) { # Do we know about any classes?
300
output_class_conversion_func(keys %classes); # Handle all inheritance
301
# relationships among all known classes.
302
print &{"${language}::pointer_conversion_functions"}; # We'll need the functions to
306
foreach (sort keys %variables) { # First wrap all the global variables.
307
wrap_variable($variables{$_}, $_, "")
308
if (!%wraponly_globals || $wraponly_globals{$_});
311
foreach (sort keys %functions) { # Now wrap all the global functions.
312
wrap_function($functions{$_})
313
if (!%wraponly_globals || $wraponly_globals{$_});
317
# Now wrap all the classes:
319
foreach $cls (sort keys %classes) {
320
if (!defined($wraponly_classes) || # Wrap all classes?
321
defined($wraponly_classes->{$cls})) { # Supposed to wrap this class?
322
my $members = $classes{$cls}; # Access member table.
323
foreach (sort keys %$members) { # Look at each member:
324
if (ref($members->{$_}) eq '') { # Is it a member field?
325
wrap_variable($members->{$_}, $_, $cls); # Wrap as a variable.
326
} else { # It's a member function:
327
wrap_function($members->{$_}); # Wrap it appropriately.
333
&{"${language}::finish"}(); # We're done!
335
###############################################################################
337
# Code to parse the input files:
341
# Just extract the typedefs from a string. Arguments:
345
# New types may be added to the %typedefs array.
347
# Function and variable definitions are ignored.
349
sub parse_for_typedefs {
350
local ($_) = @_; # Access the argument.
352
s{\\[\0-\377]}{}g; # Delete all backslash escapes.
354
s{/\* [\0-\377]*? \*/ | # Old C-style comment.
355
//.* | # New C++ style comments.
356
\" .*? \" | # Double quoted string.
357
\' .*? \' # Single quoted string.
358
}{}xg; # Delete comments and quoted strings.
360
s/\bextern\s*\"[^\"]*\"//g; # Remove all the "extern "C"" declarations.
361
# Note that this will leave an extra trailing
362
# brace. I don't care.
363
1 while s{\{[^\{\}]*\}}{}g; # Now remove expressions in braces.
365
s{\b(?:struct|class)\s+(\w+)}{
366
# Pick out all the "class xyz", "struct xyz",
367
# and "typedef struct {} xyz" declarations.
368
$typedef{$1} ||= $1; # Call these a fundamental type from now on,
369
# unless we already knew a different name for
371
""; # Delete the typedef.
374
s{\btypedef\s+(\w[\w<>\*\[\]\&\s]*?)\s*\b(\w+)\s*;}{ # Find a typedef.
375
$typedef{$2} = canonicalize_type($1, 1); # Remember it.
381
# Handle all the definitions contained in a string. Arguments:
384
# Side effects: adds entries to the following arrays:
385
# $variables{name} Contains type of variable.
386
# $functions{name} Points to an array containing (as element 0)
387
# the return type of the function, and
388
# (as elements 1-n) type types of its arguments.
389
# $classes{name} Points to an associative array containing
390
# the member functions and their types, encoded
391
# like the elements of the $function array.
394
local ($_) = @_; # Access the argument.
396
# Replace all things that could confuse a simple-minded parser by a tag.
397
# We want to make sure that our brace and parenthesis matching is accurate,
398
# so we remove all comments and quoted strings. This is a little tricky
399
# to do accurately because there could be quotes inside of comments or
400
# (partial) comments inside of quoted strings. We also should handle \" and
401
# \' properly. The algorithm for doing this is:
402
# 1) Remove all backslash escapes.
403
# 2) Remove all comments and quoted strings at once using an ugly and
404
# slow regular expression (which seems to work).
405
# Comments and quoted strings are removed and are replaced by a tag value which
406
# is just some binary characters surrounding a number. The number is the
407
# index into the array where we stored the string.
409
s@//(%\w+)@\n$1@g; # Convert //%input into %input. This allows
410
# declarations to be put into C files.
411
s{\\[\0-\377]}{push(@strings, $&); # First remove all backslash escapes.
412
"\01$#strings\02"; }eg; # Leave a tag.
414
s{/\* [\0-\377]*? \*/ | # Old C-style comment.
415
//.* (?:\n[ \t]*//.*)* | # Several lines of new C++ style comments.
416
\" .*? \" | # Double quoted string.
417
\' .*? \' # Single quoted string.
419
if (substr($&, 0, 1) eq '/') { # Was this a comment?
420
# push(@comments, $&); # Save it.
421
# "\03$#comments\04"; # Leave the tag.
422
""; # Strip out the comments.
423
} else { # No, it must have been a string.
424
push(@strings, $&); # Save it in a different place.
425
"\01$#strings\02"; # Leave a different tag.
429
s{%novectorize_type\s+(.*)}{ # Any types we're not supposed to vectorize?
430
my @types = map(canonicalize_type($_), split(',', $1));
432
@novectorize_types{@types} = (1) x (@types); # Mark these types as used.
433
''; # Replace the %novectorize_type declaration
437
# Now pull out all expressions in braces. This has to be done in several
438
# scans so we handle nested braces. Because we have protected comments
439
# and quoted strings, there shouldn't be any problem with braces inside
442
s/\bextern\s+\01\d+\02\s*\{?//g; # Remove all the "extern "C"" declarations.
443
# (We don't have to worry about these; the
444
# C++ compiler will handle them. Note that
445
# this may leave an extra brace. I don't care.
446
1 while s{\{[^\{\}]*\}}{ # Now remove expressions in braces.
447
push(@brace_strs, $&); # Save the expression.n
448
"\05$#brace_strs\06"; # Replace it by a tag.
449
}eg; # This has to be done in a loop because we
450
# remove the innermost braces first, followed
452
s{ template \s+ <.*?> .*?[;\06] }{}xg; # Strip out template definitions.
453
s{__attribute__.*?([;\06])}{$1}g; # Strip out attribute declarations.
455
# At this point we have parsed the file so that all comments and expressions
456
# of braces have been removed. Now go through sequentially and try to parse
457
# all #defines, typedefs, etc.
459
# Currently we only handle simple typedefs, where the type name is the last
460
# expression before the semicolon. Maybe later we'll handle function and
463
s/^\s*\#.*\n//mg; # Remove all preprocessor directives.
464
s{\btypedef\s+(\w[\w<>\s\*\&]+?)(\w+)\s*;}{
465
$typedef{$2} = canonicalize_type($1); # Store the type name.
466
""; # Remove the typedef from the file.
469
s{\b(?:class|struct|typedef\s+struct\s+\05\d+\06)\s+(\w+)\s*;}{
470
$typedef{$1} or # Do we already know of this type?
471
$typedef{$1} = $1; # Remember that we know this type.
472
""; # Delete the definition.
473
}eg; # Strip out forward class definitions.
476
# Look for variable definitions:
479
(^|[;\06]) # Match beginning of statement (end of last).
481
(\w[\w<>\s\*\&]+?) # The type of the variable.
482
([\w:]+(?:\s*,\s*\w+)*)\s* # The name of the variable(s).
483
(?:=[^;]+)? # An optional assignment expression.
484
; # The final semicolon.
487
my $orig_type = $2; # Remember the original type.
488
my @vars = split(/\s*,\s*/, $3); # Get a list of variables.
489
if (!defined($wraponly_globals) || # Are we supposed to wrap any of these
490
grep($wraponly_globals->{$_}, @vars)) { # variables?
491
my $type = canonicalize_type($orig_type); # Get the type.
493
unless ($type =~ /^static /) { # Skip static variables.
494
foreach (@vars) { # Look at each variable:
495
next if /:/; # Skip static member data, since these will
496
# be handled when we see the class definition.
497
$variables{$_} = $type; # Remember the variable.
502
$delim; # Remove the whole definition.
506
# Look for function declarations:
509
(?:^|\G|[;\}\06]) # Match beginning of statement (end of last).
510
\s* # Whitespace between statements.
511
(\w[\w<>\s\*\&]*?)? # The return type of the function.
512
(\w+)\s* # The name of the function.
513
# Note that this does not match member
514
# functions, whose prototypes are given in
515
# the class declaration.
516
\(([:<>\w\s\*\&,]*)\)\s* # The function arguments.
517
(?:; | # The trailing semicolon, for a prototype.
518
\05\d+\06)\s* # The body of the function.
519
((?:\s*%.*\n)+)? # Any additional modifiers.
522
if (!defined($wraponly_globals) || # Wrap all functions?
523
defined($wraponly_globals->{$2})) { # This is a function we want?
525
($fdef, $fname) = parse_function($1, "", $2, $3, split(/\n\s*/, $4 || ""));
526
# Parse the function definition.
528
if ($@) { # Was there an error?
529
print STDERR "$progname: error parsing definition of $1 $2:\n$@\n";
531
defined($fdef) and $functions{$fname} = $fdef;
532
# If it wasn't a static function, remember it.
535
''; # Just remove the whole statement.
539
# Look for class or structure definitions:
542
(?:^|\G|[;\06]) # End of last statement.
543
\s* # Whitespace separating statements.
544
(class|struct) \s+ (\w+) \s* # The name of the class.
545
(:[\w\s,]+)? # The inheritance list.
546
\05(\d+)\06 \s* # The body of the class definition.
547
; # The trailing semicolon.
549
parse_class($1, $2, $3, $brace_strs[$4]); # Parse the class definition.
550
# We parse the class definition even if
551
# it was not specified in a -wraponly
552
# declaration, because some other listed class
553
# may inherit from it.
554
''; # Just remove the whole statement.
558
# Strip out member function definitions, so we don't give bogus error messages:
561
(?:^|\G|[;\06]) # End of last statement.
562
\s* # Whitespace separating statements.
563
(?:[\w\s\*\&]+?) # The return type of the function.
564
(?:\w+::\~?\w+)\s* # The name of the function.
565
\((?:[:\w\s\*\&,]*)\)\s* # The function arguments.
566
(?:const\s*)? # An optional const modifier.
567
(?:; | # The trailing semicolon, for a prototype.
568
\05\d+\06) # The body of the function.
572
if (/\w/) { # Some non-punctuation that we didn't recognize?
573
s/(?:[ \t]*\n)+/\n/g; # Collapse multiple newlines into 1.
574
s/\05\d+\06/{ ... }/g; # Put braces back in understandable form.
575
1 while s/\01(\d+)\02/$strings[$1]/g; # Put quoted strings back too.
576
die "Warning: unrecognized text:\n$_\n";
581
# Parse a function prototype. Arguments:
582
# 1) The return type of the function.
583
# 2) The class of the function.
584
# 3) The name of the function.
585
# 4) The argument list for the function (not including the THIS argument for
587
# 5-n) Additional declarations (%input, etc.), if any.
589
# Returns a reference to the %function_def array appropriate to this function.
590
# Returns undef if it was a static function.
592
# Also returns the name of the function, which will be different from the name
593
# passed if there was a %name directive.
596
my ($ftype, $class, $fname, $arglist, @addl_decls) = @_;
597
# Access the arguments.
599
$ftype = canonicalize_type($ftype); # Get the type of the function.
600
my $static_flag = ($ftype =~ s/\bstatic\s*//); # Is the function static?
601
# (This also removes "static" from the type.)
602
$static_flag and $class eq '' and return undef;
603
# Don't try to make an entry for static
604
# functions since we can't access them
607
# Process the argument list. First, we pretty up the list of printable
608
# arguments, and then we convert that to our internal types.
610
$arglist =~ s/^\s*void\s*$//; # Change argument of "void" to "".
611
if ($arglist =~ /[\(\)]/) { # Does it have stuff we don't understand?
612
warn("$progname: function pointers and other complex types not accepted
613
in definition of function $fname, arglist $arglist\n");
614
return undef; # Skip this function.
616
my @args = split(/,/, $arglist); # Access the argument list.
618
$class and !$static_flag and # If this is a non-static member function,
619
unshift(@args, "$class *THIS"); # pass the class pointer as the first
621
$ftype ne 'void' and # Pretend the return value is the first
622
unshift(@args, "$ftype retval"); # argument for the moment. We'll take
625
my @canon_args = map { canonicalize_type($_) } @args;
626
# Get the canonical types.
628
# Try to infer as much of the rest of the definition as possible. We can
629
# infer everything if there are no pointer or reference types.
631
# First give names to all arguments that don't have any:
633
my $script_name; # The name of the function in the scripting
634
# language, if different.
635
my $vectorize; # Whether or not to vectorize this function.
637
my @argnames = map { # Get names for each argument to C function.
638
(($args[$_] =~ /(\w+)\s*(?:=|$)/ && # Take last word in type as
639
!exists($typedef{$1})) ? # arg name if it's not a type.
640
$1 : # Use the name if it was there.
641
"_arg$_"); # Generate a name for the argument.
642
} 0..(@args-1); # Get the specified names for each argument.
644
my %args; # This array will become the "args" field of
645
# the %function_def array.
647
# Process the argument declarations:
650
foreach $argidx (0 .. (@argnames-1)) {
651
my $argname = $argnames[$argidx]; # Access the argument name.
652
my $argtype = $canon_args[$argidx]; # Access its type.
654
my $decl = ($args{$argname} = {}); # Create a declaration for this arg.
656
$decl->{vectorize} = !$novectorize_types{$argtype};
657
# Vectorize unless this type is not supposed to
658
# be vectorized. (We may turn off the
659
# vectorize flag for several reasons below.)
660
$decl->{c_var_name} = "_arg_$argname"; # Generate a unique name.
661
# Default to passing by value.
663
$decl->{type} = $argtype; # Remember the type.
664
$argtype =~ s/\bconst\b\s*//g; # Strip out const to avoid multiplicities of
667
$argtype =~ s/ ?\&$//; # Strip off passsing by C++ reference.
669
# If there's an extra '*' on the end of a type we recognize, we assume that
670
# we pass it by reference and put a & in front of the variable.
672
if ($argtype =~ /^(.*?)\s*\*$/ && $argtype ne 'char *' && # Is this a pointer?
673
is_basic_type($1)) { # And it's not a structure?
674
$argtype = $1; # Strip off the trailing *.
675
$decl->{pass_by_pointer_reference} = 1; # Remember to put & in front of
678
$decl->{pass_by_pointer_reference} = 0; # Don't put & in front of call.
681
$decl->{basic_type} = $argtype; # Store the modified type.
685
$args{'retval'}{source} = 'output'; # "retval" is always an output var.
687
# Look at the additional declarations and convert things like
688
# %input x(a,b), y(a,b)
689
# into two separate declarations:
693
@paren_expr = (); # No parenthesized subexpressions known yet.
694
# Note that this is a global variable, because
695
# it's used in parse_dimension_decl.
697
foreach (@addl_decls) {
698
1 while s{(\([^()]*\))}{ # Get rid of parenthesized sub-expressions
699
# since they can cause problems.
700
push(@paren_expr, $1); # Save the parenthesized expression.
701
"\01$#paren_expr\02"; }eg; # Replace it with a tag.
703
# Convert "%input x(a), y" into two
704
# separate declaraions, "%input x(a)" and
706
push(@decl_copy, "%$1 $2")
707
while (s/^\s*\%\s*(input|modify|output)\s+(\w+(?:\s*\01\d+\02)?)\s*,\s*(.*)/%$1 $3/);
708
push(@decl_copy, $_); # Save what's left.
711
# Now parse all of the % declarations:
713
foreach (@decl_copy) {
714
if (/^\s*%\s*(input|modify|output)\s+(\w+)(?:\s*\01(\d+)\02)?\s*$/) { # Input argument?
715
my $arg = $args{$2}; # Point to the argument description.
717
die("In definition of ${class}::$fname:\n Illegal argument name $2\n");
719
die("In definition of ${class}::$fname:\n Illegal reuse of argument $2\n");
720
$arg->{source} = $1; # Remember the variable type.
721
if (defined($3)) { # Is this a vector?
722
$arg->{dimension} = parse_dimension_decl($paren_expr[$3], \%args);
723
$arg->{basic_type} =~ s/\s*\*$//
724
# If this was declared as a pointer, change
725
# the basic type by taking off a '*'. Thus
726
# char * goes into char, and float ** goes
728
unless $arg->{pass_by_pointer_reference};
729
# If we already marked it to pass by reference,
730
# then we already took off the '*'.
732
elsif ($2 ne 'retval' && # Can't alter the type of retval.
733
$1 ne 'input' && # Is this a modify/output variable and it's
734
substr($args{$2}{basic_type}, -1) eq '*' && # being passed as a
735
# pointer? E.g., char * when passed as modify
736
# output should have a basic type of char.
737
!$arg->{pass_pointer_by_reference}) {
738
# We didn't already strip off the '*'?
739
$arg->{pass_by_pointer_reference} = 1; # Pass a reference.
740
$arg->{basic_type} =~ s/\s*\*//; # Strip off the *.
743
elsif (/^\s*%\s*name\s+(\w+)\s*$/) { # Name of function in scripting language?
744
$script_name = $1; # Remember that.
745
} elsif (/^\s*%\s*(no)?vectorize\s*$/) { # Vectorize or not?
746
$vectorize = !defined($1); # Remember the value.
747
} elsif (/^\s*%\s*nowrap\s*$/) { # Don't wrap this function?
748
return undef; # Quit now.
749
} elsif (/^\s*%\s*name\s+(\w+)\s*$/) { # Change the name of the function:
750
$fname = $1; # Remember the new name.
752
1 while s/\01(\d+)\02/$paren_expr[$1]/; # Put all the parenthesized
753
# sub-expressions back to print it out properly.
754
die("In definition of function ${class}::$fname:
755
unrecognized declaration $_\n");
760
# Now for each of the input/modify variables whose dimension is given by
761
# a C expression, see if we can find a way to compute the variable in the
762
# expression. If so, we can eliminate the dimension variable from the
765
foreach $argname (@argnames) {
766
my $arg = $args{$argname}; # Get this argument.
767
$arg->{source} ||= 'input'; # Make all unspecified arguments input args.
768
$arg->{dimension} ||= []; # Default to a dimensionless variable.
770
next unless @{$arg->{dimension}}; # Skip if not an array argument.
771
$arg->{pass_by_pointer_reference} = 0; # If it's an array argument, we
774
next unless ($arg->{source} eq 'input' || # Skip if not an argument whose
775
$arg->{source} eq 'modify'); # value we are given.
778
foreach (@{$arg->{dimension}}) { # Look at the expression for each dimension.
780
# See if we can invert this expression to determine the value of a
781
# dimensional variable. If so, then we can remove the argument from the
784
# We can only invert simple arithmetic expressions, i.e., things in which
785
# only one argument is present, and which are of the form
791
# Expressions may not be substituted for the '1' and '2', though any other
794
# Other forms we can't handle, so we require that the value be specified.
796
if (/^_arg_(\w+)$/) { # Just the argument word by itself?
797
$args{$1}{calculate} = "dim($argname, $dimidx)";
798
$args{$1}{source} = 'dimension'; # Mark as a dimensional variable.
799
} elsif (/^_arg_(\w+)\s*([-+])\s*(\d+)$/) { # First or second form?
800
$args{$1}{calculate} ||= "dim($argname, $dimidx)" .
801
($2 eq '-' ? '+' : '-') . $3;
802
$args{$1}{source} = 'dimension'; # Mark as a dimensional variable.
803
} elsif (/^(\d+)\s*\*\s*_arg_(\w+)$/) { # Simple multiplication?
804
$args{$2}{calculate} ||= "dim($argname, $dimidx)/$1";
805
$args{$2}{source} = 'dimension'; # Mark as a dimensional variable.
806
} elsif (/^(\d+)\s*\*\s*_arg_(\w+)\s*([-+])\s*\d+$/) {
807
$args{$2}{calculate} ||= "(dim($argname, $dimidx)" .
808
($3 eq '-' ? '+' : '-') . "$4)/$1";
809
$args{$2}{source} = 'dimension'; # Mark as a dimensional variable.
816
# Now form the list of input/output/modify arguments in order, removing
817
# dimensional arguments:
819
my (@inputs, @modifies, @outputs); # Array of argument names that will be
820
# the input/modify/output variables.
822
foreach $argname (@argnames) {
823
next if exists($args{$argname}{calculate}); # Do we know how to calculate
824
# this variable from the others?
825
if ($args{$argname}{source} =~ /^input|dimension$/) {
826
# It will be 'dimension' if this is an argument
827
# that specifies another argument's dimension
828
# but we couldn't actually calculate the
829
# argument because the expression wasn't
830
# invertible, e.g., %input a((b > 0) ? b : -b)
831
# defines b as a dimensional variable but
832
# b cannot be calculated so it must be
833
# explicitly specified.
834
push(@inputs, $argname);
835
} elsif ($args{$argname}{source} eq 'modify') {
836
push(@modifies, $argname);
837
} elsif ($args{$argname}{source} eq 'output') {
838
push(@outputs, $argname);
840
die("internal error, invalid argument source '$args{$argname}{source}'");
844
if ($ftype ne 'void') { # Was there a return type?
845
shift(@argnames); # Remove the return value from the argument
846
shift(@canon_args); # list since it is handled separately.
849
unless (defined($vectorize)) { # Did we get a %(no)vectorize?
850
if ((@outputs != 0 && @inputs != 0 || @modifies != 0) &&
851
# Don't try to vectorize it if there aren't
852
# any output arguments or any input args.
853
grep($_->{source} ne 'output' && $_->{vectorize} != 0, values %args)) {
854
# Don't try to vectorize this function if
855
# none of its arguments can be vectorized.
862
if (!$vectorize) { # Not vectorizing this function?
863
foreach $arg (values %args) {
864
$arg->{vectorize} = 0; # Mark each of the arguments as not vectorized.
869
# Now we've generated all the pieces for the %function_def array. Fill in
874
script_name => $script_name,
875
static => $static_flag,
877
modifies => \@modifies,
878
outputs => \@outputs,
881
argnames => \@argnames,
882
vectorize => $vectorize
889
# The following subroutine parses a dimension declaration, e.g.,
890
# %output varname(dim1, dim2)
892
# 1) The dimension string (including parentheses).
893
# 2) A reference to an associative array where we store the names of dimension
896
# Returns: a reference to a list which will become the "dimension" field
897
# of the "args" subfield of the %function_def array, i.e.,
899
# where dim1 and dim2 are expressions which are the dimensional values.
900
# These expressions may contain the parameter names or other C expressions.
901
# The parameter names are substituted to their C equivalents, and any
902
# arguments which appear in them are declared not vectorized.
904
# Global variable inputs: @paren_expr contains all parenthesized expressions
905
# that were removed to facilitate parsing.
907
sub parse_dimension_decl {
908
my ($dimstr, $args) = @_; # Name the arguments.
910
$dimstr =~ s/^\((.*)\)$/$1/; # Strip the parentheses.
912
my @dims = split(/,/, $dimstr || ""); # Split into components.
915
1 while s/\01(\d+)\02/$paren_expr[$1]/; # Replace parenthesized
916
# expressions; now commas in parentheses can't
917
# hurt us since we've already done the split.
918
s/^\s+//; # Remove leading whitespace.
919
s/\s+$//; # Remove trailing whitespace.
921
# Find any parameter names in this dimension declaration.
923
my @expr_tokens = split(/(\W+)/, $_); # Split it on non-words (operators),
924
# but put the operators into the array.
926
my $n_params = 0; # The number of parameters that were contained
927
# in this expression.
928
for ($idx = 0; $idx < @expr_tokens; ++$idx) { # Look at each token:
929
my $arg = $args->{$expr_tokens[$idx]}; # See if this word is in the
931
next unless defined($arg); # Skip if it's an operator or some other
933
$arg->{vectorize} = 0; # This argument may not be vectorized, since
934
# it determines the dimensions of other args.
935
$arg->{source} = 'dimension'; # Remember this is a dimension variable.
936
$expr_tokens[$idx] = $arg->{c_var_name};
937
# Replace it in the expression so that we
938
# know how to do the dimension checking.
940
if (@expr_tokens == 1) { # Only one thing?
941
$_ = $expr_tokens[0]; # Put it back (in case we changed it).
943
$_ = '(' . join('', @expr_tokens) . ')'; # Put the expression in
951
# The following subroutine parses a class definition. Arguments:
952
# 1) "class" or "struct" (so we know what's private and public).
953
# 2) The name of the class.
954
# 3) The inheritance list (with a leading colon).
955
# 4) The body of the function.
957
# Fills out the following global variables:
958
# $classes{name} Points to an associative array containing
959
# the member functions and their types. Each
960
# entry is a list where the first element is
961
# the type of the function and the remaining
962
# elements are the types of its arguments.
965
my ($class_struct, $classname, $inh_list, $class_def) = @_;
966
# Name the arguments.
967
local ($_); # Don't mess up caller's $_.
969
my %members; # Where we store member function info.
970
if ($typedef{$classname}) { # Is another name already known for this
971
$classname = $typedef{$classname}; # class? Change the name if so.
973
$classes{$classname} = \%members; # Make a null associative array.
974
$typedef{$classname} = $classname; # Remember that we know of this type.
975
$derived_classes{$classname} = []; # Currently this class is not a base class
978
# First parse the inheritance list. Note that since we're parsing classes
979
# in the same order that the C++ compiler sees them, all the preceding
980
# classes should be defined.
982
if (defined($inh_list)) { # Is there an inheritance list?
983
my @base_classes = split(/\s*,\s*/, substr($inh_list, 1)); # Extract them.
984
# The substr skips the leading colon.
985
foreach (@base_classes) {
986
s/^\s+//; # Strip leading spaces.
987
s/\s+$//; # Strip trailing spaces.
988
s/\s*virtual\s+//; # Remove the virtual keyword.
989
next if /^private\b/ || /^protected\b/;
990
# Not interested in protected members.
992
s/^public\s+// or # public not explicitly specified?
993
$class_struct = 'struct' # public is assumed if a struct.
994
or next; # Skip it--it's private.
996
unless (defined($derived_classes{$_})) { # Do we understand this base class?
997
warn("$progname: warning: in class $classname
998
I don't understand base class $_, skipping its member functions\n");
999
next; # Skip this class.
1001
push(@{$derived_classes{$_}}, $classname); # Remember that this class is
1002
# derived from this base class.
1007
# Now we've dealt with the inheritance. Parse this class. First get rid
1008
# of all the private and protected members:
1010
$_ = $class_def; # Access the class definition.
1011
$class_struct eq 'class' and
1012
$_ = "; private: $_"; # Everything in a class is private up until
1013
# the first "public:" declaration. Note that
1014
# we put a semicolon in so we can anchor
1016
my $private_members = ''; # No private members known yet.
1018
1 while s{\b(?:private|protected):(.*?)\bpublic:}{
1019
$private_members .= $1; # Remember the private members.
1021
}esg; # Delete everything between any
1022
# private: and public:. The loop is necessary
1023
# to handle a sequence like
1024
# protected: private: public:; the first
1025
# iteration will turn it into protected:public:
1026
# and the second will eliminate the protected
1028
s{\b(?:private|protected):(.*)}{
1029
$private_members .= $1;
1031
}es; # Delete everything after the last private:
1033
s/\bpublic://g; # Strip out any extra public: declarations.
1035
# Now parse the member functions of the class. At this point we know that the
1036
# body of the class begins with ";" or "{".
1038
1 while s/([\{;\06])\s*typedef\s.*?;/$1/g; # Remove any typedefs.
1039
1 while s/([\{;\06])\s*(class|struct).*?[;\06]/$1/g;
1040
# Remove any nested classes.
1041
1 while s/([\{;\06])\s*friend\s.*?;/$1/g; # Remove any friends.
1042
1 while s/([\{;\06])[^;\06]*\boperator\b[^;\06]*[;\06]/$1/g;
1043
# Remove any definition of operators.
1046
([\{;\06]) # Match beginning of statement (end of last).
1047
# (Note that we stuck a semicolon at the
1048
# beginning so this will work even for the
1049
# first definition.)
1050
\s* # Whitespace between statements.
1051
([<>\w\s\*\&]*?)? # The return type of the function.
1052
(\~?\w+)\s* # The name of the function.
1053
# Note that this does not match member
1054
# functions, whose prototypes are given in
1055
# the class declaration.
1056
\(([^\)\(]*)\)\s* # The function arguments.
1057
(?:const\s*)? # Optional const qualifier.
1058
(?::[^;\05]+)? # Initializers (for constructors).
1059
(?:; | # The trailing semicolon, for a prototype.
1060
\05\d+\06)\s* # The body of the function.
1061
((?:%.*\n\s*)+)? # Any additional modifiers.
1063
my ($funcname, $functype) = ($3, $2);
1064
if ($funcname eq $classname) { # Is this a constructor?
1065
$funcname = "new"; # Change it to the new function.
1066
$functype = "static $classname *THIS"; # Change the return type.
1068
elsif ($funcname eq "~$classname") { # Is this a destructor?
1069
$funcname = "delete"; # Change its name
1070
$functype = "void"; # and its return type.
1074
($fdef, $funcname) = parse_function($functype, $classname, $funcname, $4,
1075
split(/\n\s*/, $5 || "")); # Parse it.
1077
if ($@) { # Was there an error?
1078
print STDERR "$progname: error parsing definition of $functype ${classname}::$funcname:\n$@\n";
1080
defined($fdef) and $members{$funcname} = $fdef; # Remember definition
1081
# unless it was marked nowrap.
1083
$1; # Remove the member function definition.
1087
# Parse member fields:
1090
([\{;\06]) # Match beginning of statement (end of last).
1092
([\w\s\*\&]+?) # The type of the variable.
1093
(\w+(?:\s*,\s*\w+)*)\s* # The name of the variable(s).
1094
(?:=[^;]+)? # An optional assignment expression.
1095
; # The final semicolon.
1098
my $type = canonicalize_type($2);
1099
foreach (split(/\s*,\s*/, $3)) { # Look at each variable.
1100
$members{$_} = $type; # Remember this type.
1102
$delim; # Remove the whole definition.
1105
/\w/ and print STDERR "Warning: unrecognized text in definition of class $classname:\n$_\n";
1108
# Add a new and a delete to this class if there isn't one, because that's the
1109
# only way to create and destroy members of the class:
1111
unless ($members{"new"} || # Already a new function?
1112
$private_members =~ /\b$classname\s*\(/) { # Constructor is private?
1113
$members{"new"} = (parse_function("static $classname *", $classname, "new",""))[0];
1116
unless ($members{"delete"} || # Already a delete function?
1117
$private_members =~ /\~$classname\s*\(/) { # Destructor is private?
1118
$members{"delete"} = (parse_function("void", $classname, "delete", ""))[0];
1123
# The following function is called to convert a type into a canonical format.
1124
# It handles typedefs and puts the '*' and '&' in the appropriate locations.
1126
# 1) The type name to canonicalize.
1127
# 2) True if unrecognized words should be understood as builtin types that we
1130
sub canonicalize_type {
1131
my ($type, $new_type_flag) = @_; # Access the argument.
1134
$type =~ s/=.*//; # A default value can be specified, and we
1136
if ($new_type_flag) { # Add unrecognized words to the basic type list?
1137
$type =~ s{\w+}{$typedef{$&} ||= $&}eg;
1139
$type =~ s{\w+}{$typedef{$&} || ''}eg; # Translate the typedefs, and delete
1140
# any words that we don't care about, like
1141
# 'inline', or function arguments names.
1144
$type =~ s/\[\]/\*/; # Convert float[] into float *.
1145
$type =~ s/</ < /g; # Put a space after template brackets.
1147
$type =~ s/\s+/ /g; # Convert whitespace into spaces.
1148
$type =~ s/^ //; # Strip leading whitespace.
1149
$type =~ s/ $//; # Strip trailing whitespace.
1150
$type =~ s/ ([\*\&])/$1/g; # Remove spaces between '*' and '&'.
1151
$type =~ s/[\*\&]/ $&/; # Put a space before the first one.
1153
$oldval =~ s/\s+/ /g; # Pretty-print the type.
1154
die("unrecognized type '$oldval'\n");
1157
# print STDERR "Canonicalizing $oldval => $type\n";
1162
# Dump out the definition of a function (for debug purposes). Arguments:
1163
# 1) A string used to prefix each line so the indentation looks right.
1164
# 2) The %function_def array.
1167
my ($indent_str, $faa) = @_; # Name the arguments.
1169
printf("%s%s%s %s::%s(%s)\n", $indent_str, $faa->{static} ? "static " : "",
1170
$faa->{returns}, $faa->{class}, $faa->{name},
1172
map({ $faa->{args}{$_}{type} . " " . $_ } @{$faa->{argnames}})));
1173
# Print out the C++ function prototype.
1174
printf("%s [%s] = %s(%s)\n", $indent_str,
1175
join(", ", @{$faa->{outputs}}, @{$faa->{modifies}}),
1176
$faa->{script_name} || ($faa->{class} ? $faa->{class} . "_" : "" ) . $faa->{name},
1177
join(", ", @{$faa->{inputs}}));
1178
# Print out the scripting language prototype.
1180
foreach (@{$faa->{outputs}}, @{$faa->{modifies}}, @{$faa->{inputs}}) {
1181
printf("%s %s %s: basic type = %s, vectorize = %d, dimension = [%s]\n",
1182
$indent_str, $faa->{args}{$_}{source}, $_,
1183
$faa->{args}{$_}{basic_type},
1184
$faa->{args}{$_}{vectorize},
1185
join(", ", @{$faa->{args}{$_}{dimension}}));
1186
if (exists($faa->{args}{$_}{calculate})) { # A dimension argument?
1187
printf("%s Calculate from %s\n", $indent_str,
1188
$faa->{args}{$_}{calculate});
1192
printf("%s %svectorized\n", $indent_str, $faa->{vectorize} ? "" : "not ");
1196
# Return true if the type is a basic type that can be freely and easily
1200
my ($typename) = @_; # Access the argument.
1202
if ($typename =~ /\*$/) { # Is it a pointer type?
1203
return 1; # Pointers can be freely copied.
1206
foreach (split(' ', $typename)) { # Look at all the words:
1207
return 0 unless exists($basic_types{$_}); # Skip if not a basic type word.
1209
return 1; # It's a basic type.
1212
###############################################################################
1214
# Code to produce the wrappers:
1216
# All subroutines below this point may output C code to the default file handle
1217
# which has been redirected to the appropriate place.
1221
# Output a C++ function which allows a derived class to be substituted for
1222
# a base class in a function argument. This function is called whenver
1223
# the type does not match exactly.
1225
# Arguments to the perl function:
1226
# 1-n) The names of the classes to allow inheritance relationships between.
1227
# Classes outside this list are simply not handled.
1229
sub output_class_conversion_func {
1232
" * Convert between classes, handling inheritance relationships.\n" .
1234
" * 1) The pointer.\n" .
1235
" * 2) The type code for its class.\n" .
1236
" * 3) The type code for the class you want.\n" .
1238
" * Returns 0 if the conversion is illegal, or else returns the\n" .
1239
" * desired pointer.\n" .
1240
" * We assume that you have already verified that the type code does\n".
1241
" * not match, so the only valid possibility is an inheritance\n" .
1242
" * relationship.\n" .
1245
# See if in fact we know about any inheritance relationships:
1247
my $is_inh = 0; # Assume there is no inheritance.
1249
$is_inh = 1, last if @{$derived_classes{$_}} != 0; # Quit if we found one
1250
} # inheritance relationship.
1252
if ($is_inh) { # Is there an inheritance relationship?
1253
print("static void *\n" .
1254
"__cvt_type(void *ptr, unsigned ptr_type, unsigned goal_type)\n" .
1256
" switch (goal_type)\n" . # Look at the class we want:
1257
" {\n"); # Output the function header.
1260
foreach $baseclass (sort @_) { # Look at each of the classes:
1261
my @derived_classes = all_derived_classes($baseclass);
1262
# Get a list of all classes that are derived
1264
next if @derived_classes == 0; # Nothing to do if no one inherits from us.
1266
print (" case @{[pointer_type_code($baseclass . ' *')]}: /* $baseclass */\n" .
1267
" switch (ptr_type)\n" .
1268
" {\n"); # Now look at the type of class we hae.
1271
foreach $derived_class (@derived_classes) {
1272
print(" case @{[pointer_type_code($derived_class . ' *')]}: /* $derived_class */\n" .
1273
" return ($baseclass *)($derived_class *)ptr;\n");
1275
print (" default:\n" .
1276
" return 0;\n" . # Not derived from the goal class.
1279
print(" default:\n" . # Goal class has nothing derived from it.
1285
else { # No inheritance relationships:
1286
print("static void *\n" .
1287
"__cvt_type(void *, unsigned, unsigned)\n" . # Don't list the
1288
"{\n" . # parameter names, because gcc gives warning
1289
" return 0;\n" . # messages about unused parameters.
1295
# Output the functions to set up the arrays for vectorizing.
1297
sub output_vectorizing_subs {
1300
* Check to see if the vectorizing dimensions on an input argument are
1302
* 1) The input argument.
1303
* 2) The number of vectorizing dimensions we have so far. This is updated
1304
* if we add more vectorizing dimensions.
1305
* 3) An array containing the existing vectorizing dimensions.
1306
* 4) The number of explicitly declared dimensions, i.e., 0 if this was
1307
* declared as a scalar, 1 if a vector. We vectorize only the dimensions
1308
* higher than the explicitly declared ones.
1309
* 5) A value which is set to 0 if this argument is not vectorized. This
1310
* value is left unaltered if the argument is vectorized.
1312
* Returns 0 if there was a problem, 1 if the dimensions were ok.
1315
_check_input_vectorize(@{[&{"${language}::arg_declare"}('arg')]},
1316
$dim_type *n_vec_dim,
1317
$dim_type _d[${"${language}::max_dimensions"}],
1318
$dim_type explicit_dims,
1319
$dim_type *vec_stride)
1323
$dim_type n_dims = _n_dims(arg);
1325
if (n_dims > explicit_dims) /* Any additional dimensions? */
1327
if (*n_vec_dim == 0) /* No vectorizing dimensions seen yet? */
1328
{ /* This defines the vectorizing dimensions. */
1329
*n_vec_dim = n_dims - explicit_dims; /* Remember the # of dims. */
1330
for (v_idx = 0; v_idx < ${"${language}::max_dimensions"}-explicit_dims; ++v_idx)
1331
_d[v_idx] = _dim(arg, v_idx+explicit_dims); /* Remember this dim. */
1333
else /* Already had some vectorizing dimensions. */
1334
{ /* These must match exactly. */
1335
for (v_idx = 0; v_idx < ${"${language}::max_dimensions"}-explicit_dims; ++v_idx)
1336
if (_d[v_idx] != _dim(arg, v_idx+explicit_dims)) /* Wrong size? */
1337
return 0; /* Error! */
1340
/* else if (n_dims < explicit_dims) */ /* Too few dimensions? */
1341
/* return 0; */ /* We don't do this check because there's no way to
1342
* distinguish between a vector and a 3x1 matrix. */
1344
*vec_stride = 0; /* Vectorization not required. */
1350
* Same thing except for modify variables. Arguments:
1351
* 1) The input argument.
1352
* 2) The number of vectorizing dimensions we have so far.
1353
* 3) An array containing the existing vectorizing dimensions.
1354
* 4) The number of explicitly declared dimensions, i.e., 0 if this was
1355
* declared as a scalar, 1 if a vector. We vectorize only the dimensions
1356
* higher than the explicitly declared ones.
1357
* 5) A flag indicating whether this is the first modify variable. This
1358
* flag is passed by reference and updated by this subroutine.
1360
* The vectorizing dimensions of modify arguments must exactly match those
1361
* specified for input variables. The difference between this subroutine
1362
* and _check_input_vectorize is that only the first modify variable may
1363
* specify additional vectorizing dimensions.
1365
* Returns 0 if there was a problem, 1 if the dimensions were ok.
1368
_check_modify_vectorize(@{[&{"${language}::arg_declare"}('arg')]},
1369
$dim_type *n_vec_dim,
1370
$dim_type _d[${"${language}::max_dimensions"}],
1371
$dim_type explicit_dims,
1372
int *first_modify_flag)
1376
$dim_type n_dims = _n_dims(arg);
1378
if (n_dims > explicit_dims) /* Any additional dimensions? */
1380
if (*n_vec_dim == 0 && *first_modify_flag) /* No vectorizing dimensions seen yet? */
1381
{ /* This defines the vectorizing dimensions. */
1382
*n_vec_dim = n_dims - explicit_dims; /* Remember the # of dims. */
1383
for (v_idx = 0; v_idx < ${"${language}::max_dimensions"}-explicit_dims; ++v_idx)
1384
_d[v_idx] = _dim(arg, v_idx+explicit_dims); /* Remember this dim. */
1386
else /* Already had some vectorizing dimensions. */
1387
{ /* These must match exactly. */
1388
for (v_idx = 0; v_idx < ${"${language}::max_dimensions"}-explicit_dims; ++v_idx)
1389
if (_d[v_idx] != _dim(arg, v_idx+explicit_dims)) /* Wrong size? */
1390
return 0; /* Error! */
1393
/* else if (n_dims < explicit_dims) */ /* Too few dimensions? */
1394
/* return 0; */ /* We don't do this check because there's no way to
1395
* distinguish between a vector and a 3x1 matrix. */
1397
*first_modify_flag = 0; /* Next modify variable will not be first. */
1404
# Returns a unique type code for a given pointer type. Arguments:
1405
# 1) The type of the pointer.
1407
sub pointer_type_code {
1408
my ($type) = @_; # Name the arguments.
1410
# In order to guarantee that the same type has the same type code even in
1411
# different wrapper files, we just use a hash of the type as the type code.
1412
# It's very unlikely, though possible, that two unrelated types will have the
1413
# same type code. Maybe we'll fix this later.
1416
foreach (split(//, $type)) { # Look at each character.
1417
$hash_code = ($hash_code * 29 + ord($_)) & 0x7ffff;
1418
# This assumes a 32- or 64-bit architecture.
1419
# We used to AND with 0x7fffffff but perl 5.005
1420
# seems to handle integer overflow quite
1421
# differently from 5.004, so that doesn't work
1426
# Try to detect the case where hash codes might conflict, and give a warning:
1428
if (exists($hash_code_to_type{$hash_code})) { # Already seen this one?
1429
if ($hash_code_to_type{$hash_code} ne $type) { # Conflicting types?
1430
unless ($already_warned{$type, $hash_code_to_type{$hash_code}}) {
1431
warn("matwrap: hash codes for type $type and $hash_code_to_type{$hash_code} conflict;\n These types will not be distinguishable.\n");
1432
$already_warned{$type, $hash_code_to_type{$hash_code}} = 1;
1433
# Don't give this warning twice.
1436
} else { # Remember this type to check for future
1437
$hash_code_to_type{$hash_code} = $type; # conflicts.
1444
# The following subroutine returns all classes which are derived from a given
1446
# 1) The name of the class.
1448
# Returns a list of classes as an array.
1450
sub all_derived_classes {
1451
my $class = $_[0]; # Access the argument.
1453
my @derived_classes = @{$derived_classes{$class}}; # Get the classes which
1454
# are immediately derived from that class.
1455
foreach (@{$derived_classes{$class}}) { # Now find what is derived from those.
1456
push(@derived_classes, all_derived_classes($_));
1463
# Wrap a variable or a constant. Arguments:
1464
# 1) The variable type.
1465
# 2) The variable name.
1466
# 3) The class the variable is in. Blank if global.
1469
my ($type, $name, $class) = @_;
1471
if ($type =~ /^\bconst\b/ &&
1472
$type !~ /\*/) { # Is this a constant?
1473
&{"${language}::declare_const"}($name, $class, $type, "");
1475
my $sflag = ($type =~ s/^static //) ? "static " : "";
1478
(parse_function("$sflag$type", $class, "___get_$name", "",
1479
"%name " . ($class ? "${class}_" : "") . "get_$name"))[0];
1480
# The name ___get is treated specially by
1482
wrap_function($fdef); # Wrap it.
1484
$fdef = # Make a set function.
1485
(parse_function("${sflag}void", $class, "___set_$name", "$type newval",
1486
"%name " . ($class ? "${class}_" : "") . "set_$name"))[0];
1487
# The name ___set is treated specially by
1489
wrap_function($fdef); # Wrap it.
1494
# Wrap a function definition. Arguments:
1495
# 1) The %function_def array for this function.
1498
my $faa = bless $_[0], $language; # Access the argument.
1499
# Bless it into the language class so we
1500
# can access functions whose first argument
1501
# is this array using member function syntax.
1502
my $retstr; # Where we accumulate the C code. We don't
1503
# output the C code immediately because
1504
# if the language module die()'s during
1505
# execution of this function, we want to
1506
# skip it and move to the next.
1507
my $args = $faa->{args}; # Argument definitions.
1510
eval { # Protect from die:
1511
$retstr = $faa->function_start(); # Begin the function declaration.
1514
# Figure out whether we can vectorize this function. It may be tagged to
1515
# vectorize, but if all arguments are either dimensional arguments or
1516
# tensors of the maximum dimension, then we can't vectorize it. (For example,
1517
# this would be the case in octave for a function that takes only full
1518
# matrix arguments.)
1520
my $max_dimensions = 0; # Assume we won't be able to vectorize.
1521
if ($faa->{vectorize}) { # Supposed to vectorize this function?
1522
foreach $argname (@{$faa->{inputs}}, @{$faa->{modifies}}) {
1523
# Look at the arguments to make
1524
# sure we can actually vectorize this many
1526
$arg = $faa->{args}{$argname};
1527
next unless $arg->{vectorize}; # Ignore non-vectorizable arguments.
1528
if (@{$arg->{dimension}} < ${"${language}::max_dimensions"}) { # Room to vectorize here?
1529
$max_dimensions = ${"${language}::max_dimensions"};
1530
# Turn on the vectorizing.
1531
last; # Other arguments are irrelevant for maximum
1532
# vectorizing dimension.
1535
foreach $argname (@{$faa->{outputs}}) { # Make sure the outputs don't
1536
$arg = $faa->{args}{$argname}; # have too high dimension.
1537
if ($arg->{vectorize} == 0 || # Not able to vectorize this?
1538
@{$arg->{dimension}} >= ${"${language}::max_dimensions"}) {
1539
$max_dimensions = 0; # Too many output dimensions--no room for
1540
last; # vectorization.
1546
# Try to declare all variables at the top so this has a chance of working
1547
# with a C compiler as well as a C++ compiler.
1549
if ($max_dimensions) { # Are we vectorizing?
1550
$retstr .= " $dim_type _d[$max_dimensions] = { " . # Allocate space for
1551
join(",", (1) x $max_dimensions) . " };\n"; # dimensions.
1552
$retstr .= " $dim_type _vec_n = 0;\n"; # The number of vectorizing dims.
1553
$retstr .= " $dim_type _vidx;\n"; # An index we use in various places.
1554
$retstr .= " $dim_type _vec_sz;\n"; # The product of the vectorized
1556
$retstr .= " int first_modify_flag = 1;\n" # Add the modify flag if
1557
if (@{$faa->{modifies}}); # there are any modify arguments.
1560
foreach $argname (@{$faa->{argnames}}, # Look at the arguments.
1561
($faa->{returns} eq 'void' ? () : ("retval"))) {
1562
# Also include the return value here.
1563
# Declare space to hold argument values
1564
# and the return from the function, if there
1566
$arg = $faa->{args}{$argname};
1567
if ($arg->{vectorize} && $max_dimensions || # Is this argument supposed to be vectorized?
1568
@{$arg->{dimension}}) { # Is it an array?
1569
$retstr .= " $arg->{basic_type} *$arg->{c_var_name};\n"; # Pointer.
1571
$retstr .= " $arg->{basic_type} $arg->{c_var_name};\n"; # Scalar.
1576
# Calculate all of the dimensional arguments:
1578
my (%dims_calculated, %dimvar);
1579
foreach $arg (grep(exists($_->{calculate}), values %$args)) {
1580
my $calc_str = "($arg->{calculate})"; # Put the string in parentheses.
1581
$calc_str =~ s{dim\((\w+), (\d+)\)}{
1582
$dims_calculated{$1, $2} = 1; # Remember that we got this dim.
1583
$dimvar{$1} = 1; # We handled this dimension.
1584
$faa->get_size($1, $2); # Replace dim(varname, n) with the appropriate
1585
}eg; # C expression to get the dimension.
1587
$retstr .= " $arg->{c_var_name} = $calc_str;\n";
1588
# Set the value of this dimensional variable.
1592
# Now calculate any other arguments which are used as dimensional indices
1593
# but we could not calculate from the given dimensions.
1595
foreach $argname (grep($args->{$_}{source} eq 'dimension' &&
1596
!defined($dimvar{$_}), @{$faa->{inputs}})) {
1597
$retstr .= $faa->get_c_arg_scalar($argname); # Get this argument value.
1598
$dimvar{$argname} = 1; # Remember that we got this one.
1601
# Declare the vectorizing "stride". Virtually all matlab clones store
1602
# multidimensional data using the same layout: a single dimension array.
1603
# Since we can vectorize array arguments, we assume that the least
1604
# significant (fastest varying) dimension(s) is the vector that is
1605
# passed on each successive call to the C function. The stride is the
1606
# product of the least significant dimensions (the ones that the C
1607
# function wanted). To get to the next C function call, the index into
1608
# the serial array is incremented by the vector stride. Note that if the
1609
# object is a scalar or is not vectorized, the vector stride is 0.
1611
# We don't need to declare vector strides for dimensional variables, since
1612
# by definition they can't be vectorized.
1614
foreach $argname (@{$faa->{inputs}}) {
1615
$arg = $args->{$argname}; # Look at the non-dimensional variables,
1616
# including the output:
1617
$retstr .= " $dim_type _vecstride_$argname = " .
1618
(@{$arg->{dimension}} == 0 ? 1 : join("*", @{$arg->{dimension}})) . ";\n"
1619
if $max_dimensions > 0 && $faa->{args}{$argname}{vectorize};
1620
# Assume this argument will be vectorized.
1621
# This will be set to 0 by check_input_vectorize
1622
# if it is not vectorized.
1625
# Now verify that the dimension of all arguments are compatible, set up the
1626
# vectorization, and get the pointer to the first argument value.
1628
foreach $argname (@{$faa->{inputs}}, @{$faa->{modifies}}) {
1629
# Look at the input arguments:
1630
$arg = $args->{$argname}; # Access the description of argument.
1631
my $dim = @{$arg->{dimension}};
1632
# Get the minimum dimension of the argument.
1634
foreach (0 .. $dim-1) { # Look at the dimension specs.
1635
next if $dims_calculated{$argname, $_}; # Skip if we used this to
1636
# calculate a dimension variable.
1637
push(@conds, " ($dim_type)(" . $faa->get_size($argname, $_) . ") != ($dim_type)(" . $arg->{dimension}[$_] . ")");
1638
# Make sure this dimension matches.
1641
# See if any additional dimensions are specified. If so, we'll use them
1642
# for vectorizing. All modify arguments must have the additional
1643
# vectorizing dimensions. Input arguments may be either scalars or vectors,
1644
# but if they are vectorized, their dimensions must match.
1646
if ($arg->{vectorize} && $dim < $max_dimensions) {
1647
if ($arg->{source} eq 'input') { # Input args
1648
# may or may not have vectorizing dims.
1649
push(@conds, "!_check_input_vectorize(@{[$faa->arg_pass($argname)]}, &_vec_n, _d, " . scalar(@{$arg->{dimension}}) . ", &_vecstride_$argname)");
1651
push(@conds, "!_check_modify_vectorize(@{[$faa->arg_pass($argname)]}, &_vec_n, _d, " . scalar(@{$arg->{dimension}}) . ", &first_modify_flag)");
1653
} else { # Not a vectorizable argument?
1654
push(@conds, $faa->n_dimensions($argname) . " > $dim");
1655
# Make sure it has exactly the right number of
1656
# dimensions. Unfortunately, octave and matlab
1657
# can't distinguish between a vector and a
1658
# n by 1 matrix, so we have to check for less
1659
# than or equal to the number of dimensions.
1662
if (@conds) { # Any dimension conditions?
1663
$retstr .= (" if (" . join(" ||\n ", @conds) . ")\n" .
1664
" " . $faa->error_dimension($argname) . "\n");
1665
# Blow up if there's a problem.
1668
if ($arg->{vectorize} && $max_dimensions > 0 || @{$arg->{dimension}}) {
1669
$retstr .= $faa->get_c_arg_ptr($argname); # Get a pointer to this arg.
1671
$retstr .= $faa->get_c_arg_scalar($argname) # Get this argument.
1672
unless $dimvar{$argname}; # Unless we had to get it above because it
1673
# was a dimensional variable.
1675
$retstr .= "\n"; # Put an extra blank line in to make it
1679
# So much for the input arguments. Now handle the output arguments. These
1680
# matrices must be allocated to be the appropriate size:
1682
foreach $argname (@{$faa->{outputs}}) {
1683
$arg = $args->{$argname}; # Point to description of argument.
1685
if ($max_dimensions > 0) { # Are we vectorizing?
1687
$faa->make_output_ptr($argname,
1688
"(" . @{$arg->{dimension}} . " + _vec_n)", # Number of dims.
1689
@{$arg->{dimension}}, # Explicit dimensions.
1690
map({ "_d[$_] " } # Vectorized dims.
1691
0 .. ($max_dimensions-@{$arg->{dimension}}-1)));
1692
} else { # Not vectorizing:
1693
if (@{$arg->{dimension}}) { # Is this a vector?
1694
$retstr .= $faa->make_output_ptr($argname,
1695
scalar(@{$arg->{dimension}}),
1696
@{$arg->{dimension}});
1697
# Make it as a vector.
1698
} else { # It's a scalar:
1699
$retstr .= $faa->make_output_scalar($argname);
1704
# Now actually call the C function. Get each of the arguments in a variable
1705
# and then pass it off to the function:
1707
$retstr .= (" _vec_sz = " . join('*', map { "_d[$_]" } 0..$max_dimensions-1) . ";\n" .
1708
" for (_vidx = 0; _vidx < _vec_sz; ++_vidx) {\n")
1709
if $max_dimensions; # Add a loop if we're vectorizing.
1712
# Get an expression for each argument:
1715
$arg = $faa->{args}{$_}; # Access this argument.
1716
my $cexp = $arg->{c_var_name}; # Assume we just use the variable name.
1717
if ($max_dimensions > 0 && $arg->{vectorize}) { # Vectorizing?
1718
if ($arg->{source} eq 'input') { # Do we have a vector stride?
1719
$cexp .= "[_vecstride_$_*_vidx]"; # Add the index.
1721
$cexp .= "[" . (@{$arg->{dimension}} == 0 ? "" : join("*", @{$arg->{dimension}}) . "*") . "_vidx]";
1723
if (@{$arg->{dimension}} || $arg->{pass_by_pointer_reference}) {
1724
"&$cexp"; # Need to pass an address?
1728
} else { # Not a vectorized parameter:
1729
if ($arg->{pass_by_pointer_reference}) { # Pass by reference?
1735
} @{$faa->{argnames}};
1737
if ($faa->{returns} ne 'void') { # Is there a return code?
1738
if ($max_dimensions) { # Are we vectorizing this?
1739
$retstr .= " $args->{retval}{c_var_name}" . "[_vidx] = ($args->{retval}{basic_type})\n ";
1740
# Store return value in an array.
1742
$retstr .= " $args->{retval}{c_var_name} = ($args->{retval}{basic_type})\n ";
1743
# Store return value in a scalar.
1748
if ($faa->{class}) { # Is this a member function?
1749
if ($faa->{static}) { # Is it a static member function?
1750
if ($faa->{name} eq 'new') { # Is this the new function?
1751
$fcallstr = " new $faa->{class}(" .
1752
join(", ", @fargs) . ");\n";
1754
$fcallstr = " $faa->{class}::$faa->{name}(" . # Specify the class
1755
join(", ", @fargs) . ");\n"; # name explicitly.
1757
} else { # It's a member function. First argument is
1758
# actually the class pointer.
1759
if ($faa->{name} eq 'delete') { # Delete the field?
1760
$fcallstr = " delete $fargs[0];\n";
1762
$fcallstr = " ($fargs[0])->$faa->{name}(" .
1763
join(", ", @fargs[1 .. (@fargs-1)]) . ");\n";
1766
} else { # It's a boring global function:
1767
$fcallstr = " $faa->{name}(" . join(", ", @fargs) . ");\n";
1770
$fcallstr =~ s/___set_(.*?)\((.*)\)/$1 = $2/; # Handle the variable set.
1771
$fcallstr =~ s/___get_(.*?)\(\)/$1/; # Handle the variable get.
1772
$retstr .= $fcallstr; # Call the function.
1774
$retstr .= " }\n" if $max_dimensions; # Terminate the vectorizing loop.
1776
# Now we've called the function. Put back all the output and modify variables.
1778
foreach $argname (@{$faa->{modifies}}, @{$faa->{outputs}}) {
1779
if ($max_dimensions > 0 || # Vectorizing?
1780
@{$args->{$argname}{dimension}} > 0) { # It's an array of some sort?
1781
$retstr .= $faa->put_val_ptr($argname); # Put back as vector.
1783
$retstr .= $faa->put_val_scalar($argname); # It's guaranteed to be
1787
$retstr .= $faa->function_end(); # We're done!
1790
if ($@) { # Was there a problem?
1791
print(STDERR "While wrapping function ",
1792
($faa->{script_name} || $faa->{class} . "::" . $faa->{name}),
1794
# Print the message.
1796
print $retstr; # Output the result.
added
removed
plplot/plplot-5.9.9/bindings/octave/matwrap/matwrap
