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