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

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