src/expressions/PSPP_expressions.pm

   1 use strict;
   2 use warnings 'all';
   3
   4 use Getopt::Long;
   5
   6 # Parse command line.
   7 our ($default_output_file) = $0;
   8 $default_output_file =~ s/\.pl//;
   9 our ($input_file);
  10 our ($output_file);
  11 parse_cmd_line ();
  12
  13 # Initialize type system.
  14 our (%type, @types);
  15 init_all_types ();
  16
  17 # Parse input file.
  18 our (%ops);
  19 our (@funcs, @opers);
  20 parse_input ();
  21
  22 # Command line.
  23
  24 # Parses the command line.
  25 #
  26 # Initializes $input_file, $output_file.
  27 sub parse_cmd_line {
  28     GetOptions ("i|input=s" => \$input_file,
  29                 "o|output=s" => \$output_file,
  30                 "h|help" => sub { usage (); })
  31       or exit 1;
  32
  33     $input_file = "operations.def" if !defined $input_file;
  34     $output_file = $default_output_file if !defined $output_file;
  35
  36     open (INPUT, "<$input_file") or die "$input_file: open: $!\n";
  37     open (OUTPUT, ">$output_file") or die "$output_file: create: $!\n";
  38
  39     select (OUTPUT);
  40 }
  41
  42 sub usage {
  43     print <<EOF;
  44 $0, for generating $default_output_file from definitions
  45 usage: generate.pl [-i INPUT] [-o OUTPUT] [-h]
  46   -i INPUT    input file containing definitions (default: operations.def)
  47   -o OUTPUT   output file (default: $default_output_file)
  48   -h          display this help message
  49 EOF
  50     exit (0);
  51 }
  52
  53 our ($token);
  54 our ($toktype);
  55 \f
  56 # Types.
  57
  58 # Defines all our types.
  59 #
  60 # Initializes %type, @types.
  61 sub init_all_types {
  62     # Common user-visible types used throughout evaluation trees.
  63     init_type ('number', 'any', C_TYPE => 'double',
  64                ATOM => 'number', MANGLE => 'n', HUMAN_NAME => 'num',
  65                STACK => 'ns', MISSING_VALUE => 'SYSMIS');
  66     init_type ('string', 'any', C_TYPE => 'struct fixed_string',
  67                ATOM => 'string', MANGLE => 's', HUMAN_NAME => 'string',
  68                STACK => 'ss', MISSING_VALUE => 'empty_string');
  69     init_type ('boolean', 'any', C_TYPE => 'double',
  70                ATOM => 'number', MANGLE => 'n', HUMAN_NAME => 'boolean',
  71                STACK => 'ns', MISSING_VALUE => 'SYSMIS');
  72
  73     # Format types.
  74     init_type ('format', 'atom');
  75     init_type ('ni_format', 'leaf', C_TYPE => 'const struct fmt_spec *',
  76                ATOM => 'format', MANGLE => 'f',
  77                HUMAN_NAME => 'num_input_format');
  78     init_type ('no_format', 'leaf', C_TYPE => 'const struct fmt_spec *',
  79                ATOM => 'format', MANGLE => 'f',
  80                HUMAN_NAME => 'num_output_format');
  81
  82     # Integer types.
  83     init_type ('integer', 'leaf', C_TYPE => 'int',
  84                ATOM => 'integer', MANGLE => 'n', HUMAN_NAME => 'integer');
  85     init_type ('pos_int', 'leaf', C_TYPE => 'int',
  86                ATOM => 'integer', MANGLE => 'n',
  87                HUMAN_NAME => 'positive_integer_constant');
  88
  89     # Variable names.
  90     init_type ('variable', 'atom');
  91     init_type ('num_var', 'leaf', C_TYPE => 'const struct variable *',
  92                ATOM => 'variable', MANGLE => 'Vn',
  93                HUMAN_NAME => 'num_variable');
  94     init_type ('str_var', 'leaf', C_TYPE => 'const struct variable *',
  95                ATOM => 'variable', MANGLE => 'Vs',
  96                HUMAN_NAME => 'string_variable');
  97
  98     # Vectors.
  99     init_type ('vector', 'leaf', C_TYPE => 'const struct vector *',
 100                ATOM => 'vector', MANGLE => 'v', HUMAN_NAME => 'vector');
 101
 102     # Fixed types.
 103     init_type ('expression', 'fixed', C_TYPE => 'struct expression *',
 104                FIXED_VALUE => 'e');
 105     init_type ('case', 'fixed', C_TYPE => 'const struct ccase *',
 106                FIXED_VALUE => 'c');
 107     init_type ('case_idx', 'fixed', C_TYPE => 'size_t',
 108                FIXED_VALUE => 'case_idx');
 109
 110     # One of these is emitted at the end of each expression as a sentinel
 111     # that tells expr_evaluate() to return the value on the stack.
 112     init_type ('return_number', 'atom');
 113     init_type ('return_string', 'atom');
 114
 115     # Used only for debugging purposes.
 116     init_type ('operation', 'atom');
 117 }
 118
 119 # init_type has 2 required arguments:
 120 #
 121 #   NAME: Type name.
 122 #
 123 #           `$name' is the type's name in operations.def.
 124 #
 125 #           `OP_$name' is the terminal's type in operations.h.
 126 #
 127 #           `expr_allocate_$name()' allocates a node of the given type.
 128 #
 129 #   ROLE: How the type may be used:
 130 #
 131 #           "any": Usable as operands and function arguments, and
 132 #           function and operator results.
 133 #
 134 #           "leaf": Usable as operands and function arguments, but
 135 #           not function arguments or results.  (Thus, they appear
 136 #           only in leaf nodes in the parse type.)
 137 #
 138 #           "fixed": Not allowed either as an operand or argument
 139 #           type or a result type.  Used only as auxiliary data.
 140 #
 141 #           "atom": Not allowed anywhere; just adds the name to
 142 #           the list of atoms.
 143 #
 144 # All types except those with "atom" as their role also require:
 145 #
 146 #   C_TYPE: The C type that represents this abstract type.
 147 #
 148 # Types with "any" or "leaf" role require:
 149 #
 150 #   ATOM:
 151 #
 152 #           `$atom' is the `struct operation_data' member name.
 153 #
 154 #           get_$atom_name() obtains the corresponding data from a
 155 #           node.
 156 #
 157 #   MANGLE: Short string for name mangling.  Use identical strings
 158 #   if two types should not be overloaded.
 159 #
 160 #   HUMAN_NAME: Name for a type when we describe it to the user.
 161 #
 162 # Types with role "any" require:
 163 #
 164 #   STACK: Name of the local variable in expr_evaluate(), used for
 165 #   maintaining the stack for this type.
 166 #
 167 #   MISSING_VALUE: Expression used for the missing value of this
 168 #   type.
 169 #
 170 # Types with role "fixed" require:
 171 #
 172 #   FIXED_VALUE: Expression used for the value of this type.
 173 sub init_type {
 174     my ($name, $role, %rest) = @_;
 175     my ($type) = $type{"\U$name"} = {NAME => $name, ROLE => $role, %rest};
 176
 177     my (@need_keys) = qw (NAME ROLE);
 178     if ($role eq 'any') {
 179         push (@need_keys, qw (C_TYPE ATOM MANGLE HUMAN_NAME STACK MISSING_VALUE));
 180     } elsif ($role eq 'leaf') {
 181         push (@need_keys, qw (C_TYPE ATOM MANGLE HUMAN_NAME));
 182     } elsif ($role eq 'fixed') {
 183         push (@need_keys, qw (C_TYPE FIXED_VALUE));
 184     } elsif ($role eq 'atom') {
 185     } else {
 186         die "no role `$role'";
 187     }
 188
 189     my (%have_keys);
 190     $have_keys{$_} = 1 foreach keys %$type;
 191     for my $key (@need_keys) {
 192         defined $type->{$key} or die "$name lacks $key";
 193         delete $have_keys{$key};
 194     }
 195     scalar (keys (%have_keys)) == 0
 196       or die "$name has superfluous key(s) " . join (', ', keys (%have_keys));
 197
 198     push (@types, $type);
 199 }
 200
 201 # c_type(type).
 202 #
 203 # Returns the C type of the given type as a string designed to be
 204 # prepended to a variable name to produce a declaration.  (That won't
 205 # work in general but it works well enough for our types.)
 206 sub c_type {
 207     my ($type) = @_;
 208     my ($c_type) = $type->{C_TYPE};
 209     defined $c_type or die;
 210
 211     # Append a space unless (typically) $c_type ends in `*'.
 212     $c_type .= ' ' if $c_type =~ /\w$/;
 213
 214     return $c_type;
 215 }
 216 \f
 217 # Input parsing.
 218
 219 # Parses the entire input.
 220 #
 221 # Initializes %ops, @funcs, @opers.
 222 sub parse_input {
 223     get_line ();
 224     get_token ();
 225     while ($toktype ne 'eof') {
 226         my (%op);
 227
 228         $op{OPTIMIZABLE} = 1;
 229         $op{UNIMPLEMENTED} = 0;
 230         $op{EXTENSION} = 0;
 231         for (;;) {
 232             if (match ('extension')) {
 233                 $op{EXTENSION} = 1;
 234             } elsif (match ('no_opt')) {
 235                 $op{OPTIMIZABLE} = 0;
 236             } elsif (match ('absorb_miss')) {
 237                 $op{ABSORB_MISS} = 1;
 238             } else {
 239                 last;
 240             }
 241         }
 242
 243         $op{RETURNS} = parse_type () || $type{NUMBER};
 244         die "$op{RETURNS} is not a valid return type"
 245           if !any ($op{RETURNS}, @type{qw (NUMBER STRING BOOLEAN)});
 246
 247         $op{CATEGORY} = $token;
 248         if (!any ($op{CATEGORY}, qw (operator function))) {
 249             die "`operator' or `function' expected at `$token'";
 250         }
 251         get_token ();
 252
 253         my ($name) = force ("id");
 254
 255         die "function name may not contain underscore"
 256           if $op{CATEGORY} eq 'function' && $name =~ /_/;
 257         die "operator name may not contain period"
 258           if $op{CATEGORY} eq 'operator' && $name =~ /\./;
 259
 260         if (my ($prefix, $suffix) = $name =~ /^(.*)\.(\d+)$/) {
 261             $name = $prefix;
 262             $op{MIN_VALID} = $suffix;
 263             $op{ABSORB_MISS} = 1;
 264         }
 265         $op{NAME} = $name;
 266
 267         force_match ('(');
 268         @{$op{ARGS}} = ();
 269         while (!match (')')) {
 270             my ($arg) = parse_arg ();
 271             push (@{$op{ARGS}}, $arg);
 272             if (defined ($arg->{IDX})) {
 273                 last if match (')');
 274                 die "array must be last argument";
 275             }
 276             if (!match (',')) {
 277                 force_match (')');
 278                 last;
 279             }
 280         }
 281
 282         for my $arg (@{$op{ARGS}}) {
 283             next if !defined $arg->{CONDITION};
 284             my ($any_arg) = join ('|', map ($_->{NAME}, @{$op{ARGS}}));
 285             $arg->{CONDITION} =~ s/\b($any_arg)\b/arg_$1/g;
 286         }
 287
 288         my ($opname) = "OP_$op{NAME}";
 289         $opname =~ tr/./_/;
 290         if ($op{CATEGORY} eq 'function') {
 291             my ($mangle) = join ('', map ($_->{TYPE}{MANGLE}, @{$op{ARGS}}));
 292             $op{MANGLE} = $mangle;
 293             $opname .= "_$mangle";
 294         }
 295         $op{OPNAME} = $opname;
 296
 297         if ($op{MIN_VALID}) {
 298             my ($array_arg) = array_arg (\%op);
 299             die "can't have minimum valid count without array arg"
 300               if !defined $array_arg;
 301             die "minimum valid count allowed only with double array"
 302               if $array_arg->{TYPE} ne $type{NUMBER};
 303             die "can't have minimum valid count if array has multiplication factor"
 304               if $array_arg->{TIMES} != 1;
 305         }
 306
 307         while ($toktype eq 'id') {
 308             my ($type) = parse_type () or die "parse error";
 309             die "`$type->{NAME}' is not allowed as auxiliary data"
 310               unless $type->{ROLE} eq 'leaf' || $type->{ROLE} eq 'fixed';
 311             my ($name) = force ("id");
 312             push (@{$op{AUX}}, {TYPE => $type, NAME => $name});
 313             force_match (';');
 314         }
 315
 316         if ($op{OPTIMIZABLE}) {
 317             die "random variate functions must be marked `no_opt'"
 318               if $op{NAME} =~ /^RV\./;
 319             for my $aux (@{$op{AUX}}) {
 320                 if (any ($aux->{TYPE}, @type{qw (CASE CASE_IDX)})) {
 321                     die "operators with $aux->{TYPE} aux data must be "
 322                       . "marked `no_opt'";
 323                 }
 324             }
 325         }
 326
 327         if ($op{RETURNS} eq $type{STRING} && !defined ($op{ABSORB_MISS})) {
 328             my (@args);
 329             for my $arg (@{$op{ARGS}}) {
 330                 if (any ($arg->{TYPE}, @type{qw (NUMBER BOOLEAN)})) {
 331                     die "$op{NAME} returns string and has double or bool "
 332                       . "argument, but is not marked ABSORB_MISS";
 333                 }
 334                 if (defined $arg->{CONDITION}) {
 335                     die "$op{NAME} returns string but has argument with condition";
 336                 }
 337             }
 338         }
 339
 340         if ($toktype eq 'block') {
 341             $op{BLOCK} = force ('block');
 342         } elsif ($toktype eq 'expression') {
 343             if ($token eq 'unimplemented') {
 344                 $op{UNIMPLEMENTED} = 1;
 345             } else {
 346                 $op{EXPRESSION} = $token;
 347             }
 348             get_token ();
 349         } else {
 350             die "block or expression expected";
 351         }
 352
 353         die "duplicate operation name $opname" if defined $ops{$opname};
 354         $ops{$opname} = \%op;
 355         if ($op{CATEGORY} eq 'function') {
 356             push (@funcs, $opname);
 357         } else {
 358             push (@opers, $opname);
 359         }
 360     }
 361     close(INPUT);
 362
 363     @funcs = sort {$ops{$a}->{NAME} cmp $ops{$b}->{NAME}
 364                      ||
 365                        $ops{$a}->{OPNAME} cmp $ops{$b}->{OPNAME}}
 366       @funcs;
 367     @opers = sort {$ops{$a}->{NAME} cmp $ops{$b}->{NAME}} @opers;
 368     our (@order) = (@funcs, @opers);
 369 }
 370
 371 # Reads the next token into $token, $toktype.
 372 sub get_token {
 373     our ($line);
 374     lookahead ();
 375     return if defined ($toktype) && $toktype eq 'eof';
 376     $toktype = 'id', return
 377         if ($token) = $line =~ /\G([a-zA-Z_][a-zA-Z_.0-9]*)/gc;
 378     $toktype = 'int', return if ($token) = $line =~ /\G[0-9]+/gc;
 379     $toktype = 'punct', $token = $1, return if $line =~ /\G([][(),*;.])/gc;
 380     if ($line =~ /\G=/gc) {
 381         $toktype = "expression";
 382         $line =~ /\G\s+/gc;
 383         $token = accumulate_balanced (';');
 384     } elsif ($line =~ /\G\{/gc) {
 385         $toktype = "block";
 386         $token = accumulate_balanced ('}');
 387         $token =~ s/^\n+//;
 388     } else {
 389         die "bad character `" . substr ($line, pos $line, 1) . "' in input";
 390     }
 391 }
 392
 393 # Skip whitespace, then return the remainder of the line.
 394 sub lookahead {
 395     our ($line);
 396     die "unexpected end of file" if !defined ($line);
 397     for (;;) {
 398         $line =~ /\G\s+/gc;
 399         last if pos ($line) < length ($line);
 400         get_line ();
 401         $token = $toktype = 'eof', return if !defined ($line);
 402     }
 403     return substr ($line, pos ($line));
 404 }
 405
 406 # accumulate_balanced($chars)
 407 #
 408 # Accumulates input until a character in $chars is encountered, except
 409 # that balanced pairs of (), [], or {} cause $chars to be ignored.
 410 #
 411 # Returns the input read.
 412 sub accumulate_balanced {
 413     my ($end) = @_;
 414     my ($s) = "";
 415     my ($nest) = 0;
 416     our ($line);
 417     for (;;) {
 418         my ($start) = pos ($line);
 419         if ($line =~ /\G([^][(){};,]*)([][(){};,])/gc) {
 420             $s .= substr ($line, $start, pos ($line) - $start - 1)
 421                 if pos ($line) > $start;
 422             my ($last) = substr ($line, pos ($line) - 1, 1);
 423             if ($last =~ /[[({]/) {
 424                 $nest++;
 425                 $s .= $last;
 426             } elsif ($last =~ /[])}]/) {
 427                 if ($nest > 0) {
 428                     $nest--;
 429                     $s .= $last;
 430                 } elsif (index ($end, $last) >= 0) {
 431                     return $s;
 432                 } else {
 433                     die "unbalanced parentheses";
 434                 }
 435             } elsif (index ($end, $last) >= 0) {
 436                 return $s if !$nest;
 437                 $s .= $last;
 438             } else {
 439                 $s .= $last;
 440             }
 441         } else {
 442             $s .= substr ($line, pos ($line)) . "\n";
 443             get_line ();
 444         }
 445     }
 446 }
 447
 448 # Reads the next line from INPUT into $line.
 449 sub get_line {
 450     our ($line);
 451     $line = <INPUT>;
 452     if (defined ($line)) {
 453         chomp $line;
 454         $line =~ s%//.*%%;
 455         pos ($line) = 0;
 456     }
 457 }
 458
 459 # If the current token is an identifier that names a type,
 460 # returns the type and skips to the next token.
 461 # Otherwise, returns undef.
 462 sub parse_type {
 463     if ($toktype eq 'id') {
 464         foreach my $type (values (%type)) {
 465             get_token (), return $type
 466               if defined ($type->{NAME}) && $type->{NAME} eq $token;
 467         }
 468     }
 469     return;
 470 }
 471
 472 # force($type).
 473 #
 474 # Makes sure that $toktype equals $type, reads the next token, and
 475 # returns the previous $token.
 476 sub force {
 477     my ($type) = @_;
 478     die "parse error at `$token' expecting $type"
 479         if $type ne $toktype;
 480     my ($tok) = $token;
 481     get_token ();
 482     return $tok;
 483 }
 484
 485 # force($tok).
 486 #
 487 # If $token equals $tok, reads the next token and returns true.
 488 # Otherwise, returns false.
 489 sub match {
 490     my ($tok) = @_;
 491     if ($token eq $tok) {
 492         get_token ();
 493         return 1;
 494     } else {
 495         return 0;
 496     }
 497 }
 498
 499 # force_match($tok).
 500 #
 501 # If $token equals $tok, reads the next token.
 502 # Otherwise, flags an error in the input.
 503 sub force_match {
 504     my ($tok) = @_;
 505     die "parse error at `$token' expecting `$tok'" if !match ($tok);
 506 }
 507
 508 # Parses and returns a function argument.
 509 sub parse_arg {
 510     my (%arg);
 511     $arg{TYPE} = parse_type () || $type{NUMBER};
 512     die "argument name expected at `$token'" if $toktype ne 'id';
 513     $arg{NAME} = $token;
 514
 515     if (lookahead () =~ /^[[,)]/) {
 516         get_token ();
 517         if (match ('[')) {
 518             die "only double and string arrays supported"
 519               if !any ($arg{TYPE}, @type{qw (NUMBER STRING)});
 520             $arg{IDX} = force ('id');
 521             if (match ('*')) {
 522                 $arg{TIMES} = force ('int');
 523                 die "multiplication factor must be positive"
 524                   if $arg{TIMES} < 1;
 525             } else {
 526                 $arg{TIMES} = 1;
 527             }
 528             force_match (']');
 529         }
 530     } else {
 531         $arg{CONDITION} = $arg{NAME} . ' ' . accumulate_balanced (',)');
 532         our ($line);
 533         pos ($line) -= 1;
 534         get_token ();
 535     }
 536     return \%arg;
 537 }
 538 \f
 539 # Output.
 540
 541 # Prints the output file header.
 542 sub print_header {
 543     print <<EOF;
 544 /* $output_file
 545    Generated from $input_file by generate.pl.
 546    Do not modify! */
 547
 548 EOF
 549 }
 550
 551 # Prints the output file trailer.
 552 sub print_trailer {
 553     print <<EOF;
 554
 555 /*
 556    Local Variables:
 557    mode: c
 558    buffer-read-only: t
 559    End:
 560 */
 561 EOF
 562 }
 563 \f
 564 # Utilities.
 565
 566 # any($target, @list)
 567 #
 568 # Returns true if $target appears in @list,
 569 # false otherwise.
 570 sub any {
 571     $_ eq $_[0] and return 1 foreach @_[1...$#_];
 572     return 0;
 573 }
 574
 575 # make_sysmis_decl($op, $min_valid_src)
 576 #
 577 # Returns a declaration for a boolean variable called `force_sysmis',
 578 # which will be true when operation $op should be system-missing.
 579 # Returns undef if there are no such circumstances.
 580 #
 581 # If $op has a minimum number of valid arguments, $min_valid_src
 582 # should be an an expression that evaluates to the minimum number of
 583 # valid arguments for $op.
 584 sub make_sysmis_decl {
 585     my ($op, $min_valid_src) = @_;
 586     my (@sysmis_cond);
 587     if (!$op->{ABSORB_MISS}) {
 588         for my $arg (@{$op->{ARGS}}) {
 589             my ($arg_name) = "arg_$arg->{NAME}";
 590             if (!defined $arg->{IDX}) {
 591                 if (any ($arg->{TYPE}, @type{qw (NUMBER BOOLEAN)})) {
 592                     push (@sysmis_cond, "!is_valid ($arg_name)");
 593                 }
 594             } elsif ($arg->{TYPE} eq $type{NUMBER}) {
 595                 my ($a) = "$arg_name";
 596                 my ($n) = "arg_$arg->{IDX}";
 597                 push (@sysmis_cond, "count_valid ($a, $n) < $n");
 598             }
 599         }
 600     } elsif (defined $op->{MIN_VALID}) {
 601         my ($args) = $op->{ARGS};
 602         my ($arg) = ${$args}[$#{$args}];
 603         my ($a) = "arg_$arg->{NAME}";
 604         my ($n) = "arg_$arg->{IDX}";
 605         push (@sysmis_cond, "count_valid ($a, $n) < $min_valid_src");
 606     }
 607     for my $arg (@{$op->{ARGS}}) {
 608         push (@sysmis_cond, "!($arg->{CONDITION})")
 609           if defined $arg->{CONDITION};
 610     }
 611     return "bool force_sysmis = " . join (' || ', @sysmis_cond)
 612       if @sysmis_cond;
 613     return;
 614 }
 615
 616 # array_arg($op)
 617 #
 618 # If $op has an array argument, return it.
 619 # Otherwise, returns undef.
 620 sub array_arg {
 621     my ($op) = @_;
 622     my ($args) = $op->{ARGS};
 623     return if !@$args;
 624     my ($last_arg) = $args->[@$args - 1];
 625     return $last_arg if defined $last_arg->{IDX};
 626     return;
 627 }