Mercurial > octave

comparison build-aux/mk-opts.pl @ 12733:b67c2d580a25 stable

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
maint: clean up top-level directory * build-aux/bootstrap: Rename from bootstrap. * build-aux/bootstrap.conf: Rename from bootstrap.conf. * build-aux/changelog.tmpl: Rename from changelog.tmpl. * build-aux/bootstrap.conf: Update for new file locations. * build-aux/common.mk: Rename from common.mk. * build-aux/diff-template: Rename from diff-template. * build-aux/mk-opts.pl: Rename from mk-opts.pl. * build-aux/mkinstalldirs: Rename from mkinstalldirs. * build-aux/move-if-change: Rename from move-if-change. * etc/CHECKLIST: Rename from CHECKLIST. * etc/HACKING: Rename from HACKING. * etc/NEWS.1: Rename from NEWS.1. * etc/NEWS.2: Rename from NEWS.2. * etc/NEWS.3: Rename from NEWS.3. * etc/OLD-ChangeLogs/ChangeLog: Rename from OLD-ChangeLogs/ChangeLog. * etc/OLD-ChangeLogs/ChangeLog.1: Rename from OLD-ChangeLogs/ChangeLog.1. * etc/OLD-ChangeLogs/doc-ChangeLog: Rename from OLD-ChangeLogs/doc-ChangeLog. * etc/OLD-ChangeLogs/libcruft-ChangeLog: Rename from OLD-ChangeLogs/libcruft-ChangeLog. * etc/OLD-ChangeLogs/liboctave-ChangeLog: Rename from OLD-ChangeLogs/liboctave-ChangeLog. * etc/OLD-ChangeLogs/scripts-ChangeLog: Rename from OLD-ChangeLogs/scripts-ChangeLog. * etc/OLD-ChangeLogs/src-ChangeLog: Rename from OLD-ChangeLogs/src-ChangeLog. * etc/OLD-ChangeLogs/test-ChangeLog: Rename from OLD-ChangeLogs/test-ChangeLog. * etc/PROJECTS: Rename from PROJECTS. * etc/README.Cygwin: Rename from README.Cygwin. * etc/README.Linux: Rename from README.Linux. * etc/README.MacOS: Rename from README.MacOS. * etc/README.MinGW: Rename from README.MinGW. * etc/README.Windows: Rename from README.Windows. * etc/README.devel: Rename from README.devel. * etc/README.ftp: Rename from README.ftp. * etc/README.gnuplot: Rename from README.gnuplot. * etc/README.kpathsea: Rename from README.kpathsea. * etc/README.mirrors: Rename from README.mirrors. * etc/README.snapshots: Rename from README.snapshots. * etc/gdbinit: Rename from gdbinit. * m4/acinclude.m4: Rename from acinclude.m4. * src/mkoctfile.cc.in: Rename from mkoctfile.cc.in. * src/mkoctfile.in: Rename from mkoctfile.in. * src/octave-config.cc.in: Rename from octave-config.cc.in. * src/octave-config.in: Rename from octave-config.in. * config.guess, config.sub, missing, octave-sh: Delete. * Makefile.am: Include build-aux/common.mk instead of common.mk. * examples/Makefile.am, libcruft/Makefile.am, liboctave/Makefile.am, liboctave/config-ops.sh, scripts/Makefile.am, src/DLD-FUNCTIONS/config-module.sh, test/Makefile.am, autogen.sh, doc/Makefile.am, doc/faq/Makefile.am, doc/icons/Makefile.am, doc/interpreter/Makefile.am, doc/interpreter/config-images.sh, doc/liboctave/Makefile.am, doc/refcard/Makefile.am, build-aux/common.mk, src/Makefile.am: Update for new file locations. * Makefile.am: Don't build mkoctfile or octave-config here. * README: Update INSTALL info. * build-aux/mkinstalldirs: Update to new version. * src/Makefile.am (mkoctfile, octave-config): New targets.
author John W. Eaton <jwe@octave.org>
date Fri, 10 Jun 2011 14:35:42 -0400
parents mk-opts.pl@16cca721117b
children 72c96de7a403
comparison
equal deleted inserted replaced
12732:10f6727fbaa8 12733:b67c2d580a25
1 #! /usr/bin/perl -w
2 #
3 # Copyright (C) 2002-2011 John W. Eaton
4 #
5 # This file is part of Octave.
6 #
7 # Octave is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by the
9 # Free Software Foundation; either version 3 of the License, or (at
10 # your option) any later version.
11 #
12 # Octave is distributed in the hope that it will be useful, but WITHOUT
13 # ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
14 # FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
15 # for more details.
16 #
17 # You should have received a copy of the GNU General Public License
18 # along with Octave; see the file COPYING. If not, see
19 # <http://www.gnu.org/licenses/>.
20
21 # Generate option handling code from a simpler input files for
22 # Octave's functions like lsode, dassl, etc.
23
24 # FIXME:
25 #
26 # * Improve default documentation and/or individual documentation
27 # in data files.
28 #
29 # * Fix print/show code to display/return something more informative
30 # for special values (for example, -1 ==> infinite in some cases).
31 # Probably need more information in the data files for this.
32
33 # Input file format:
34 #
35 # CLASS = string
36 # FCN_NAME = string
37 # INCLUDE = file
38 # DOC_STRING doc END_DOC_STRING
39 # OPTION
40 # NAME = string
41 # DOC_ITEM doc END_DOC_ITEM
42 # TYPE = string
43 # SET_ARG_TYPE = string (optional, defaults to TYPE)
44 # INIT_VALUE = string | INIT_BODY code END_INIT_BODY
45 # SET_EXPR = string | SET_BODY code END_SET_BODY | SET_CODE code END_SET_CODE
46 # END_OPTION
47 #
48 # END_* must appear at beginning of line (whitespace ignored).
49
50 ################################################################################
51 # Load packages to
52 # 1) process command line options
53 ################################################################################
54 use Getopt::Long;
55
56 ################################################################################
57 # Extract command line arguments
58 &parse_options;
59
60 $DEFN_FILE = shift @ARGV;
61 open (DEFN_FILE) or die "unable to open input definition file $DEFN_FILE";
62
63 ################################################################################
64 # Initialize variables
65 $BLANK_LINE = qr/^\s*$/;
66 $COMMENT = qr/^\s*#/;
67
68 ################################################################################
69 # Process file
70 $OPT_NUM = 0;
71
72 &parse_input;
73
74 &process_data;
75
76 # Produce desired style of output
77 &emit_opt_class_header if $opt_class_header;
78 &emit_opt_handler_fcns if $opt_handler_fcns;
79 &emit_options_debug if $opt_debug;
80
81 # End of main code
82
83 ################################################################################
84 # Subroutines
85 ################################################################################
86
87 sub parse_input
88 {
89 LINE: while (<DEFN_FILE>)
90 {
91 next LINE if /$BLANK_LINE/;
92 next LINE if /$COMMENT/;
93
94 if (/^\s*OPTION\s*$/)
95 {
96 &parse_option_block;
97 }
98 elsif (/^\s*CLASS\s*=\s*"(\w+)"\s*$/)
99 {
100 die "duplicate CLASS" if defined $CLASS;
101 $CLASS = $1;
102 $CLASS_NAME = "${CLASS}_options";
103 $STRUCT_NAME = "${CLASS_NAME}_struct";
104 $STATIC_TABLE_NAME = "${CLASS_NAME}_table";
105 }
106 elsif (/^\s*FCN_NAME\s*=\s*"(\w+)"\s*$/)
107 {
108 die "duplicate FCN_NAME" if defined $FCN_NAME;
109 $FCN_NAME = $1;
110 }
111 elsif (/^\s*INCLUDE\s*=\s*"(\S+)"\s*$/)
112 {
113 $INCLUDE .= "#include <$1>\n";
114 }
115 elsif (/^\s*DOC_STRING\s*$/)
116 {
117 die "duplicate DOC_STRING" if defined $DOC_STRING;
118 while (defined ($_ = <DEFN_FILE>) and not /^\s*END_DOC_STRING\s*$/)
119 {
120 $DOC_STRING .= $_;
121 }
122 $DOC_STRING =~ s/\n/\\n\\\n/g;
123 }
124 else
125 {
126 die "mk-opts.pl: unknown command: $_\n"
127 }
128 }
129 $INCLUDE = "" if not defined $INCLUDE; # Initialize value if required
130 }
131
132 sub parse_option_block
133 {
134 while (<DEFN_FILE>)
135 {
136 next if /$BLANK_LINE/;
137
138 die "missing END_OPTION" if /^\s*OPTION\s*$/;
139
140 last if /^\s*END_OPTION\s*$/;
141
142 if (/^\s*NAME\s*=\s*"(.*)"\s*$/)
143 {
144 die "duplicate NAME" if defined $NAME[$OPT_NUM];
145 $NAME[$OPT_NUM] = $1;
146 ($OPT[$OPT_NUM] = $NAME[$OPT_NUM]) =~ s/\s+/_/g;
147 $OPTVAR[$OPT_NUM] = 'x_' . $OPT[$OPT_NUM];
148 $KW_TOK[$OPT_NUM] = [ split (' ', $NAME[$OPT_NUM]) ];
149 $N_TOKS[$OPT_NUM] = @{$KW_TOK[$OPT_NUM]};
150 }
151 elsif (/^\s*DOC_ITEM\s*$/)
152 {
153 die "duplicate DOC_ITEM" if defined $DOC_ITEM[$OPT_NUM];
154 while (defined ($_ = <DEFN_FILE>) and not /^\s*END_DOC_ITEM\s*$/)
155 {
156 $DOC_ITEM[$OPT_NUM] .= $_;
157 }
158 $DOC_ITEM[$OPT_NUM] =~ s/\n/\\n\\\n/g;
159 }
160 elsif (/^\s*TYPE\s*=\s*"(.*)"\s*$/)
161 {
162 die "duplicate TYPE" if defined $TYPE[$OPT_NUM];
163 $TYPE[$OPT_NUM] = $1;
164 }
165 elsif (/^\s*SET_ARG_TYPE\s*=\s*"(.*)"\s*$/)
166 {
167 die "duplicate SET_ARG_TYPE" if defined $SET_ARG_TYPE[$OPT_NUM];
168 $SET_ARG_TYPE[$OPT_NUM] = $1;
169 }
170 elsif (/^\s*INIT_VALUE\s*=\s*"(.*)"\s*$/)
171 {
172 die "duplicate INIT_VALUE" if defined $INIT_VALUE[$OPT_NUM];
173 $INIT_VALUE[$OPT_NUM] = $1;
174 }
175 elsif (/^\s*SET_EXPR\s*=\s*"(.*)"\s*$/)
176 {
177 die "duplicate SET_EXPR" if defined $SET_EXPR[$OPT_NUM];
178 $SET_EXPR[$OPT_NUM] = $1;
179 }
180 elsif (/^\s*INIT_BODY\s*$/)
181 {
182 die "duplicate INIT_BODY" if defined $INIT_BODY[$OPT_NUM];
183 while (defined ($_ = <DEFN_FILE>) and not /^\s*END_INIT_BODY\s*$/)
184 {
185 $INIT_BODY[$OPT_NUM] .= $_;
186 }
187 }
188 elsif (/^\s*SET_BODY\s*$/)
189 {
190 die "duplicate SET_BODY" if defined $INIT_BODY[$OPT_NUM];
191 while (defined ($_ = <DEFN_FILE>) and not /^\s*END_SET_BODY\s*$/)
192 {
193 $SET_BODY[$OPT_NUM] .= $_;
194 }
195 }
196 elsif (/^\s*SET_CODE\s*$/)
197 {
198 die "duplicate SET_CODE" if defined $SET_CODE[$OPT_NUM];
199 while (defined ($_ = <DEFN_FILE>) and not /^\s*END_SET_CODE\s*$/)
200 {
201 $SET_CODE[$OPT_NUM] .= $_;
202 }
203 }
204 }
205
206 if (not defined $SET_ARG_TYPE[$OPT_NUM])
207 {
208 $SET_ARG_TYPE[$OPT_NUM] = $TYPE[$OPT_NUM];
209 }
210 else
211 {
212 $SET_ARG_TYPE[$OPT_NUM]
213 = substopt ($SET_ARG_TYPE[$OPT_NUM], $OPTVAR[$OPT_NUM],
214 $OPT[$OPT_NUM], $TYPE[$OPT_NUM]);
215 }
216
217 $OPT_NUM++;
218 }
219
220 sub process_data
221 {
222 $MAX_TOKENS = max (@N_TOKS);
223
224 &get_min_match_len_info;
225
226 $FCN_NAME = lc ($CLASS) if not defined $FCN_NAME;
227
228 $OPT_FCN_NAME = "${FCN_NAME}_options" if not defined $OPT_FCN_NAME;
229
230 $STATIC_OBJECT_NAME = "${FCN_NAME}_opts";
231
232 if (not defined $DOC_STRING)
233 {
234 $DOC_STRING = "Query or set options for the function \@code{$FCN_NAME}.\\n\\
235 When called with no arguments, the names of all available options and\\n\\
236 their current values are displayed.\\n\\
237 Given one argument, return the value of the corresponding option.\\n\\
238 When called with two arguments, \@code{$OPT_FCN_NAME} set the option\\n\\
239 \@var{opt} to value \@var{val}.";
240 }
241 }
242
243 #FIXME: What does this routine do? And can it be simpler to understand?
244 sub get_min_match_len_info
245 {
246 my ($i, $j, $k);
247
248 for ($i = 0; $i < $OPT_NUM; $i++)
249 {
250 for ($j = 0; $j < $MAX_TOKENS; $j++)
251 {
252 $MIN_TOK_LEN_TO_MATCH[$i][$j] = 0;
253 }
254
255 $MIN_TOKS_TO_MATCH[$i] = 1;
256
257 L1: for ($k = 0; $k < $OPT_NUM; $k++)
258 {
259 my $duplicate = 1;
260
261 if ($i != $k)
262 {
263 L2: for ($j = 0; $j < $MAX_TOKENS; $j++)
264 {
265 if ($j < $N_TOKS[$i])
266 {
267 if ($KW_TOK[$i][$j] eq $KW_TOK[$k][$j])
268 {
269 if ($MIN_TOK_LEN_TO_MATCH[$i][$j] == 0)
270 {
271 $MIN_TOK_LEN_TO_MATCH[$i][$j] = 1;
272 }
273
274 $MIN_TOKS_TO_MATCH[$i]++;
275 }
276 else
277 {
278 $duplicate = 0;
279
280 if ($MIN_TOK_LEN_TO_MATCH[$i][$j] == 0)
281 {
282 $MIN_TOK_LEN_TO_MATCH[$i][$j] = 1;
283 }
284
285 my @s = split (//, $KW_TOK[$i][$j]);
286 my @t = split (//, $KW_TOK[$k][$j]);
287
288 my ($n, $ii);
289 $n = scalar (@s);
290 $n = scalar (@t) if (@t < $n);
291
292 for ($ii = 0; $ii < $n; $ii++)
293 {
294 if ("$s[$ii]" eq "$t[$ii]")
295 {
296 if ($ii + 2 > $MIN_TOK_LEN_TO_MATCH[$i][$j])
297 {
298 $MIN_TOK_LEN_TO_MATCH[$i][$j]++;
299 }
300 }
301 else
302 {
303 last L2;
304 }
305 }
306
307 last L1;
308 }
309 }
310 else
311 {
312 die qq|ambiguous options "$NAME[$i]" and "$NAME[$k]"| if $duplicate;
313 }
314 }
315 }
316 }
317 }
318 } # end of get_min_match_len_info
319
320
321 sub emit_copy_body
322 {
323 my ($pfx, $var) = @_;
324
325 for (my $i = 0; $i < $OPT_NUM; $i++)
326 {
327 print "${pfx}$OPTVAR[$i] = ${var}.$OPTVAR[$i];\n";
328 }
329
330 print "${pfx}reset = ${var}.reset;\n";
331 }
332
333 ## To silence GCC warnings, we create an initialization list even
334 ## though the init function actually does the work of initialization.
335
336 sub emit_default_init_list
337 {
338 my ($prefix) = @_;
339
340 print "$OPTVAR[0] (),\n" unless ($OPT_NUM == 0);
341
342 for (my $i = 1; $i < $OPT_NUM; $i++)
343 {
344 print "${prefix}$OPTVAR[$i] (),\n";
345 }
346
347 print "${prefix}reset ()\n";
348 }
349
350 sub emit_copy_ctor_init_list
351 {
352 my ($prefix, $var) = @_;
353
354 print "$OPTVAR[0] ($var.$OPTVAR[0]),\n" unless ($OPT_NUM == 0);
355
356 for (my $i = 1; $i < $OPT_NUM; $i++)
357 {
358 print "${prefix}$OPTVAR[$i] ($var.$OPTVAR[$i]),\n";
359 }
360
361 print "${prefix}reset ($var.reset)\n";
362 }
363
364 sub emit_opt_class_header
365 {
366 my ($i, $s);
367
368 print <<"_END_EMIT_OPT_CLASS_HEADER_";
369 // DO NOT EDIT!
370 // Generated automatically from $DEFN_FILE.
371
372 #if !defined (octave_${CLASS_NAME}_h)
373 #define octave_${CLASS_NAME}_h 1
374
375 #include <cfloat>
376 #include <cmath>
377
378 $INCLUDE
379
380 class
381 $CLASS_NAME
382 {
383 public:
384
385 $CLASS_NAME (void)
386 _END_EMIT_OPT_CLASS_HEADER_
387
388 print ' : ';
389 emit_default_init_list (" ");
390
391 print " {
392 init ();
393 }
394
395 $CLASS_NAME (const ${CLASS_NAME}& opt)
396 : ";
397
398 emit_copy_ctor_init_list (" ", "opt");
399
400 print " { }
401
402 ${CLASS_NAME}& operator = (const ${CLASS_NAME}& opt)
403 {
404 if (this != &opt)
405 {\n";
406
407 emit_copy_body (' ', 'opt');
408
409 print " }
410
411 return *this;
412 }
413
414 ~$CLASS_NAME (void) { }\n";
415
416 print "\n void init (void)\n {\n";
417
418 for ($i = 0; $i < $OPT_NUM; $i++)
419 {
420 if ($INIT_VALUE[$i])
421 {
422 print " $OPTVAR[$i] = $INIT_VALUE[$i];\n";
423 }
424 elsif ($INIT_BODY[$i])
425 {
426 $s = substopt ($INIT_BODY[$i], $OPTVAR[$i], $OPT[$i], $TYPE[$i]);
427 chomp ($s);
428 $s =~ s/^\s*/ /g;
429 $s =~ s/\n\s*/\n /g;
430 print $s,"\n";
431 }
432 }
433
434 print " reset = true;\n",
435 " }\n";
436
437 ## For backward compatibility and because set_options is probably
438 ## a better name in some contexts:
439
440 print "\n void set_options (const ${CLASS_NAME}& opt)\n",
441 " {\n";
442
443 emit_copy_body (' ', 'opt');
444
445 print " }\n\n void set_default_options (void) { init (); }\n";
446
447 for ($i = 0; $i < $OPT_NUM; $i++)
448 {
449 if ($SET_EXPR[$i])
450 {
451 emit_set_decl ($i);
452
453 print "\n { $OPTVAR[$i] = $SET_EXPR[$i]; reset = true; }\n";
454 }
455 elsif ($SET_BODY[$i])
456 {
457 emit_set_decl ($i);
458
459 $s = substopt ($SET_BODY[$i], $OPTVAR[$i], $OPT[$i], $TYPE[$i]);
460 chomp ($s);
461 $s = ' ' . $s;
462 $s =~ s/\n/\n /g;
463 print "\n {\n$s\n reset = true;\n }\n";
464 }
465 elsif ($SET_CODE[$i])
466 {
467 $s = substopt ($SET_CODE[$i], $OPTVAR[$i], $OPT[$i], $TYPE[$i]);
468 chomp ($s);
469 $s =~ s/^ //g;
470 $s =~ s/\n /\n/g;
471 print "\n",$s,"\n";
472 }
473 }
474
475 for ($i = 0; $i < $OPT_NUM; $i++)
476 {
477 print " $TYPE[$i] $OPT[$i] (void) const\n { return $OPTVAR[$i]; }\n\n";
478 }
479
480 print "private:\n\n";
481
482 for ($i = 0; $i < $OPT_NUM; $i++)
483 {
484 print " $TYPE[$i] $OPTVAR[$i];\n";
485 }
486
487 print "\nprotected:\n\n bool reset;\n};\n\n#endif\n";
488 }
489
490 sub emit_set_decl
491 {
492 my ($i) = @_;
493
494 print "\n void set_$OPT[$i] ($SET_ARG_TYPE[$i] val)";
495 }
496
497 sub emit_opt_handler_fcns
498 {
499 my $header = $DEFN_FILE;
500 $header =~ s/[.]\w*$/.h/; # replace .in with .h
501 $header =~ s|^.*/([^/]*)$|$1|; # strip directory part
502
503 print <<"_END_EMIT_OPT_HANDLER_FCNS_";
504 // DO NOT EDIT!
505 // Generated automatically from $DEFN_FILE.
506
507 #ifdef HAVE_CONFIG_H
508 #include <config.h>
509 #endif
510
511 #include <iomanip>
512 #include <iostream>
513
514 #include "$header"
515
516 #include "defun-dld.h"
517 #include "pr-output.h"
518
519 #include "oct-obj.h"
520 #include "utils.h"
521 #include "pager.h"
522
523 static $CLASS_NAME $STATIC_OBJECT_NAME;
524
525 _END_EMIT_OPT_HANDLER_FCNS_
526
527 &emit_struct_decl;
528
529 &emit_struct_def;
530
531 &emit_print_function;
532
533 &emit_set_functions;
534
535 &emit_show_function;
536
537 &emit_options_function;
538 }
539
540 sub emit_struct_decl
541 {
542 print <<"_END_PRINT_STRUCT_DECL_";
543 #define MAX_TOKENS $MAX_TOKENS
544
545 struct $STRUCT_NAME
546 {
547 const char *keyword;
548 const char *kw_tok[MAX_TOKENS + 1];
549 int min_len[MAX_TOKENS + 1];
550 int min_toks_to_match;
551 };
552
553 _END_PRINT_STRUCT_DECL_
554 }
555
556 sub emit_struct_def
557 {
558 my $i;
559
560 print "#define NUM_OPTIONS $OPT_NUM\n\n";
561
562 print "static $STRUCT_NAME $STATIC_TABLE_NAME [] =\n{\n";
563
564 for ($i = 0; $i < ($OPT_NUM - 1); $i++)
565 {
566 emit_option_table_entry ($i, 0);
567 print "\n";
568 }
569 emit_option_table_entry ($i, 0);
570
571 print "};\n\n";
572 }
573
574 sub emit_option_table_entry
575 {
576 my ($i, $empty) = @_;
577
578 my $k;
579
580 if ($empty)
581 {
582 print " { 0,\n";
583 }
584 else
585 {
586 print " { \"$NAME[$i]\",\n";
587 }
588
589 my $n = scalar $#{$KW_TOK[$i]};
590 print " {";
591 for $k (0 .. $MAX_TOKENS)
592 {
593 if ($empty or $k > $n)
594 {
595 print " 0,";
596 }
597 else
598 {
599 print " \"$KW_TOK[$i][$k]\",";
600 }
601 }
602 print " },\n";
603
604 print " {";
605 for $k (0 .. $MAX_TOKENS)
606 {
607 if ($empty or $k > $n)
608 {
609 print " 0,";
610 }
611 else
612 {
613 print " $MIN_TOK_LEN_TO_MATCH[$i][$k],";
614 }
615 }
616 print " }, $MIN_TOKS_TO_MATCH[$i], ";
617
618 print "},\n";
619 }
620
621 sub emit_print_function
622 {
623 ## FIXME -- determine the width of the table automatically.
624
625 print qq|static void
626 print_$CLASS_NAME (std::ostream& os)
627 {
628 std::ostringstream buf;
629
630 os << "\\n"
631 << "Options for $CLASS include:\\n\\n"
632 << " keyword value\\n"
633 << " ------- -----\\n";
634
635 $STRUCT_NAME *list = $STATIC_TABLE_NAME;\n\n|;
636
637 for (my $i = 0; $i < $OPT_NUM; $i++)
638 {
639 print qq| {\n os << " "
640 << std::setiosflags (std::ios::left) << std::setw (50)
641 << list[$i].keyword
642 << std::resetiosflags (std::ios::left)
643 << " ";\n\n|;
644
645 if ($TYPE[$i] eq "double")
646 {
647 print qq| double val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n|;
648 print qq| os << val << "\\n";\n|;
649 }
650 elsif ($TYPE[$i] eq "float")
651 {
652 print qq| float val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n|;
653 print qq| os << val << "\\n";\n|;
654 }
655 elsif ($TYPE[$i] eq "int" or $TYPE[$i] eq "octave_idx_type")
656 {
657 print qq| int val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n|;
658 print qq| os << val << "\\n";\n|;
659 }
660 elsif ($TYPE[$i] eq "std::string")
661 {
662 print qq| os << $STATIC_OBJECT_NAME.$OPT[$i] () << "\\n";\n|;
663 }
664 elsif ($TYPE[$i] eq "Array<int>" or $TYPE[$i] eq "Array<octave_idx_type>")
665 {
666 my $elt_type;
667 if ($TYPE[$i] eq "Array<int>")
668 {
669 $elt_type = "int";
670 }
671 else
672 {
673 $elt_type = "octave_idx_type";
674 }
675 print qq| Array<$elt_type> val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n|;
676 print qq| if (val.length () == 1)
677 {
678 os << val(0) << "\\n";
679 }
680 else
681 {
682 os << "\\n\\n";
683 octave_idx_type len = val.length ();
684 Matrix tmp (len, 1);
685 for (octave_idx_type i = 0; i < len; i++)
686 tmp(i,0) = val(i);
687 octave_print_internal (os, tmp, false, 2);
688 os << "\\n\\n";
689 }\n|;
690 }
691 elsif ($TYPE[$i] eq "Array<double>")
692 {
693 print qq| Array<double> val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n|;
694 print qq| if (val.length () == 1)
695 {
696 os << val(0) << "\\n";
697 }
698 else
699 {
700 os << "\\n\\n";
701 Matrix tmp = Matrix (ColumnVector (val));
702 octave_print_internal (os, tmp, false, 2);
703 os << "\\n\\n";
704 }\n|;
705 }
706 elsif ($TYPE[$i] eq "Array<float>")
707 {
708 print qq| Array<float> val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n|;
709 print qq| if (val.length () == 1)
710 {
711 os << val(0) << "\\n";
712 }
713 else
714 {
715 os << "\\n\\n";
716 FloatMatrix tmp = FloatMatrix (FloatColumnVector (val));
717 octave_print_internal (os, tmp, false, 2);
718 os << "\\n\\n";
719 }\n|;
720 }
721 else
722 {
723 die ("unknown type $TYPE[$i]");
724 }
725
726 print " }\n\n";
727 }
728
729 print qq| os << "\\n";\n}\n\n|;
730 }
731
732 sub emit_set_functions
733 {
734 print "static void
735 set_$CLASS_NAME (const std::string& keyword, const octave_value& val)
736 {
737 $STRUCT_NAME *list = $STATIC_TABLE_NAME;\n\n";
738
739 my $iftok = "if";
740
741 for (my $i = 0; $i < $OPT_NUM; $i++)
742 {
743 $iftok = "else if" if ($i > 0);
744
745 print " $iftok (keyword_almost_match (list[$i].kw_tok, list[$i].min_len,
746 keyword, list[$i].min_toks_to_match, MAX_TOKENS))
747 {\n";
748
749 if ($TYPE[$i] eq "double")
750 {
751 print " double tmp = val.double_value ();\n\n";
752 print " if (! error_state)
753 $STATIC_OBJECT_NAME.set_$OPT[$i] (tmp);\n";
754 }
755 elsif ($TYPE[$i] eq "float")
756 {
757 print " float tmp = val.float_value ();\n\n";
758 print " if (! error_state)
759 $STATIC_OBJECT_NAME.set_$OPT[$i] (tmp);\n";
760 }
761 elsif ($TYPE[$i] eq "int" or $TYPE[$i] eq "octave_idx_type")
762 {
763 print " int tmp = val.int_value ();\n\n";
764 print " if (! error_state)
765 $STATIC_OBJECT_NAME.set_$OPT[$i] (tmp);\n";
766 }
767 elsif ($TYPE[$i] eq "std::string")
768 {
769 print " std::string tmp = val.string_value ();\n\n";
770 print " if (! error_state)
771 $STATIC_OBJECT_NAME.set_$OPT[$i] (tmp);\n";
772 }
773 elsif ($TYPE[$i] eq "Array<int>" or $TYPE[$i] eq "Array<octave_idx_type>")
774 {
775 print " Array<int> tmp = val.int_vector_value ();\n\n";
776 print " if (! error_state)
777 $STATIC_OBJECT_NAME.set_$OPT[$i] (tmp);\n";
778 }
779 elsif ($TYPE[$i] eq "Array<double>")
780 {
781 print " Array<double> tmp = val.vector_value ();\n\n";
782 print " if (! error_state)
783 $STATIC_OBJECT_NAME.set_$OPT[$i] (tmp);\n";
784 }
785 elsif ($TYPE[$i] eq "Array<float>")
786 {
787 print " Array<float> tmp = val.float_vector_value ();\n\n";
788 print " if (! error_state)
789 $STATIC_OBJECT_NAME.set_$OPT[$i] (tmp);\n";
790 }
791 else
792 {
793 die ("unknown type $TYPE[$i]");
794 }
795
796 print " }\n";
797 }
798
799 print qq| else
800 {
801 warning ("$OPT_FCN_NAME: no match for `%s'", keyword.c_str ());
802 }
803 }\n\n|;
804 }
805
806 sub emit_show_function
807 {
808 print "static octave_value_list
809 show_$CLASS_NAME (const std::string& keyword)
810 {
811 octave_value retval;
812
813 $STRUCT_NAME *list = $STATIC_TABLE_NAME;\n\n";
814
815 my $iftok = "if";
816
817 for (my $i = 0; $i < $OPT_NUM; $i++)
818 {
819 $iftok = "else if" if ($i > 0);
820
821 print " $iftok (keyword_almost_match (list[$i].kw_tok, list[$i].min_len,
822 keyword, list[$i].min_toks_to_match, MAX_TOKENS))
823 {\n";
824
825 if ($TYPE[$i] eq "double")
826 {
827 print " double val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n";
828 print " retval = val;\n";
829 }
830 elsif ($TYPE[$i] eq "float")
831 {
832 print " float val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n";
833 print " retval = val;\n";
834 }
835 elsif ($TYPE[$i] eq "int" or $TYPE[$i] eq "octave_idx_type")
836 {
837 print " int val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n";
838 print " retval = static_cast<double> (val);\n";
839 }
840 elsif ($TYPE[$i] eq "std::string")
841 {
842 print " retval = $STATIC_OBJECT_NAME.$OPT[$i] ();\n";
843 }
844 elsif ($TYPE[$i] eq "Array<int>" or $TYPE[$i] eq "Array<octave_idx_type>")
845 {
846 my $elt_type;
847 if ($TYPE[$i] eq "Array<int>")
848 {
849 $elt_type = "int";
850 }
851 else
852 {
853 $elt_type = "octave_idx_type";
854 }
855 print " Array<$elt_type> val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n";
856 print " if (val.length () == 1)
857 {
858 retval = static_cast<double> (val(0));
859 }
860 else
861 {
862 octave_idx_type len = val.length ();
863 ColumnVector tmp (len);
864 for (octave_idx_type i = 0; i < len; i++)
865 tmp(i) = val(i);
866 retval = tmp;
867 }\n";
868 }
869 elsif ($TYPE[$i] eq "Array<double>")
870 {
871 print " Array<double> val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n";
872 print " if (val.length () == 1)
873 {
874 retval = val(0);
875 }
876 else
877 {
878 retval = ColumnVector (val);
879 }\n";
880 }
881 elsif ($TYPE[$i] eq "Array<float>")
882 {
883 print " Array<float> val = $STATIC_OBJECT_NAME.$OPT[$i] ();\n\n";
884 print " if (val.length () == 1)
885 {
886 retval = val(0);
887 }
888 else
889 {
890 retval = FloatColumnVector (val);
891 }\n";
892 }
893 else
894 {
895 die ("unknown type $TYPE[$i]");
896 }
897
898 print " }\n";
899 }
900
901 print qq| else
902 {
903 warning ("$OPT_FCN_NAME: no match for `%s'", keyword.c_str ());
904 }
905
906 return retval;\n}\n\n|;
907 }
908
909 sub emit_options_function
910 {
911 print <<"_END_EMIT_OPTIONS_FUNCTION_HDR_";
912 DEFUN_DLD ($OPT_FCN_NAME, args, ,
913 "-*- texinfo -*-\\n\\
914 \@deftypefn {Loadable Function} {} $OPT_FCN_NAME ()\\n\\
915 \@deftypefnx {Loadable Function} {val =} $OPT_FCN_NAME (\@var{opt})\\n\\
916 \@deftypefnx {Loadable Function} {} $OPT_FCN_NAME (\@var{opt}, \@var{val})\\n\\
917 $DOC_STRING\\n\\
918 \\n\\
919 Options include\\n\\
920 \\n\\
921 \@table \@code\\n\\
922 _END_EMIT_OPTIONS_FUNCTION_HDR_
923 # FIXME: Add extra newline above
924
925 for (my $i = 0; $i < $OPT_NUM; $i++)
926 {
927 print '@item \"', $NAME[$i], '\"\n\\', "\n";
928 print $DOC_ITEM[$i] if $DOC_ITEM[$i];
929 }
930
931 print <<"_END_EMIT_OPTIONS_FUNCTION_BODY_";
932 \@end table\\n\\
933 \@end deftypefn")
934 {
935 octave_value_list retval;
936
937 int nargin = args.length ();
938
939 if (nargin == 0)
940 {
941 print_$CLASS_NAME (octave_stdout);
942 }
943 else if (nargin == 1 || nargin == 2)
944 {
945 std::string keyword = args(0).string_value ();
946
947 if (! error_state)
948 {
949 if (nargin == 1)
950 retval = show_$CLASS_NAME (keyword);
951 else
952 set_$CLASS_NAME (keyword, args(1));
953 }
954 else
955 error ("$OPT_FCN_NAME: expecting keyword as first argument");
956 }
957 else
958 print_usage ();
959
960 return retval;
961 }
962 _END_EMIT_OPTIONS_FUNCTION_BODY_
963
964 }
965
966 sub emit_options_debug
967 {
968 print qq|CLASS = "$CLASS"\n|;
969
970 for (my $i = 0; $i < $OPT_NUM; $i++)
971 {
972 print "\nOPTION\n";
973 print qq| NAME = "$NAME[$i]"\n|;
974 print qq| TYPE = "$TYPE[$i]"\n|;
975 if ($SET_ARG_TYPE[$i])
976 {
977 print eval ("\" SET_ARG_TYPE = \\\"$SET_ARG_TYPE[$i]\\\"\"") . "\n";
978 }
979 if ($INIT_VALUE[$i])
980 {
981 print qq| INIT_VALUE = "$INIT_VALUE[$i]"\n|;
982 }
983 if ($INIT_BODY[$i])
984 {
985 print " INIT_BODY\n";
986 print &substopt ($INIT_BODY[$i]);
987 print " END_INIT_BODY\n";
988 }
989 if ($SET_EXPR[$i])
990 {
991 print qq| SET_EXPR = "$SET_EXPR[$i]"\n|;
992 }
993 if ($SET_BODY[$i])
994 {
995 print " SET_BODY\n";
996 print &substopt ($SET_BODY[$i]);
997 print " END_SET_BODY\n";
998 }
999 if ($SET_CODE[$i])
1000 {
1001 print " SET_CODE\n";
1002 print &substopt ($SET_CODE[$i]);
1003 print " END_SET_CODE\n";
1004 }
1005 print "END_OPTION\n";
1006 }
1007 }
1008
1009 sub substopt
1010 {
1011 my ($string, $optvar, $opt, $type) = @_;
1012
1013 $string =~ s/\$OPTVAR/$optvar/g;
1014 $string =~ s/\$OPT/$opt/g;
1015 $string =~ s/\$TYPE/$type/g;
1016
1017 return $string;
1018 }
1019
1020 sub max
1021 {
1022 my $max = shift;
1023
1024 foreach (@_)
1025 {
1026 $max = $_ if $max < $_;
1027 }
1028
1029 return $max;
1030 }
1031
1032 ################################################################################
1033 # Subroutine processes any command line arguments
1034 ################################################################################
1035 sub parse_options
1036 {
1037 my $result;
1038
1039 $opt_help = 0;
1040 $opt_class_header = 0;
1041 $opt_handler_fcns = 0;
1042 $opt_debug = 0;
1043
1044 $result = GetOptions ("opt-class-header" => \$opt_class_header,
1045 "opt-handler-fcns" => \$opt_handler_fcns,
1046 "debug" => \$opt_debug,
1047 "help" => \$opt_help);
1048
1049 # give user info if options incorrect or -h(elp) given
1050 &usage_info if (!$result or (@ARGV != 1) or $opt_help);
1051 if ($opt_class_header and $opt_handler_fcns)
1052 {
1053 die "Only one of [-opt-class-header | -opt-handler-fcns ] may be specified";
1054 }
1055
1056 }
1057
1058 ################################################################################
1059 # Subroutine displays usage information
1060 ################################################################################
1061 sub usage_info
1062 {
1063 warn <<_END_OF_USAGE_;
1064 //////////////////////////////////////////////////////////////////////////////
1065 USAGE : mk-opts.pl -opt-class-header|-opt-handler-fcns [-debug] [-help] DEFN_FILE
1066 //////////////////////////////////////////////////////////////////////////////
1067
1068 Automatically generate C++ code for option handling code (DASSL, DASRT, etc.)
1069 from definition file.
1070
1071 See the head of mk-opts.pl for a description of the format that is parsed.
1072 _END_OF_USAGE_
1073
1074 exit(1); # exit with error code
1075 }
1076