Revise TODO.
[pspp] / 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 }