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