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