Mercurial > octave-antonio
diff mk-opts.pl @ 3998:f6df65db67f9
[project @ 2002-07-24 18:10:39 by jwe]
| author | jwe |
|---|---|
| date | Wed, 24 Jul 2002 18:10:40 +0000 |
| parents | |
| children | b4b4515af951 |
line wrap: on
line diff
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/mk-opts.pl Wed Jul 24 18:10:40 2002 +0000 @@ -0,0 +1,944 @@ +#! /usr/bin/perl + +# Generate option handling code from a simpler input files for +# Octave's functions like lsode, dassl, etc. + +# Input file format: +# +# CLASS = string +# FCN_NAME = string +# DOC_STRING doc END_DOC_STRING +# OPTION +# NAME = string +# TYPE = string +# SET_ARG_TYPE = string (optional, defaults to TYPE) +# INIT_VALUE = string | INIT_BODY code END_INIT_BODY +# SET_EXPR = string | SET_BODY code END_SET_BODY | SET_CODE code END_SET_CODE +# END_OPTION +# +# END_* must appear at beginning of line (whitespace ignored). + +use Getopt::Long; + +$opt_emit_opt_class_header = 0; +$opt_emit_opt_handler_fcns = 0; +$opt_debug = 0; + +GetOptions ("opt-class-header" => \$opt_emit_opt_class_header, + "opt-handler-fcns" => \$opt_emit_opt_handler_fcns, + "debug" => \$opt_debug); + +if (@ARGV == 1) + { + $INFILE = shift @ARGV; + open (INFILE) || die "unable to open input file $INFILE"; + } +else + { + die "usage: mk-opts.pl [options] FILE"; + } + +$opt_num = 0; + +&parse_input; + +&process_data; + +FOO: + { + $opt_emit_opt_class_header && do { &emit_opt_class_header; last FOO; }; + + $opt_emit_opt_handler_fcns && do { &emit_opt_handler_fcns; last FOO; }; + + $opt_debug && do { &emit_options_debug; last FOO; }; + } + +sub parse_input +{ + local ($have_doc_string); + + while (<INFILE>) + { + next if (/^\s*$/); + + if (/^\s*OPTION\s*$/) + { + &parse_option_block; + } + elsif (/^\s*CLASS\s*=\s*"(\w+)"\s*$/) + { + die "duplicate CLASS" if ($class ne ""); + $CLASS = $1; + $class_name = "${CLASS}_options"; + $struct_name = "${class_name}_struct"; + $static_table_name = "${class_name}_table"; + } + elsif (/^\s*FCN_NAME\s*=\s*"(\w+)"\s*$/) + { + die "duplicate FCN_NAME" if ($fcn_name ne ""); + $fcn_name = $1; + } + elsif (/^\s*DOC_STRING\s*$/) + { + die "duplicate DOC_STRING" if ($have_doc_string); + &parse_doc_string; + $have_doc_string = 1; + } + } +} + +sub parse_option_block +{ + local ($have_init_body, $have_set_body, $have_set_code); + + while (<INFILE>) + { + next if (/^\s*$/); + + die "missing END_OPTION" if (/^\s*OPTION\s*$/); + + last if (/^\s*END_OPTION\s*$/); + + if (/^\s*NAME\s*=\s*"(.*)"\s*$/) + { + die "duplicate NAME" if ($name[$opt_num] ne ""); + $name[$opt_num] = $1; + ($opt[$opt_num] = $name[$opt_num]) =~ s/\s+/_/g; + $optvar[$opt_num] = "x_$opt[$opt_num]"; + $kw_tok[$opt_num] = [ split (/\s+/, $name[$opt_num]) ]; + $n_toks[$opt_num] = @{$kw_tok[$opt_num]}; + } + elsif (/^\s*TYPE\s*=\s*"(.*)"\s*$/) + { + die "duplicate TYPE" if ($type[$opt_num] ne ""); + $type[$opt_num] = $1; + } + elsif (/^\s*SET_ARG_TYPE\s*=\s*"(.*)"\s*$/) + { + die "duplicate SET_ARG_TYPE" if ($set_arg_type[$opt_num] ne ""); + $set_arg_type[$opt_num] = $1; + } + elsif (/^\s*INIT_VALUE\s*=\s*"(.*)"\s*$/) + { + die "duplicate INIT_VALUE" if ($init_value[$opt_num] ne ""); + $init_value[$opt_num] = $1; + } + elsif (/^\s*SET_EXPR\s*=\s*"(.*)"\s*$/) + { + die "duplicate SET_EXPR" if ($set_expr[$opt_num] ne ""); + $set_expr[$opt_num] = $1; + } + elsif (/^\s*INIT_BODY\s*$/) + { + die "duplicate INIT_BODY" if ($have_init_body); + &parse_init_body; + $have_init_body = 1; + } + elsif (/^\s*SET_BODY\s*$/) + { + die "duplicate SET_BODY" if ($have_set_body); + &parse_set_body; + $have_set_body = 1; + } + elsif (/^\s*SET_CODE\s*$/) + { + die "duplicate SET_CODE" if ($have_set_code); + &parse_set_code; + $have_set_code = 1; + } + } + + if ($set_arg_type[$opt_num] eq "") + { + $set_arg_type[$opt_num] = $type[$opt_num] + } + else + { + $set_arg_type[$opt_num] + = &substopt ($set_arg_type[$opt_num], $optvar[$opt_num], + $opt[$opt_num], $type[$opt_num]); + } + + $opt_num++; +} + +sub process_data +{ + @uniq_types = &get_uniq_types (@type); + @uniq_set_arg_types = &get_uniq_types (@set_arg_type); + + @get_type_num = &get_uniq_type_num (*type, *uniq_types); + @set_type_num = &get_uniq_type_num (*set_arg_type, *uniq_set_arg_types); + + $max_tokens = &max (@n_toks); + + &get_min_match_len_info ($max_tokens); + + $fcn_name = lc ($CLASS) if ($fcn_name eq ""); + + $opt_fcn_name = "${fcn_name}_options" if ($opt_fcn_name eq ""); + + $static_object_name = "${fcn_name}_opts"; + + if ($doc_string eq "") + { + $doc_string = "When called with two arguments, this function\\n\\ +allows you set options parameters for the function \@code{$fcn_name}.\\n\\ +Given one argument, \@code{$opt_fcn_name} returns the value of the\\n\\ +corresponding option. If no arguments are supplied, the names of all\\n\\ +the available options and their current values are displayed.\\n\\\n"; + } +} + +sub get_uniq_types +{ + local ($k, $i, @retval, %u); + + $k = 0; + + for ($i = 0; $i < $opt_num; $i++) + { + local ($x); + $x = $_[$i]; + $u{$x}++; + $retval[$k++] = $x if ($u{$x} == 1); + } + + @retval; +} + +sub get_uniq_type_num +{ + local (*t, *ut) = @_; + + local ($k, $i, @retval); + + for ($i = 0; $i < $opt_num; $i++) + { + for $k (0 .. $#ut) + { + $retval[$i] = $k if ($t[$i] eq $ut[$k]); + } + } + + @retval; +} + +sub get_min_match_len_info +{ + local ($max_tokens) = @_; + + local ($i, $j, $k); + + for ($i = 0; $i < $opt_num; $i++) + { + for ($j = 0; $j < $max_tokens; $j++) + { + $min_tok_len_to_match[$i][$j] = 0; + } + + $min_toks_to_match[$i] = 1; + + L1: for ($k = 0; $k < $opt_num; $k++) + { + local ($duplicate) = 1; + + if ($i != $k) + { + L2: for ($j = 0; $j < $max_tokens; $j++) + { + if ($j < $n_toks[$i]) + { + if ($kw_tok[$i][$j] eq $kw_tok[$k][$j]) + { + if ($min_tok_len_to_match[$i][$j] == 0) + { + $min_tok_len_to_match[$i][$j] = 1; + } + + $min_toks_to_match[$i]++; + } + else + { + $duplicate = 0; + + if ($min_tok_len_to_match[$i][$j] == 0) + { + $min_tok_len_to_match[$i][$j] = 1; + } + + local (@s) = split (//, $kw_tok[$i][$j]); + local (@t) = split (//, $kw_tok[$k][$j]); + + local ($n, $ii); + $n = scalar (@s); + $n = scalar (@t) if (@t < $n); + + for ($ii = 0; $ii < $n; $ii++) + { + if ("$s[$ii]" eq "$t[$ii]") + { + if ($ii + 2 > $min_tok_len_to_match[$i][$j]) + { + $min_tok_len_to_match[$i][$j]++; + } + } + else + { + last L2; + } + } + + last L1; + } + } + else + { + die "ambiguous options \"$name[$i]\" and \"$name[$k]\"" if ($duplicate); + } + } + } + } + } +} + +sub parse_doc_string +{ + while (<INFILE>) + { + last if (/^\s*END_DOC_STRING\s*$/); + + $doc_string .= $_; + } + + $doc_string =~ s/\n/\\n\\\n/g; +} + +sub parse_init_body +{ + while (<INFILE>) + { + last if (/^\s*END_INIT_BODY\s*$/); + + $init_body[$opt_num] .= $_; + } +} + +sub parse_set_body +{ + while (<INFILE>) + { + last if (/^\s*END_SET_BODY\s*$/); + + $set_body[$opt_num] .= $_; + } +} + +sub parse_set_code +{ + while (<INFILE>) + { + last if (/^\s*END_SET_CODE\s*$/); + + $set_code[$opt_num] .= $_; + } +} + +sub emit_opt_class_header +{ + local ($i, $s); + + print "// DO NOT EDIT! +// Generated automatically from $INFILE. + +#if !defined (octave_${class_name}_h) +#define octave_${class_name}_h 1 + +#include <cfloat> +#include <cmath> + +class +${class_name} +{ +public: + + ${class_name} (void) { init (); } + + ${class_name} (const ${class_name}& opt) { copy (opt); } + + ${class_name}& operator = (const ${class_name}& opt) + { + if (this != &opt) + copy (opt); + + return *this; + } + + ~${class_name} (void) { }\n"; + + print "\n void init (void)\n {\n"; + + for ($i = 0; $i < $opt_num; $i++) + { + if ($init_value[$i]) + { + print " $optvar[$i] = $init_value[$i];\n"; + } + elsif ($init_body[$i]) + { + $s = &substopt ($init_body[$i], $optvar[$i], $opt[$i], $type[$i]); + chop ($s); + $s =~ s/^\s*/ /g; + $s =~ s/\n\s*/\n /g; + print "$s\n"; + } + } + + print " }\n"; + + print "\n void copy (const ${class_name}& opt)\n {\n"; + + for ($i = 0; $i < $opt_num; $i++) + { + print " $optvar[$i] = opt.$optvar[$i];\n"; + } + + print " }\n"; + + print "\n void set_default_options (void) { init (); }\n"; + + for ($i = 0; $i < $opt_num; $i++) + { + if ($set_expr[$i]) + { + &emit_set_decl ($i); + + print "\n { $optvar[$i] = $set_expr[$i]; }\n"; + } + elsif ($set_body[$i]) + { + &emit_set_decl ($i); + + $s = &substopt ($set_body[$i], $optvar[$i], $opt[$i], $type[$i]); + chop ($s); + $s =~ s/^/ /g; + $s =~ s/\n/\n /g; + print "\n {\n$s\n }\n"; + } + elsif ($set_code[$i]) + { + $s = &substopt ($set_code[$i], $optvar[$i], $opt[$i], $type[$i]); + chop ($s); + $s =~ s/^ //g; + $s =~ s/\n /\n/g; + print "\n$s\n"; + } + } + + for ($i = 0; $i < $opt_num; $i++) + { + print " $type[$i] $opt[$i] (void) const\n { return $optvar[$i]; }\n\n"; + } + + print "private:\n\n"; + + for ($i = 0; $i < $opt_num; $i++) + { + print " $type[$i] $optvar[$i];\n"; + } + + print "};\n\n#endif\n"; +} + +sub emit_set_decl +{ + local ($i) = @_; + + print " + void set_$opt[$i] ($set_arg_type[$i] val)"; +} + +sub emit_opt_handler_fcns +{ + local ($i); + + print "// DO NOT EDIT!\n// Generated automatically from $INFILE.\n\n"; + + print "#ifdef HAVE_CONFIG_H +#include <config.h> +#endif + +#include <iomanip> +#include <iostream> + +#include \"defun-dld.h\" +#include \"pr-output.h\" + +static ${class_name} ${static_object_name};\n\n"; + + &emit_set_mf_typedefs (@uniq_set_arg_types); + + &emit_get_mf_typedefs (@uniq_types); + + &emit_struct_decl; + + &emit_struct_def; + + &emit_print_function; + + &emit_set_functions; + + &emit_show_function; + + &emit_options_function; +} + +sub emit_set_mf_typedefs +{ + local ($k) = 0; + + foreach (@_) + { + print "typedef void (${class_name}::*set_opt_mf_$k) ($_[$k]);\n"; + $k++; + } + + print "\n"; +} + +sub emit_get_mf_typedefs +{ + local ($k) = 0; + + foreach (@_) + { + print "typedef $_[$k] (${class_name}::*get_opt_mf_$k) (void) const;\n"; + $k++; + } + + print "\n"; +} + +sub emit_struct_decl +{ + local ($i); + + print "#define MAX_TOKENS $max_tokens\n\n"; + + print "struct ${struct_name}\n{\n"; + + print " const char *keyword;\n"; + print " const char *kw_tok[MAX_TOKENS + 1];\n"; + print " int min_len[MAX_TOKENS + 1];\n"; + print " int min_toks_to_match;\n"; + + foreach $i (0 .. $#uniq_set_arg_types) + { + print " set_opt_mf_$i set_fcn_$i;\n"; + } + + foreach $i (0 .. $#uniq_set_arg_types) + { + print " get_opt_mf_$i get_fcn_$i;\n"; + } + + print "};\n\n"; +} + +sub emit_struct_def +{ + local ($i); + + print "#define NUM_OPTIONS $opt_num\n\n"; + + print "static ${struct_name} ${static_table_name} [] =\n{\n"; + + for ($i = 0; $i < $opt_num; $i++) + { + &emit_option_table_entry ($i, 0); + + if ($i < $opt_num - 1) + { + print "\n"; + } + } + + &emit_option_table_entry ($i, 1); + + print "};\n\n"; +} + +sub emit_option_table_entry +{ + local ($i, $empty) = @_; + + local ($k); + + if ($empty) + { + print " { 0,\n"; + } + else + { + print " { \"$name[$i]\",\n"; + } + + local ($n) = scalar $#{$kw_tok[$i]}; + print " {"; + for $k (0 .. $max_tokens) + { + if ($empty || $k > $n) + { + print " 0,"; + } + else + { + print " \"$kw_tok[$i][$k]\","; + } + } + print " },\n"; + + print " {"; + for $k (0 .. $max_tokens) + { + if ($empty || $k > $n) + { + print " 0,"; + } + else + { + print " $min_tok_len_to_match[$i][$k],"; + } + } + print " }, $min_toks_to_match[$i], "; + + print " "; + for $k (0 .. $#uniq_set_arg_types) + { + if ($empty || $k != $set_type_num[$i]) + { + print "0, "; + } + else + { + print "&${class_name}::set_$opt[$i], "; + } + } + + print "\n "; + for $k (0 .. $#uniq_types) + { + if ($empty || $k != $get_type_num[$i]) + { + print "0, "; + } + else + { + print "&${class_name}::$opt[$i], "; + } + } + + print "},\n"; +} + +sub emit_print_function +{ + local ($i); + + print "static void +print_${class_name} (std::ostream& os) +{ + print_usage (\"$opt_fcn_name\", 1); + + os << \"\\n\" + << \"Options for $CLASS include:\\n\\n\" + << \" keyword value\\n\" + << \" ------- -----\\n\"; + + $struct_name *list = $static_table_name;\n\n"; + + for ($i = 0; $i < $opt_num; $i++) + { + print " {\n os << \" \" + << std::setiosflags (std::ios::left) << std::setw (40) + << list[$i].keyword + << std::resetiosflags (std::ios::left) + << \" \";\n\n"; + + if ($type[$i] eq "double") + { + print " double val = $static_object_name.$opt[$i] ();\n\n"; + print " os << val << \"\\n\";\n"; + } + elsif ($type[$i] eq "int") + { + print " int val = $static_object_name.$opt[$i] ();\n\n"; + print " os << val << \"\\n\";\n"; + } + elsif ($type[$i] eq "std::string") + { + print " os << $static_object_name.$opt[$i] () << \"\\n\";\n"; + } + elsif ($type[$i] eq "Array<double>") + { + print " Array<double> val = $static_object_name.$opt[$i] ();\n\n"; + print " if (val.length () == 1) + { + os << val(0) << \"\\n\"; + } + else + { + os << \"\\n\\n\"; + Matrix tmp = Matrix (ColumnVector (val)); + octave_print_internal (os, tmp, false, 2); + os << \"\\n\\n\"; + }\n"; + } + else + { + die ("unknown type $type[$i]"); + } + + print " }\n\n"; + } + + print " os << \"\\n\";\n}\n\n"; +} + +sub emit_set_functions +{ + print "static void +set_${class_name} (const std::string& keyword, const octave_value& val) +{ + $struct_name *list = $static_table_name;\n\n"; + + $iftok = "if"; + + for ($i = 0; $i < $opt_num; $i++) + { + $iftok = "else if" if ($i > 0); + + print " $iftok (keyword_almost_match (list[$i].kw_tok, list[$i].min_len, + keyword, list[$i].min_toks_to_match, MAX_TOKENS)) + {\n"; + + if ($type[$i] eq "double") + { + print " double tmp = val.double_value ();\n\n"; + print " if (! error_state) + $static_object_name.set_$opt[$i] (tmp);\n"; + } + elsif ($type[$i] eq "int") + { + print " int tmp = val.int_value ();\n\n"; + print " if (! error_state) + $static_object_name.set_$opt[$i] (tmp);\n"; + } + elsif ($type[$i] eq "std::string") + { + print " std::string tmp = val.string_value ();\n\n"; + print " if (! error_state) + $static_object_name.set_$opt[$i] (tmp);\n"; + } + elsif ($type[$i] eq "Array<double>") + { + print " Array<double> tmp = val.vector_value ();\n\n"; + print " if (! error_state) + $static_object_name.set_$opt[$i] (tmp);\n"; + } + else + { + die ("unknown type $type[$i]"); + } + + print " }\n"; + } + + print " else + { + warning (\"$opt_fcn_name: no match for `%s'\", keyword.c_str ()); + } +}\n\n"; +} + +sub emit_show_function +{ + local ($i, $iftok); + + print "static octave_value_list +show_${class_name} (const std::string& keyword) +{ + octave_value retval; + + $struct_name *list = $static_table_name;\n\n"; + + $iftok = "if"; + + for ($i = 0; $i < $opt_num; $i++) + { + $iftok = "else if" if ($i > 0); + + print " $iftok (keyword_almost_match (list[$i].kw_tok, list[$i].min_len, + keyword, list[$i].min_toks_to_match, MAX_TOKENS)) + {\n"; + + if ($type[$i] eq "double") + { + print " double val = $static_object_name.$opt[$i] ();\n\n"; + print " retval = val;\n"; + } + elsif ($type[$i] eq "int") + { + print " int val = $static_object_name.$opt[$i] ();\n\n"; + print " retval = static_cast<double> (val);\n"; + } + elsif ($type[$i] eq "std::string") + { + print " retval = $static_object_name.$opt[$i] ();\n"; + } + elsif ($type[$i] eq "Array<double>") + { + print " Array<double> val = $static_object_name.$opt[$i] ();\n\n"; + print " if (val.length () == 1) + { + retval = val(0); + } + else + { + retval = ColumnVector (val); + }\n"; + } + else + { + die ("unknown type $type[$i]"); + } + + print " }\n"; + } + + print " else + { + warning (\"$opt_fcn_name: no match for `%s'\", keyword.c_str ()); + } + + return retval;\n}\n\n"; +} + +sub emit_options_function +{ + print "DEFUN_DLD ($opt_fcn_name, args, , + \"-*- texinfo -*-\\n\\ +\@deftypefn {Loadable Function} {} $opt_fcn_name (\@var{opt}, \@var{val})\\n\\ +$doc_string\@end deftypefn\") +{ + octave_value_list retval; + + int nargin = args.length (); + + if (nargin == 0) + { + print_${class_name} (octave_stdout); + } + else if (nargin == 1 || nargin == 2) + { + std::string keyword = args(0).string_value (); + + if (! error_state) + { + if (nargin == 1) + retval = show_${class_name} (keyword); + else + set_${class_name} (keyword, args(1)); + } + else + error (\"$opt_fcn_name: expecting keyword as first argument\"); + } + else + print_usage (\"$opt_fcn_name\"); + + return retval; +}"; +} + +sub emit_options_debug +{ + print "CLASS = \"$class\"\n"; + + for ($i = 0; $i < $opt_num; $i++) + { + $NAME = $name[$i]; + ($OPT = $NAME) =~ s/\s+/_/g; + $OPTVAR = "x_$OPT"; + $TYPE = $type[$i]; + print "\n"; + print "OPTION\n"; + print " NAME = \"$NAME\"\n"; + print " TYPE = \"$TYPE\"\n"; + if ($set_arg_type[$i]) + { + print eval ("\" SET_ARG_TYPE = \\\"$set_arg_type[$i]\\\"\"") . "\n"; + } + if ($init_value[$i]) + { + print " INIT_VALUE = \"$init_value[$i]\"\n"; + } + if ($init_body[$i]) + { + print " INIT_BODY\n"; + print &substopt ($init_body[$i]); + print " END_INIT_BODY\n"; + } + if ($set_expr[$i]) + { + print " SET_EXPR = \"$set_expr[$i]\"\n"; + } + if ($set_body[$i]) + { + print " SET_BODY\n"; + print &substopt ($set_body[$i]); + print " END_SET_BODY\n"; + } + if ($set_code[$i]) + { + print " SET_CODE\n"; + print &substopt ($set_code[$i]); + print " END_SET_CODE\n"; + } + print "END_OPTION\n"; + } +} + +sub substopt +{ + local ($string, $OPTVAR, $OPT, $TYPE) = @_; + + $string =~ s/\$OPTVAR/$OPTVAR/g; + $string =~ s/\$OPT/$OPT/g; + $string =~ s/\$TYPE/$TYPE/g; + + $string; +} + +sub print_assoc_array +{ + local (%t) = @_; + + local ($k); + + foreach $k (keys (%t)) + { + print "$k: $t{$k}\n"; + } +} + +sub max +{ + local ($max) = shift; + + foreach (@_) + { + $max = $_ if $max < $_; + } + + $max; +}