pintos-os.org Git - pspp/blob - src/language/expressions/generate.pl

   1 # PSPP - a program for statistical analysis.
   2 # Copyright (C) 2017 Free Software Foundation, Inc.
   3 #
   4 # This program is free software: you can redistribute it and/or modify
   5 # it under the terms of the GNU General Public License as published by
   6 # the Free Software Foundation, either version 3 of the License, or
   7 # (at your option) any later version.
   8 #
   9 # This program is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 # GNU General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU General Public License
  15 # along with this program.  If not, see <http://www.gnu.org/licenses/>.
  16 #
  17 use strict;
  18 use warnings 'all';
  19
  20 use Getopt::Long;
  21
  22 # Parse command line.
  23 our ($input_file);
  24 our ($output_file);
  25 parse_cmd_line ();
  26
  27 # Initialize type system.
  28 our (%type, @types);
  29 init_all_types ();
  30
  31 # Parse input file.
  32 our (%ops);
  33 our (@funcs, @opers, @order);
  34 parse_input ();
  35
  36 # Produce output.
  37 print_header ();
  38 if ($output_file =~ /evaluate\.h$/) {
  39     generate_evaluate_h ();
  40 } elsif ($output_file =~ /evaluate\.inc$/) {
  41     generate_evaluate_inc ();
  42 } elsif ($output_file =~ /operations\.h$/) {
  43     generate_operations_h ();
  44 } elsif ($output_file =~ /optimize\.inc$/) {
  45     generate_optimize_inc ();
  46 } elsif ($output_file =~ /parse\.inc$/) {
  47     generate_parse_inc ();
  48 } else {
  49     die "$output_file: unknown output type\n";
  50 }
  51 print_trailer ();
  52 \f
  53 # Command line.
  54
  55 # Parses the command line.
  56 #
  57 # Initializes $input_file, $output_file.
  58 sub parse_cmd_line {
  59     GetOptions ("i|input=s" => \$input_file,
  60                 "o|output=s" => \$output_file,
  61                 "h|help" => sub { usage (); })
  62       or exit 1;
  63
  64     $input_file = "operations.def" if !defined $input_file;
  65     die "$0: output file must be specified\n" if !defined $output_file;
  66
  67     open (INPUT, "<$input_file") or die "$input_file: open: $!\n";
  68     open (OUTPUT, ">$output_file") or die "$output_file: create: $!\n";
  69
  70     select (OUTPUT);
  71 }
  72
  73 sub usage {
  74     print <<EOF;
  75 $0, for generating expression parsers and evaluators from definitions
  76 usage: generate.pl -o OUTPUT [-i INPUT] [-h]
  77   -i INPUT    input file containing definitions (default: operations.def)
  78   -o OUTPUT   output file
  79   -h          display this help message
  80 EOF
  81     exit (0);
  82 }
  83
  84 our ($token);
  85 our ($toktype);
  86 \f
  87 # Types.
  88
  89 # Defines all our types.
  90 #
  91 # Initializes %type, @types.
  92 sub init_all_types {
  93     # Common user-visible types used throughout evaluation trees.
  94     init_type ('number', 'any', C_TYPE => 'double',
  95                ATOM => 'number', MANGLE => 'n', HUMAN_NAME => 'number',
  96                STACK => 'ns', MISSING_VALUE => 'SYSMIS');
  97     init_type ('string', 'any', C_TYPE => 'struct substring',
  98                ATOM => 'string', MANGLE => 's', HUMAN_NAME => 'string',
  99                STACK => 'ss', MISSING_VALUE => 'empty_string');
 100     init_type ('boolean', 'any', C_TYPE => 'double',
 101                ATOM => 'number', MANGLE => 'n', HUMAN_NAME => 'boolean',
 102                STACK => 'ns', MISSING_VALUE => 'SYSMIS');
 103
 104     # Format types.
 105     init_type ('format', 'atom');
 106     init_type ('ni_format', 'leaf', C_TYPE => 'const struct fmt_spec *',
 107                ATOM => 'format', MANGLE => 'f',
 108                HUMAN_NAME => 'num_input_format');
 109     init_type ('no_format', 'leaf', C_TYPE => 'const struct fmt_spec *',
 110                ATOM => 'format', MANGLE => 'f',
 111                HUMAN_NAME => 'num_output_format');
 112
 113     # Integer types.
 114     init_type ('integer', 'leaf', C_TYPE => 'int',
 115                ATOM => 'integer', MANGLE => 'n', HUMAN_NAME => 'integer');
 116     init_type ('pos_int', 'leaf', C_TYPE => 'int',
 117                ATOM => 'integer', MANGLE => 'n',
 118                HUMAN_NAME => 'positive_integer_constant');
 119
 120     # Variable names.
 121     init_type ('variable', 'atom');
 122     init_type ('num_var', 'leaf', C_TYPE => 'const struct variable *',
 123                ATOM => 'variable', MANGLE => 'Vn',
 124                HUMAN_NAME => 'num_variable');
 125     init_type ('str_var', 'leaf', C_TYPE => 'const struct variable *',
 126                ATOM => 'variable', MANGLE => 'Vs',
 127                HUMAN_NAME => 'string_variable');
 128     init_type ('var', 'leaf', C_TYPE => 'const struct variable *',
 129                ATOM => 'variable', MANGLE => 'V',
 130                HUMAN_NAME => 'variable');
 131
 132     # Vectors.
 133     init_type ('vector', 'leaf', C_TYPE => 'const struct vector *',
 134                ATOM => 'vector', MANGLE => 'v', HUMAN_NAME => 'vector');
 135
 136     # Fixed types.
 137     init_type ('expression', 'fixed', C_TYPE => 'struct expression *',
 138                FIXED_VALUE => 'e');
 139     init_type ('case', 'fixed', C_TYPE => 'const struct ccase *',
 140                FIXED_VALUE => 'c');
 141     init_type ('case_idx', 'fixed', C_TYPE => 'size_t',
 142                FIXED_VALUE => 'case_idx');
 143     init_type ('dataset', 'fixed', C_TYPE => 'struct dataset *',
 144                FIXED_VALUE => 'ds');
 145
 146     # One of these is emitted at the end of each expression as a sentinel
 147     # that tells expr_evaluate() to return the value on the stack.
 148     init_type ('return_number', 'atom');
 149     init_type ('return_string', 'atom');
 150
 151     # Used only for debugging purposes.
 152     init_type ('operation', 'atom');
 153 }
 154
 155 # init_type has 2 required arguments:
 156 #
 157 #   NAME: Type name.
 158 #
 159 #           `$name' is the type's name in operations.def.
 160 #
 161 #           `OP_$name' is the terminal's type in operations.h.
 162 #
 163 #           `expr_allocate_$name()' allocates a node of the given type.
 164 #
 165 #   ROLE: How the type may be used:
 166 #
 167 #           "any": Usable as operands and function arguments, and
 168 #           function and operator results.
 169 #
 170 #           "leaf": Usable as operands and function arguments, but
 171 #           not function arguments or results.  (Thus, they appear
 172 #           only in leaf nodes in the parse type.)
 173 #
 174 #           "fixed": Not allowed either as an operand or argument
 175 #           type or a result type.  Used only as auxiliary data.
 176 #
 177 #           "atom": Not allowed anywhere; just adds the name to
 178 #           the list of atoms.
 179 #
 180 # All types except those with "atom" as their role also require:
 181 #
 182 #   C_TYPE: The C type that represents this abstract type.
 183 #
 184 # Types with "any" or "leaf" role require:
 185 #
 186 #   ATOM:
 187 #
 188 #           `$atom' is the `struct operation_data' member name.
 189 #
 190 #           get_$atom_name() obtains the corresponding data from a
 191 #           node.
 192 #
 193 #   MANGLE: Short string for name mangling.  Use identical strings
 194 #   if two types should not be overloaded.
 195 #
 196 #   HUMAN_NAME: Name for a type when we describe it to the user.
 197 #
 198 # Types with role "any" require:
 199 #
 200 #   STACK: Name of the local variable in expr_evaluate(), used for
 201 #   maintaining the stack for this type.
 202 #
 203 #   MISSING_VALUE: Expression used for the missing value of this
 204 #   type.
 205 #
 206 # Types with role "fixed" require:
 207 #
 208 #   FIXED_VALUE: Expression used for the value of this type.
 209 sub init_type {
 210     my ($name, $role, %rest) = @_;
 211     my ($type) = $type{"\U$name"} = {NAME => $name, ROLE => $role, %rest};
 212
 213     my (@need_keys) = qw (NAME ROLE);
 214     if ($role eq 'any') {
 215         push (@need_keys, qw (C_TYPE ATOM MANGLE HUMAN_NAME STACK MISSING_VALUE));
 216     } elsif ($role eq 'leaf') {
 217         push (@need_keys, qw (C_TYPE ATOM MANGLE HUMAN_NAME));
 218     } elsif ($role eq 'fixed') {
 219         push (@need_keys, qw (C_TYPE FIXED_VALUE));
 220     } elsif ($role eq 'atom') {
 221     } else {
 222         die "no role `$role'";
 223     }
 224
 225     my (%have_keys);
 226     $have_keys{$_} = 1 foreach keys %$type;
 227     for my $key (@need_keys) {
 228         defined $type->{$key} or die "$name lacks $key";
 229         delete $have_keys{$key};
 230     }
 231     scalar (keys (%have_keys)) == 0
 232       or die "$name has superfluous key(s) " . join (', ', keys (%have_keys));
 233
 234     push (@types, $type);
 235 }
 236
 237 # c_type(type).
 238 #
 239 # Returns the C type of the given type as a string designed to be
 240 # prepended to a variable name to produce a declaration.  (That won't
 241 # work in general but it works well enough for our types.)
 242 sub c_type {
 243     my ($type) = @_;
 244     my ($c_type) = $type->{C_TYPE};
 245     defined $c_type or die;
 246
 247     # Append a space unless (typically) $c_type ends in `*'.
 248     $c_type .= ' ' if $c_type =~ /\w$/;
 249
 250     return $c_type;
 251 }
 252 \f
 253 # Input parsing.
 254
 255 # Parses the entire input.
 256 #
 257 # Initializes %ops, @funcs, @opers.
 258 sub parse_input {
 259     get_line ();
 260     get_token ();
 261     while ($toktype ne 'eof') {
 262         my (%op);
 263
 264         $op{OPTIMIZABLE} = 1;
 265         $op{UNIMPLEMENTED} = 0;
 266         $op{EXTENSION} = 0;
 267         $op{PERM_ONLY} = 0;
 268         for (;;) {
 269             if (match ('extension')) {
 270                 $op{EXTENSION} = 1;
 271             } elsif (match ('no_opt')) {
 272                 $op{OPTIMIZABLE} = 0;
 273             } elsif (match ('absorb_miss')) {
 274                 $op{ABSORB_MISS} = 1;
 275             } elsif (match ('perm_only')) {
 276                 $op{PERM_ONLY} = 1;
 277             } elsif (match ('no_abbrev')) {
 278                 $op{NO_ABBREV} = 1;
 279             } else {
 280                 last;
 281             }
 282         }
 283
 284         $op{RETURNS} = parse_type () || $type{NUMBER};
 285         die "$op{RETURNS} is not a valid return type"
 286           if !any ($op{RETURNS}, @type{qw (NUMBER STRING BOOLEAN)});
 287
 288         $op{CATEGORY} = $token;
 289         if (!any ($op{CATEGORY}, qw (operator function))) {
 290             die "`operator' or `function' expected at `$token'";
 291         }
 292         get_token ();
 293
 294         my ($name) = force ("id");
 295
 296         die "function name may not contain underscore"
 297           if $op{CATEGORY} eq 'function' && $name =~ /_/;
 298         die "operator name may not contain period"
 299           if $op{CATEGORY} eq 'operator' && $name =~ /\./;
 300
 301         if (my ($prefix, $suffix) = $name =~ /^(.*)\.(\d+)$/) {
 302             $name = $prefix;
 303             $op{MIN_VALID} = $suffix;
 304             $op{ABSORB_MISS} = 1;
 305         }
 306         $op{NAME} = $name;
 307
 308         force_match ('(');
 309         @{$op{ARGS}} = ();
 310         while (!match (')')) {
 311             my ($arg) = parse_arg ();
 312             push (@{$op{ARGS}}, $arg);
 313             if (defined ($arg->{IDX})) {
 314                 last if match (')');
 315                 die "array must be last argument";
 316             }
 317             if (!match (',')) {
 318                 force_match (')');
 319                 last;
 320             }
 321         }
 322
 323         for my $arg (@{$op{ARGS}}) {
 324             next if !defined $arg->{CONDITION};
 325             my ($any_arg) = join ('|', map ($_->{NAME}, @{$op{ARGS}}));
 326             $arg->{CONDITION} =~ s/\b($any_arg)\b/arg_$1/g;
 327         }
 328
 329         my ($opname) = "OP_$op{NAME}";
 330         $opname =~ tr/./_/;
 331         if ($op{CATEGORY} eq 'function') {
 332             my ($mangle) = join ('', map ($_->{TYPE}{MANGLE}, @{$op{ARGS}}));
 333             $op{MANGLE} = $mangle;
 334             $opname .= "_$mangle";
 335         }
 336         $op{OPNAME} = $opname;
 337
 338         if ($op{MIN_VALID}) {
 339             my ($array_arg) = array_arg (\%op);
 340             die "can't have minimum valid count without array arg"
 341               if !defined $array_arg;
 342             die "minimum valid count allowed only with double array"
 343               if $array_arg->{TYPE} ne $type{NUMBER};
 344             die "can't have minimum valid count if array has multiplication factor"
 345               if $array_arg->{TIMES} != 1;
 346         }
 347
 348         while ($toktype eq 'id') {
 349             my ($type) = parse_type () or die "parse error";
 350             die "`$type->{NAME}' is not allowed as auxiliary data"
 351               unless $type->{ROLE} eq 'leaf' || $type->{ROLE} eq 'fixed';
 352             my ($name) = force ("id");
 353             push (@{$op{AUX}}, {TYPE => $type, NAME => $name});
 354             force_match (';');
 355         }
 356
 357         if ($op{OPTIMIZABLE}) {
 358             die "random variate functions must be marked `no_opt'"
 359               if $op{NAME} =~ /^RV\./;
 360             for my $aux (@{$op{AUX}}) {
 361                 if (any ($aux->{TYPE}, @type{qw (CASE CASE_IDX)})) {
 362                     die "operators with $aux->{TYPE} aux data must be "
 363                       . "marked `no_opt'";
 364                 }
 365             }
 366         }
 367
 368         if ($op{RETURNS} eq $type{STRING} && !defined ($op{ABSORB_MISS})) {
 369             my (@args);
 370             for my $arg (@{$op{ARGS}}) {
 371                 if (any ($arg->{TYPE}, @type{qw (NUMBER BOOLEAN)})) {
 372                     die "$op{NAME} returns string and has double or bool "
 373                       . "argument, but is not marked ABSORB_MISS";
 374                 }
 375                 if (defined $arg->{CONDITION}) {
 376                     die "$op{NAME} returns string but has argument with condition";
 377                 }
 378             }
 379         }
 380
 381         if ($toktype eq 'block') {
 382             $op{BLOCK} = force ('block');
 383         } elsif ($toktype eq 'expression') {
 384             if ($token eq 'unimplemented') {
 385                 $op{UNIMPLEMENTED} = 1;
 386             } else {
 387                 $op{EXPRESSION} = $token;
 388             }
 389             get_token ();
 390         } else {
 391             die "block or expression expected";
 392         }
 393
 394         die "duplicate operation name $opname" if defined $ops{$opname};
 395         $ops{$opname} = \%op;
 396         if ($op{CATEGORY} eq 'function') {
 397             push (@funcs, $opname);
 398         } else {
 399             push (@opers, $opname);
 400         }
 401     }
 402     close(INPUT);
 403
 404     @funcs = sort {$ops{$a}->{NAME} cmp $ops{$b}->{NAME}
 405                      ||
 406                        $ops{$a}->{OPNAME} cmp $ops{$b}->{OPNAME}}
 407       @funcs;
 408     @opers = sort {$ops{$a}->{NAME} cmp $ops{$b}->{NAME}} @opers;
 409     @order = (@funcs, @opers);
 410 }
 411
 412 # Reads the next token into $token, $toktype.
 413 sub get_token {
 414     our ($line);
 415     lookahead ();
 416     return if defined ($toktype) && $toktype eq 'eof';
 417     $toktype = 'id', $token = $1, return
 418         if $line =~ /\G([a-zA-Z_][a-zA-Z_.0-9]*)/gc;
 419     $toktype = 'int', $token = $1, return if $line =~ /\G([0-9]+)/gc;
 420     $toktype = 'punct', $token = $1, return if $line =~ /\G([][(),*;.])/gc;
 421     if ($line =~ /\G=/gc) {
 422         $toktype = "expression";
 423         $line =~ /\G\s+/gc;
 424         $token = accumulate_balanced (';');
 425     } elsif ($line =~ /\G\{/gc) {
 426         $toktype = "block";
 427         $token = accumulate_balanced ('}');
 428         $token =~ s/^\n+//;
 429     } else {
 430         die "bad character `" . substr ($line, pos $line, 1) . "' in input";
 431     }
 432 }
 433
 434 # Skip whitespace, then return the remainder of the line.
 435 sub lookahead {
 436     our ($line);
 437     die "unexpected end of file" if !defined ($line);
 438     for (;;) {
 439         $line =~ /\G\s+/gc;
 440         last if pos ($line) < length ($line);
 441         get_line ();
 442         $token = $toktype = 'eof', return if !defined ($line);
 443     }
 444     return substr ($line, pos ($line));
 445 }
 446
 447 # accumulate_balanced($chars)
 448 #
 449 # Accumulates input until a character in $chars is encountered, except
 450 # that balanced pairs of (), [], or {} cause $chars to be ignored.
 451 #
 452 # Returns the input read.
 453 sub accumulate_balanced {
 454     my ($end) = @_;
 455     my ($s) = "";
 456     my ($nest) = 0;
 457     our ($line);
 458     for (;;) {
 459         my ($start) = pos ($line);
 460         if ($line =~ /\G([^][(){};,]*)([][(){};,])/gc) {
 461             $s .= substr ($line, $start, pos ($line) - $start - 1)
 462                 if pos ($line) > $start;
 463             my ($last) = substr ($line, pos ($line) - 1, 1);
 464             if ($last =~ /[[({]/) {
 465                 $nest++;
 466                 $s .= $last;
 467             } elsif ($last =~ /[])}]/) {
 468                 if ($nest > 0) {
 469                     $nest--;
 470                     $s .= $last;
 471                 } elsif (index ($end, $last) >= 0) {
 472                     return $s;
 473                 } else {
 474                     die "unbalanced parentheses";
 475                 }
 476             } elsif (index ($end, $last) >= 0) {
 477                 return $s if !$nest;
 478                 $s .= $last;
 479             } else {
 480                 $s .= $last;
 481             }
 482         } else {
 483             $s .= substr ($line, pos ($line)) . "\n";
 484             get_line ();
 485         }
 486     }
 487 }
 488
 489 # Reads the next line from INPUT into $line.
 490 sub get_line {
 491     our ($line);
 492     $line = <INPUT>;
 493     if (defined ($line)) {
 494         chomp $line;
 495         $line =~ s%//.*%%;
 496         pos ($line) = 0;
 497     }
 498 }
 499
 500 # If the current token is an identifier that names a type,
 501 # returns the type and skips to the next token.
 502 # Otherwise, returns undef.
 503 sub parse_type {
 504     if ($toktype eq 'id') {
 505         foreach my $type (values (%type)) {
 506             get_token (), return $type
 507               if defined ($type->{NAME}) && $type->{NAME} eq $token;
 508         }
 509     }
 510     return;
 511 }
 512
 513 # force($type).
 514 #
 515 # Makes sure that $toktype equals $type, reads the next token, and
 516 # returns the previous $token.
 517 sub force {
 518     my ($type) = @_;
 519     die "parse error at `$token' expecting $type"
 520         if $type ne $toktype;
 521     my ($tok) = $token;
 522     get_token ();
 523     return $tok;
 524 }
 525
 526 # force($tok).
 527 #
 528 # If $token equals $tok, reads the next token and returns true.
 529 # Otherwise, returns false.
 530 sub match {
 531     my ($tok) = @_;
 532     if ($token eq $tok) {
 533         get_token ();
 534         return 1;
 535     } else {
 536         return 0;
 537     }
 538 }
 539
 540 # force_match($tok).
 541 #
 542 # If $token equals $tok, reads the next token.
 543 # Otherwise, flags an error in the input.
 544 sub force_match {
 545     my ($tok) = @_;
 546     die "parse error at `$token' expecting `$tok'" if !match ($tok);
 547 }
 548
 549 # Parses and returns a function argument.
 550 sub parse_arg {
 551     my (%arg);
 552     $arg{TYPE} = parse_type () || $type{NUMBER};
 553     die "argument name expected at `$token'" if $toktype ne 'id';
 554     $arg{NAME} = $token;
 555
 556     if (lookahead () =~ /^[[,)]/) {
 557         get_token ();
 558         if (match ('[')) {
 559             die "only double and string arrays supported"
 560               if !any ($arg{TYPE}, @type{qw (NUMBER STRING)});
 561             $arg{IDX} = force ('id');
 562             if (match ('*')) {
 563                 $arg{TIMES} = force ('int');
 564                 die "multiplication factor must be two"
 565                   if $arg{TIMES} != 2;
 566             } else {
 567                 $arg{TIMES} = 1;
 568             }
 569             force_match (']');
 570         }
 571     } else {
 572         $arg{CONDITION} = $arg{NAME} . ' ' . accumulate_balanced (',)');
 573         our ($line);
 574         pos ($line) -= 1;
 575         get_token ();
 576     }
 577     return \%arg;
 578 }
 579 \f
 580 # Output.
 581
 582 # Prints the output file header.
 583 sub print_header {
 584     print <<EOF;
 585 /* $output_file
 586    Generated from $input_file by generate.pl.
 587    Do not modify! */
 588
 589 EOF
 590 }
 591
 592 # Prints the output file trailer.
 593 sub print_trailer {
 594     print <<EOF;
 595
 596 /*
 597    Local Variables:
 598    mode: c
 599    buffer-read-only: t
 600    End:
 601 */
 602 EOF
 603 }
 604
 605 sub generate_evaluate_h {
 606     print "#include \"helpers.h\"\n\n";
 607
 608     for my $opname (@order) {
 609         my ($op) = $ops{$opname};
 610         next if $op->{UNIMPLEMENTED};
 611
 612         my (@args);
 613         for my $arg (@{$op->{ARGS}}) {
 614             if (!defined $arg->{IDX}) {
 615                 push (@args, c_type ($arg->{TYPE}) . $arg->{NAME});
 616             } else {
 617                 push (@args, c_type ($arg->{TYPE}) . "$arg->{NAME}" . "[]");
 618                 push (@args, "size_t $arg->{IDX}");
 619             }
 620         }
 621         for my $aux (@{$op->{AUX}}) {
 622             push (@args, c_type ($aux->{TYPE}) . $aux->{NAME});
 623         }
 624         push (@args, "void") if !@args;
 625
 626         my ($statements) = $op->{BLOCK} || "  return $op->{EXPRESSION};\n";
 627
 628         print "static inline ", c_type ($op->{RETURNS}), "\n";
 629         print "eval_$opname (", join (', ', @args), ")\n";
 630         print "{\n";
 631         print "$statements";
 632         print "}\n\n";
 633     }
 634 }
 635
 636 sub generate_evaluate_inc {
 637     for my $opname (@order) {
 638         my ($op) = $ops{$opname};
 639
 640         if ($op->{UNIMPLEMENTED}) {
 641             print "case $opname:\n";
 642             print "  NOT_REACHED ();\n\n";
 643             next;
 644         }
 645
 646         my (@decls);
 647         my (@args);
 648         for my $arg (@{$op->{ARGS}}) {
 649             my ($name) = $arg->{NAME};
 650             my ($type) = $arg->{TYPE};
 651             my ($c_type) = c_type ($type);
 652             my ($idx) = $arg->{IDX};
 653             push (@args, "arg_$arg->{NAME}");
 654             if (!defined ($idx)) {
 655                 my ($decl) = "${c_type}arg_$name";
 656                 if ($type->{ROLE} eq 'any') {
 657                     unshift (@decls, "$decl = *--$type->{STACK}");
 658                 } elsif ($type->{ROLE} eq 'leaf') {
 659                     push (@decls, "$decl = op++->$type->{ATOM}");
 660                 } else {
 661                     die;
 662                 }
 663             } else {
 664                 my ($stack) = $type->{STACK};
 665                 defined $stack or die;
 666                 unshift (@decls,
 667                          "$c_type*arg_$arg->{NAME} = $stack -= arg_$idx");
 668                 unshift (@decls, "size_t arg_$arg->{IDX} = op++->integer");
 669
 670                 my ($idx) = "arg_$idx";
 671                 if ($arg->{TIMES} != 1) {
 672                     $idx .= " / $arg->{TIMES}";
 673                 }
 674                 push (@args, $idx);
 675             }
 676         }
 677         for my $aux (@{$op->{AUX}}) {
 678             my ($type) = $aux->{TYPE};
 679             my ($name) = $aux->{NAME};
 680             if ($type->{ROLE} eq 'leaf') {
 681                 my ($c_type) = c_type ($type);
 682                 push (@decls, "${c_type}aux_$name = op++->$type->{ATOM}");
 683                 push (@args, "aux_$name");
 684             } elsif ($type->{ROLE} eq 'fixed') {
 685                 push (@args, $type->{FIXED_VALUE});
 686             }
 687         }
 688
 689         my ($sysmis_cond) = make_sysmis_decl ($op, "op++->integer");
 690         push (@decls, $sysmis_cond) if defined $sysmis_cond;
 691
 692         my ($result) = "eval_$op->{OPNAME} (" . join (', ', @args) . ")";
 693
 694         my ($stack) = $op->{RETURNS}{STACK};
 695
 696         print "case $opname:\n";
 697         if (@decls) {
 698             print "  {\n";
 699             print "    $_;\n" foreach @decls;
 700             if (defined $sysmis_cond) {
 701                 my ($miss_ret) = $op->{RETURNS}{MISSING_VALUE};
 702                 print "    *$stack++ = force_sysmis ? $miss_ret : $result;\n";
 703             } else {
 704                 print "    *$stack++ = $result;\n";
 705             }
 706             print "  }\n";
 707         } else {
 708             print "  *$stack++ = $result;\n";
 709         }
 710         print "  break;\n\n";
 711     }
 712 }
 713
 714 sub generate_operations_h {
 715     print "#include <stdlib.h>\n";
 716     print "#include <stdbool.h>\n\n";
 717
 718     print "typedef enum";
 719     print "  {\n";
 720     my (@atoms);
 721     foreach my $type (@types) {
 722         next if $type->{ROLE} eq 'fixed';
 723         push (@atoms, "OP_$type->{NAME}");
 724     }
 725     print_operations ('atom', 1, \@atoms);
 726     print_operations ('function', "OP_atom_last + 1", \@funcs);
 727     print_operations ('operator', "OP_function_last + 1", \@opers);
 728     print_range ("OP_composite", "OP_function_first", "OP_operator_last");
 729     print ",\n\n";
 730     print_range ("OP", "OP_atom_first", "OP_composite_last");
 731     print "\n  }\n";
 732     print "operation_type, atom_type;\n";
 733
 734     print_predicate ('is_operation', 'OP');
 735     print_predicate ("is_$_", "OP_$_")
 736         foreach qw (atom composite function operator);
 737 }
 738
 739 sub print_operations {
 740     my ($type, $first, $names) = @_;
 741     print "    /* \u$type types. */\n";
 742     print "    $names->[0] = $first,\n";
 743     print "    $_,\n" foreach @$names[1...$#{$names}];
 744     print_range ("OP_$type", $names->[0], $names->[$#{$names}]);
 745     print ",\n\n";
 746 }
 747
 748 sub print_range {
 749     my ($prefix, $first, $last) = @_;
 750     print "    ${prefix}_first = $first,\n";
 751     print "    ${prefix}_last = $last,\n";
 752     print "    n_${prefix} = ${prefix}_last - ${prefix}_first + 1";
 753 }
 754
 755 sub print_predicate {
 756     my ($function, $category) = @_;
 757     my ($assertion) = "";
 758
 759     print "\nstatic inline bool\n";
 760     print "$function (operation_type op)\n";
 761     print "{\n";
 762     print "  assert (is_operation (op));\n" if $function ne 'is_operation';
 763     print "  return op >= ${category}_first && op <= ${category}_last;\n";
 764     print "}\n";
 765 }
 766
 767 sub generate_optimize_inc {
 768     for my $opname (@order) {
 769         my ($op) = $ops{$opname};
 770
 771         if (!$op->{OPTIMIZABLE} || $op->{UNIMPLEMENTED}) {
 772             print "case $opname:\n";
 773             print "  NOT_REACHED ();\n\n";
 774             next;
 775         }
 776
 777         my (@decls);
 778         my ($arg_idx) = 0;
 779         for my $arg (@{$op->{ARGS}}) {
 780             my ($decl);
 781             my ($name) = $arg->{NAME};
 782             my ($type) = $arg->{TYPE};
 783             my ($ctype) = c_type ($type);
 784             my ($idx) = $arg->{IDX};
 785             if (!defined ($idx)) {
 786                 my ($func) = "get_$type->{ATOM}_arg";
 787                 push (@decls, "${ctype}arg_$name = $func (node, $arg_idx)");
 788             } else {
 789                 my ($decl) = "size_t arg_$idx = node->n_args";
 790                 $decl .= " - $arg_idx" if $arg_idx;
 791                 push (@decls, $decl);
 792
 793                 push (@decls, "${ctype}*arg_$name = "
 794                       . "get_$type->{ATOM}_args "
 795                       . " (node, $arg_idx, arg_$idx, e)");
 796             }
 797             $arg_idx++;
 798         }
 799
 800         my ($sysmis_cond) = make_sysmis_decl ($op, "node->min_valid");
 801         push (@decls, $sysmis_cond) if defined $sysmis_cond;
 802
 803         my (@args);
 804         for my $arg (@{$op->{ARGS}}) {
 805             push (@args, "arg_$arg->{NAME}");
 806             if (defined $arg->{IDX}) {
 807                 my ($idx) = "arg_$arg->{IDX}";
 808                 $idx .= " / $arg->{TIMES}" if $arg->{TIMES} != 1;
 809                 push (@args, $idx);
 810             }
 811         }
 812         for my $aux (@{$op->{AUX}}) {
 813             my ($type) = $aux->{TYPE};
 814             if ($type->{ROLE} eq 'leaf') {
 815                 my ($func) = "get_$type->{ATOM}_arg";
 816                 push (@args, "$func (node, $arg_idx)");
 817                 $arg_idx++;
 818             } elsif ($type->{ROLE} eq 'fixed') {
 819                 push (@args, $type->{FIXED_VALUE});
 820             } else {
 821                 die;
 822             }
 823         }
 824
 825         my ($result) = "eval_$op->{OPNAME} (" . join (', ', @args) . ")";
 826         if (@decls && defined ($sysmis_cond)) {
 827             my ($miss_ret) = $op->{RETURNS}{MISSING_VALUE};
 828             push (@decls, c_type ($op->{RETURNS}) . "result = "
 829                   . "force_sysmis ? $miss_ret : $result");
 830             $result = "result";
 831         }
 832
 833         print "case $opname:\n";
 834         my ($alloc_func) = "expr_allocate_$op->{RETURNS}{NAME}";
 835         if (@decls) {
 836             print "  {\n";
 837             print "    $_;\n" foreach @decls;
 838             print "    return $alloc_func (e, $result);\n";
 839             print "  }\n";
 840         } else {
 841             print "  return $alloc_func (e, $result);\n";
 842         }
 843         print "\n";
 844     }
 845 }
 846
 847 sub generate_parse_inc {
 848     my (@members) = ("\"\"", "\"\"", 0, 0, 0, "{}", 0, 0);
 849     print "{", join (', ', @members), "},\n";
 850
 851     for my $type (@types) {
 852         next if $type->{ROLE} eq 'fixed';
 853
 854         my ($human_name) = $type->{HUMAN_NAME};
 855         $human_name = $type->{NAME} if !defined $human_name;
 856
 857         my (@members) = ("\"$type->{NAME}\"", "\"$human_name\"",
 858                          0, "OP_$type->{NAME}", 0, "{}", 0, 0);
 859         print "{", join (', ', @members), "},\n";
 860     }
 861
 862     for my $opname (@order) {
 863         my ($op) = $ops{$opname};
 864
 865         my (@members);
 866
 867         push (@members, "\"$op->{NAME}\"");
 868
 869         if ($op->{CATEGORY} eq 'function') {
 870             my (@args, @opt_args);
 871             for my $arg (@{$op->{ARGS}}) {
 872                 push (@args, $arg->{TYPE}{HUMAN_NAME}) if !defined $arg->{IDX};
 873             }
 874
 875             if (my ($array) = array_arg ($op)) {
 876                 if (!defined $op->{MIN_VALID}) {
 877                     my (@array_args);
 878                     for (my $i = 0; $i < $array->{TIMES}; $i++) {
 879                         push (@array_args, $array->{TYPE}{HUMAN_NAME});
 880                     }
 881                     push (@args, @array_args);
 882                     @opt_args = @array_args;
 883                 } else {
 884                     for (my $i = 0; $i < $op->{MIN_VALID}; $i++) {
 885                         push (@args, $array->{TYPE}{HUMAN_NAME});
 886                     }
 887                     push (@opt_args, $array->{TYPE}{HUMAN_NAME});
 888                 }
 889             }
 890             my ($human) = "$op->{NAME}(" . join (', ', @args);
 891             $human .= '[, ' . join (', ', @opt_args) . ']...' if @opt_args;
 892             $human .= ')';
 893             push (@members, "\"$human\"");
 894         } else {
 895             push (@members, "NULL");
 896         }
 897
 898         my (@flags);
 899         push (@flags, "OPF_ABSORB_MISS") if defined $op->{ABSORB_MISS};
 900         push (@flags, "OPF_ARRAY_OPERAND") if array_arg ($op);
 901         push (@flags, "OPF_MIN_VALID") if defined $op->{MIN_VALID};
 902         push (@flags, "OPF_NONOPTIMIZABLE") if !$op->{OPTIMIZABLE};
 903         push (@flags, "OPF_EXTENSION") if $op->{EXTENSION};
 904         push (@flags, "OPF_UNIMPLEMENTED") if $op->{UNIMPLEMENTED};
 905         push (@flags, "OPF_PERM_ONLY") if $op->{PERM_ONLY};
 906         push (@flags, "OPF_NO_ABBREV") if $op->{NO_ABBREV};
 907         push (@members, @flags ? join (' | ', @flags) : 0);
 908
 909         push (@members, "OP_$op->{RETURNS}{NAME}");
 910
 911         push (@members, scalar (@{$op->{ARGS}}));
 912
 913         my (@arg_types) = map ("OP_$_->{TYPE}{NAME}", @{$op->{ARGS}});
 914         push (@members, "{" . join (', ', @arg_types) . "}");
 915
 916         push (@members, $op->{MIN_VALID} || 0);
 917
 918         push (@members, array_arg ($op) ? ${array_arg ($op)}{TIMES} : 0);
 919
 920         print "{", join (', ', @members), "},\n";
 921     }
 922 }
 923 \f
 924 # Utilities.
 925
 926 # any($target, @list)
 927 #
 928 # Returns true if $target appears in @list,
 929 # false otherwise.
 930 sub any {
 931     $_ eq $_[0] and return 1 foreach @_[1...$#_];
 932     return 0;
 933 }
 934
 935 # make_sysmis_decl($op, $min_valid_src)
 936 #
 937 # Returns a declaration for a boolean variable called `force_sysmis',
 938 # which will be true when operation $op should be system-missing.
 939 # Returns undef if there are no such circumstances.
 940 #
 941 # If $op has a minimum number of valid arguments, $min_valid_src
 942 # should be an an expression that evaluates to the minimum number of
 943 # valid arguments for $op.
 944 sub make_sysmis_decl {
 945     my ($op, $min_valid_src) = @_;
 946     my (@sysmis_cond);
 947     if (!$op->{ABSORB_MISS}) {
 948         for my $arg (@{$op->{ARGS}}) {
 949             my ($arg_name) = "arg_$arg->{NAME}";
 950             if (!defined $arg->{IDX}) {
 951                 if (any ($arg->{TYPE}, @type{qw (NUMBER BOOLEAN)})) {
 952                     push (@sysmis_cond, "!is_valid ($arg_name)");
 953                 }
 954             } elsif ($arg->{TYPE} eq $type{NUMBER}) {
 955                 my ($a) = "$arg_name";
 956                 my ($n) = "arg_$arg->{IDX}";
 957                 push (@sysmis_cond, "count_valid ($a, $n) < $n");
 958             }
 959         }
 960     } elsif (defined $op->{MIN_VALID}) {
 961         my ($args) = $op->{ARGS};
 962         my ($arg) = ${$args}[$#{$args}];
 963         my ($a) = "arg_$arg->{NAME}";
 964         my ($n) = "arg_$arg->{IDX}";
 965         push (@sysmis_cond, "count_valid ($a, $n) < $min_valid_src");
 966     }
 967     for my $arg (@{$op->{ARGS}}) {
 968         push (@sysmis_cond, "!($arg->{CONDITION})")
 969           if defined $arg->{CONDITION};
 970     }
 971     return "bool force_sysmis = " . join (' || ', @sysmis_cond)
 972       if @sysmis_cond;
 973     return;
 974 }
 975
 976 # array_arg($op)
 977 #
 978 # If $op has an array argument, return it.
 979 # Otherwise, returns undef.
 980 sub array_arg {
 981     my ($op) = @_;
 982     my ($args) = $op->{ARGS};
 983     return if !@$args;
 984     my ($last_arg) = $args->[@$args - 1];
 985     return $last_arg if defined $last_arg->{IDX};
 986     return;
 987 }