11 # Initialize type system.
17 our (@funcs, @opers, @order);
22 if ($output_file =~ /evaluate\.h$/) {
23 generate_evaluate_h ();
24 } elsif ($output_file =~ /evaluate\.inc$/) {
25 generate_evaluate_inc ();
26 } elsif ($output_file =~ /operations\.h$/) {
27 generate_operations_h ();
28 } elsif ($output_file =~ /optimize\.inc$/) {
29 generate_optimize_inc ();
30 } elsif ($output_file =~ /parse\.inc$/) {
31 generate_parse_inc ();
33 die "$output_file: unknown output type\n";
39 # Parses the command line.
41 # Initializes $input_file, $output_file.
43 GetOptions ("i|input=s" => \$input_file,
44 "o|output=s" => \$output_file,
45 "h|help" => sub { usage (); })
48 $input_file = "operations.def" if !defined $input_file;
49 die "$0: output file must be specified\n" if !defined $output_file;
51 open (INPUT, "<$input_file") or die "$input_file: open: $!\n";
52 open (OUTPUT, ">$output_file") or die "$output_file: create: $!\n";
59 $0, for generating expression parsers and evaluators from definitions
60 usage: generate.pl -o OUTPUT [-i INPUT] [-h]
61 -i INPUT input file containing definitions (default: operations.def)
63 -h display this help message
73 # Defines all our types.
75 # Initializes %type, @types.
77 # Common user-visible types used throughout evaluation trees.
78 init_type ('number', 'any', C_TYPE => 'double',
79 ATOM => 'number', MANGLE => 'n', HUMAN_NAME => 'number',
80 STACK => 'ns', MISSING_VALUE => 'SYSMIS');
81 init_type ('string', 'any', C_TYPE => 'struct substring',
82 ATOM => 'string', MANGLE => 's', HUMAN_NAME => 'string',
83 STACK => 'ss', MISSING_VALUE => 'empty_string');
84 init_type ('boolean', 'any', C_TYPE => 'double',
85 ATOM => 'number', MANGLE => 'n', HUMAN_NAME => 'boolean',
86 STACK => 'ns', MISSING_VALUE => 'SYSMIS');
89 init_type ('format', 'atom');
90 init_type ('ni_format', 'leaf', C_TYPE => 'const struct fmt_spec *',
91 ATOM => 'format', MANGLE => 'f',
92 HUMAN_NAME => 'num_input_format');
93 init_type ('no_format', 'leaf', C_TYPE => 'const struct fmt_spec *',
94 ATOM => 'format', MANGLE => 'f',
95 HUMAN_NAME => 'num_output_format');
98 init_type ('integer', 'leaf', C_TYPE => 'int',
99 ATOM => 'integer', MANGLE => 'n', HUMAN_NAME => 'integer');
100 init_type ('pos_int', 'leaf', C_TYPE => 'int',
101 ATOM => 'integer', MANGLE => 'n',
102 HUMAN_NAME => 'positive_integer_constant');
105 init_type ('variable', 'atom');
106 init_type ('num_var', 'leaf', C_TYPE => 'const struct variable *',
107 ATOM => 'variable', MANGLE => 'Vn',
108 HUMAN_NAME => 'num_variable');
109 init_type ('str_var', 'leaf', C_TYPE => 'const struct variable *',
110 ATOM => 'variable', MANGLE => 'Vs',
111 HUMAN_NAME => 'string_variable');
112 init_type ('var', 'leaf', C_TYPE => 'const struct variable *',
113 ATOM => 'variable', MANGLE => 'V',
114 HUMAN_NAME => 'variable');
117 init_type ('vector', 'leaf', C_TYPE => 'const struct vector *',
118 ATOM => 'vector', MANGLE => 'v', HUMAN_NAME => 'vector');
121 init_type ('expression', 'fixed', C_TYPE => 'struct expression *',
123 init_type ('case', 'fixed', C_TYPE => 'const struct ccase *',
125 init_type ('case_idx', 'fixed', C_TYPE => 'size_t',
126 FIXED_VALUE => 'case_idx');
127 init_type ('dataset', 'fixed', C_TYPE => 'struct dataset *',
128 FIXED_VALUE => 'ds');
130 # One of these is emitted at the end of each expression as a sentinel
131 # that tells expr_evaluate() to return the value on the stack.
132 init_type ('return_number', 'atom');
133 init_type ('return_string', 'atom');
135 # Used only for debugging purposes.
136 init_type ('operation', 'atom');
139 # init_type has 2 required arguments:
143 # `$name' is the type's name in operations.def.
145 # `OP_$name' is the terminal's type in operations.h.
147 # `expr_allocate_$name()' allocates a node of the given type.
149 # ROLE: How the type may be used:
151 # "any": Usable as operands and function arguments, and
152 # function and operator results.
154 # "leaf": Usable as operands and function arguments, but
155 # not function arguments or results. (Thus, they appear
156 # only in leaf nodes in the parse type.)
158 # "fixed": Not allowed either as an operand or argument
159 # type or a result type. Used only as auxiliary data.
161 # "atom": Not allowed anywhere; just adds the name to
164 # All types except those with "atom" as their role also require:
166 # C_TYPE: The C type that represents this abstract type.
168 # Types with "any" or "leaf" role require:
172 # `$atom' is the `struct operation_data' member name.
174 # get_$atom_name() obtains the corresponding data from a
177 # MANGLE: Short string for name mangling. Use identical strings
178 # if two types should not be overloaded.
180 # HUMAN_NAME: Name for a type when we describe it to the user.
182 # Types with role "any" require:
184 # STACK: Name of the local variable in expr_evaluate(), used for
185 # maintaining the stack for this type.
187 # MISSING_VALUE: Expression used for the missing value of this
190 # Types with role "fixed" require:
192 # FIXED_VALUE: Expression used for the value of this type.
194 my ($name, $role, %rest) = @_;
195 my ($type) = $type{"\U$name"} = {NAME => $name, ROLE => $role, %rest};
197 my (@need_keys) = qw (NAME ROLE);
198 if ($role eq 'any') {
199 push (@need_keys, qw (C_TYPE ATOM MANGLE HUMAN_NAME STACK MISSING_VALUE));
200 } elsif ($role eq 'leaf') {
201 push (@need_keys, qw (C_TYPE ATOM MANGLE HUMAN_NAME));
202 } elsif ($role eq 'fixed') {
203 push (@need_keys, qw (C_TYPE FIXED_VALUE));
204 } elsif ($role eq 'atom') {
206 die "no role `$role'";
210 $have_keys{$_} = 1 foreach keys %$type;
211 for my $key (@need_keys) {
212 defined $type->{$key} or die "$name lacks $key";
213 delete $have_keys{$key};
215 scalar (keys (%have_keys)) == 0
216 or die "$name has superfluous key(s) " . join (', ', keys (%have_keys));
218 push (@types, $type);
223 # Returns the C type of the given type as a string designed to be
224 # prepended to a variable name to produce a declaration. (That won't
225 # work in general but it works well enough for our types.)
228 my ($c_type) = $type->{C_TYPE};
229 defined $c_type or die;
231 # Append a space unless (typically) $c_type ends in `*'.
232 $c_type .= ' ' if $c_type =~ /\w$/;
239 # Parses the entire input.
241 # Initializes %ops, @funcs, @opers.
245 while ($toktype ne 'eof') {
248 $op{OPTIMIZABLE} = 1;
249 $op{UNIMPLEMENTED} = 0;
253 if (match ('extension')) {
255 } elsif (match ('no_opt')) {
256 $op{OPTIMIZABLE} = 0;
257 } elsif (match ('absorb_miss')) {
258 $op{ABSORB_MISS} = 1;
259 } elsif (match ('perm_only')) {
261 } elsif (match ('no_abbrev')) {
268 $op{RETURNS} = parse_type () || $type{NUMBER};
269 die "$op{RETURNS} is not a valid return type"
270 if !any ($op{RETURNS}, @type{qw (NUMBER STRING BOOLEAN)});
272 $op{CATEGORY} = $token;
273 if (!any ($op{CATEGORY}, qw (operator function))) {
274 die "`operator' or `function' expected at `$token'";
278 my ($name) = force ("id");
280 die "function name may not contain underscore"
281 if $op{CATEGORY} eq 'function' && $name =~ /_/;
282 die "operator name may not contain period"
283 if $op{CATEGORY} eq 'operator' && $name =~ /\./;
285 if (my ($prefix, $suffix) = $name =~ /^(.*)\.(\d+)$/) {
287 $op{MIN_VALID} = $suffix;
288 $op{ABSORB_MISS} = 1;
294 while (!match (')')) {
295 my ($arg) = parse_arg ();
296 push (@{$op{ARGS}}, $arg);
297 if (defined ($arg->{IDX})) {
299 die "array must be last argument";
307 for my $arg (@{$op{ARGS}}) {
308 next if !defined $arg->{CONDITION};
309 my ($any_arg) = join ('|', map ($_->{NAME}, @{$op{ARGS}}));
310 $arg->{CONDITION} =~ s/\b($any_arg)\b/arg_$1/g;
313 my ($opname) = "OP_$op{NAME}";
315 if ($op{CATEGORY} eq 'function') {
316 my ($mangle) = join ('', map ($_->{TYPE}{MANGLE}, @{$op{ARGS}}));
317 $op{MANGLE} = $mangle;
318 $opname .= "_$mangle";
320 $op{OPNAME} = $opname;
322 if ($op{MIN_VALID}) {
323 my ($array_arg) = array_arg (\%op);
324 die "can't have minimum valid count without array arg"
325 if !defined $array_arg;
326 die "minimum valid count allowed only with double array"
327 if $array_arg->{TYPE} ne $type{NUMBER};
328 die "can't have minimum valid count if array has multiplication factor"
329 if $array_arg->{TIMES} != 1;
332 while ($toktype eq 'id') {
333 my ($type) = parse_type () or die "parse error";
334 die "`$type->{NAME}' is not allowed as auxiliary data"
335 unless $type->{ROLE} eq 'leaf' || $type->{ROLE} eq 'fixed';
336 my ($name) = force ("id");
337 push (@{$op{AUX}}, {TYPE => $type, NAME => $name});
341 if ($op{OPTIMIZABLE}) {
342 die "random variate functions must be marked `no_opt'"
343 if $op{NAME} =~ /^RV\./;
344 for my $aux (@{$op{AUX}}) {
345 if (any ($aux->{TYPE}, @type{qw (CASE CASE_IDX)})) {
346 die "operators with $aux->{TYPE} aux data must be "
352 if ($op{RETURNS} eq $type{STRING} && !defined ($op{ABSORB_MISS})) {
354 for my $arg (@{$op{ARGS}}) {
355 if (any ($arg->{TYPE}, @type{qw (NUMBER BOOLEAN)})) {
356 die "$op{NAME} returns string and has double or bool "
357 . "argument, but is not marked ABSORB_MISS";
359 if (defined $arg->{CONDITION}) {
360 die "$op{NAME} returns string but has argument with condition";
365 if ($toktype eq 'block') {
366 $op{BLOCK} = force ('block');
367 } elsif ($toktype eq 'expression') {
368 if ($token eq 'unimplemented') {
369 $op{UNIMPLEMENTED} = 1;
371 $op{EXPRESSION} = $token;
375 die "block or expression expected";
378 die "duplicate operation name $opname" if defined $ops{$opname};
379 $ops{$opname} = \%op;
380 if ($op{CATEGORY} eq 'function') {
381 push (@funcs, $opname);
383 push (@opers, $opname);
388 @funcs = sort {$ops{$a}->{NAME} cmp $ops{$b}->{NAME}
390 $ops{$a}->{OPNAME} cmp $ops{$b}->{OPNAME}}
392 @opers = sort {$ops{$a}->{NAME} cmp $ops{$b}->{NAME}} @opers;
393 @order = (@funcs, @opers);
396 # Reads the next token into $token, $toktype.
400 return if defined ($toktype) && $toktype eq 'eof';
401 $toktype = 'id', $token = $1, return
402 if $line =~ /\G([a-zA-Z_][a-zA-Z_.0-9]*)/gc;
403 $toktype = 'int', $token = $1, return if $line =~ /\G([0-9]+)/gc;
404 $toktype = 'punct', $token = $1, return if $line =~ /\G([][(),*;.])/gc;
405 if ($line =~ /\G=/gc) {
406 $toktype = "expression";
408 $token = accumulate_balanced (';');
409 } elsif ($line =~ /\G\{/gc) {
411 $token = accumulate_balanced ('}');
414 die "bad character `" . substr ($line, pos $line, 1) . "' in input";
418 # Skip whitespace, then return the remainder of the line.
421 die "unexpected end of file" if !defined ($line);
424 last if pos ($line) < length ($line);
426 $token = $toktype = 'eof', return if !defined ($line);
428 return substr ($line, pos ($line));
431 # accumulate_balanced($chars)
433 # Accumulates input until a character in $chars is encountered, except
434 # that balanced pairs of (), [], or {} cause $chars to be ignored.
436 # Returns the input read.
437 sub accumulate_balanced {
443 my ($start) = pos ($line);
444 if ($line =~ /\G([^][(){};,]*)([][(){};,])/gc) {
445 $s .= substr ($line, $start, pos ($line) - $start - 1)
446 if pos ($line) > $start;
447 my ($last) = substr ($line, pos ($line) - 1, 1);
448 if ($last =~ /[[({]/) {
451 } elsif ($last =~ /[])}]/) {
455 } elsif (index ($end, $last) >= 0) {
458 die "unbalanced parentheses";
460 } elsif (index ($end, $last) >= 0) {
467 $s .= substr ($line, pos ($line)) . "\n";
473 # Reads the next line from INPUT into $line.
477 if (defined ($line)) {
484 # If the current token is an identifier that names a type,
485 # returns the type and skips to the next token.
486 # Otherwise, returns undef.
488 if ($toktype eq 'id') {
489 foreach my $type (values (%type)) {
490 get_token (), return $type
491 if defined ($type->{NAME}) && $type->{NAME} eq $token;
499 # Makes sure that $toktype equals $type, reads the next token, and
500 # returns the previous $token.
503 die "parse error at `$token' expecting $type"
504 if $type ne $toktype;
512 # If $token equals $tok, reads the next token and returns true.
513 # Otherwise, returns false.
516 if ($token eq $tok) {
526 # If $token equals $tok, reads the next token.
527 # Otherwise, flags an error in the input.
530 die "parse error at `$token' expecting `$tok'" if !match ($tok);
533 # Parses and returns a function argument.
536 $arg{TYPE} = parse_type () || $type{NUMBER};
537 die "argument name expected at `$token'" if $toktype ne 'id';
540 if (lookahead () =~ /^[[,)]/) {
543 die "only double and string arrays supported"
544 if !any ($arg{TYPE}, @type{qw (NUMBER STRING)});
545 $arg{IDX} = force ('id');
547 $arg{TIMES} = force ('int');
548 die "multiplication factor must be positive"
556 $arg{CONDITION} = $arg{NAME} . ' ' . accumulate_balanced (',)');
566 # Prints the output file header.
570 Generated from $input_file by generate.pl.
576 # Prints the output file trailer.
589 sub generate_evaluate_h {
590 print "#include \"helpers.h\"\n\n";
592 for my $opname (@order) {
593 my ($op) = $ops{$opname};
594 next if $op->{UNIMPLEMENTED};
597 for my $arg (@{$op->{ARGS}}) {
598 if (!defined $arg->{IDX}) {
599 push (@args, c_type ($arg->{TYPE}) . $arg->{NAME});
601 push (@args, c_type ($arg->{TYPE}) . "$arg->{NAME}" . "[]");
602 push (@args, "size_t $arg->{IDX}");
605 for my $aux (@{$op->{AUX}}) {
606 push (@args, c_type ($aux->{TYPE}) . $aux->{NAME});
608 push (@args, "void") if !@args;
610 my ($statements) = $op->{BLOCK} || " return $op->{EXPRESSION};\n";
612 print "static inline ", c_type ($op->{RETURNS}), "\n";
613 print "eval_$opname (", join (', ', @args), ")\n";
620 sub generate_evaluate_inc {
621 for my $opname (@order) {
622 my ($op) = $ops{$opname};
624 if ($op->{UNIMPLEMENTED}) {
625 print "case $opname:\n";
626 print " NOT_REACHED ();\n\n";
632 for my $arg (@{$op->{ARGS}}) {
633 my ($name) = $arg->{NAME};
634 my ($type) = $arg->{TYPE};
635 my ($c_type) = c_type ($type);
636 my ($idx) = $arg->{IDX};
637 push (@args, "arg_$arg->{NAME}");
638 if (!defined ($idx)) {
639 my ($decl) = "${c_type}arg_$name";
640 if ($type->{ROLE} eq 'any') {
641 unshift (@decls, "$decl = *--$type->{STACK}");
642 } elsif ($type->{ROLE} eq 'leaf') {
643 push (@decls, "$decl = op++->$type->{ATOM}");
648 my ($stack) = $type->{STACK};
649 defined $stack or die;
651 "$c_type*arg_$arg->{NAME} = $stack -= arg_$idx");
652 unshift (@decls, "size_t arg_$arg->{IDX} = op++->integer");
654 my ($idx) = "arg_$idx";
655 if ($arg->{TIMES} != 1) {
656 $idx .= " / $arg->{TIMES}";
661 for my $aux (@{$op->{AUX}}) {
662 my ($type) = $aux->{TYPE};
663 my ($name) = $aux->{NAME};
664 if ($type->{ROLE} eq 'leaf') {
665 my ($c_type) = c_type ($type);
666 push (@decls, "${c_type}aux_$name = op++->$type->{ATOM}");
667 push (@args, "aux_$name");
668 } elsif ($type->{ROLE} eq 'fixed') {
669 push (@args, $type->{FIXED_VALUE});
673 my ($sysmis_cond) = make_sysmis_decl ($op, "op++->integer");
674 push (@decls, $sysmis_cond) if defined $sysmis_cond;
676 my ($result) = "eval_$op->{OPNAME} (" . join (', ', @args) . ")";
678 my ($stack) = $op->{RETURNS}{STACK};
680 print "case $opname:\n";
683 print " $_;\n" foreach @decls;
684 if (defined $sysmis_cond) {
685 my ($miss_ret) = $op->{RETURNS}{MISSING_VALUE};
686 print " *$stack++ = force_sysmis ? $miss_ret : $result;\n";
688 print " *$stack++ = $result;\n";
692 print " *$stack++ = $result;\n";
698 sub generate_operations_h {
699 print "#include <stdlib.h>\n";
700 print "#include <stdbool.h>\n\n";
702 print "typedef enum";
705 foreach my $type (@types) {
706 next if $type->{ROLE} eq 'fixed';
707 push (@atoms, "OP_$type->{NAME}");
709 print_operations ('atom', 1, \@atoms);
710 print_operations ('function', "OP_atom_last + 1", \@funcs);
711 print_operations ('operator', "OP_function_last + 1", \@opers);
712 print_range ("OP_composite", "OP_function_first", "OP_operator_last");
714 print_range ("OP", "OP_atom_first", "OP_composite_last");
716 print "operation_type, atom_type;\n";
718 print_predicate ('is_operation', 'OP');
719 print_predicate ("is_$_", "OP_$_")
720 foreach qw (atom composite function operator);
723 sub print_operations {
724 my ($type, $first, $names) = @_;
725 print " /* \u$type types. */\n";
726 print " $names->[0] = $first,\n";
727 print " $_,\n" foreach @$names[1...$#{$names}];
728 print_range ("OP_$type", $names->[0], $names->[$#{$names}]);
733 my ($prefix, $first, $last) = @_;
734 print " ${prefix}_first = $first,\n";
735 print " ${prefix}_last = $last,\n";
736 print " ${prefix}_cnt = ${prefix}_last - ${prefix}_first + 1";
739 sub print_predicate {
740 my ($function, $category) = @_;
741 my ($assertion) = "";
743 print "\nstatic inline bool\n";
744 print "$function (operation_type op)\n";
746 print " assert (is_operation (op));\n" if $function ne 'is_operation';
747 print " return op >= ${category}_first && op <= ${category}_last;\n";
751 sub generate_optimize_inc {
752 for my $opname (@order) {
753 my ($op) = $ops{$opname};
755 if (!$op->{OPTIMIZABLE} || $op->{UNIMPLEMENTED}) {
756 print "case $opname:\n";
757 print " NOT_REACHED ();\n\n";
763 for my $arg (@{$op->{ARGS}}) {
765 my ($name) = $arg->{NAME};
766 my ($type) = $arg->{TYPE};
767 my ($ctype) = c_type ($type);
768 my ($idx) = $arg->{IDX};
769 if (!defined ($idx)) {
770 my ($func) = "get_$type->{ATOM}_arg";
771 push (@decls, "${ctype}arg_$name = $func (node, $arg_idx)");
773 my ($decl) = "size_t arg_$idx = node->arg_cnt";
774 $decl .= " - $arg_idx" if $arg_idx;
775 push (@decls, $decl);
777 push (@decls, "${ctype}*arg_$name = "
778 . "get_$type->{ATOM}_args "
779 . " (node, $arg_idx, arg_$idx, e)");
784 my ($sysmis_cond) = make_sysmis_decl ($op, "node->min_valid");
785 push (@decls, $sysmis_cond) if defined $sysmis_cond;
788 for my $arg (@{$op->{ARGS}}) {
789 push (@args, "arg_$arg->{NAME}");
790 if (defined $arg->{IDX}) {
791 my ($idx) = "arg_$arg->{IDX}";
792 $idx .= " / $arg->{TIMES}" if $arg->{TIMES} != 1;
796 for my $aux (@{$op->{AUX}}) {
797 my ($type) = $aux->{TYPE};
798 if ($type->{ROLE} eq 'leaf') {
799 my ($func) = "get_$type->{ATOM}_arg";
800 push (@args, "$func (node, $arg_idx)");
802 } elsif ($type->{ROLE} eq 'fixed') {
803 push (@args, $type->{FIXED_VALUE});
809 my ($result) = "eval_$op->{OPNAME} (" . join (', ', @args) . ")";
810 if (@decls && defined ($sysmis_cond)) {
811 my ($miss_ret) = $op->{RETURNS}{MISSING_VALUE};
812 push (@decls, c_type ($op->{RETURNS}) . "result = "
813 . "force_sysmis ? $miss_ret : $result");
817 print "case $opname:\n";
818 my ($alloc_func) = "expr_allocate_$op->{RETURNS}{NAME}";
821 print " $_;\n" foreach @decls;
822 print " return $alloc_func (e, $result);\n";
825 print " return $alloc_func (e, $result);\n";
831 sub generate_parse_inc {
832 my (@members) = ("\"\"", "\"\"", 0, 0, 0, "{}", 0, 0);
833 print "{", join (', ', @members), "},\n";
835 for my $type (@types) {
836 next if $type->{ROLE} eq 'fixed';
838 my ($human_name) = $type->{HUMAN_NAME};
839 $human_name = $type->{NAME} if !defined $human_name;
841 my (@members) = ("\"$type->{NAME}\"", "\"$human_name\"",
842 0, "OP_$type->{NAME}", 0, "{}", 0, 0);
843 print "{", join (', ', @members), "},\n";
846 for my $opname (@order) {
847 my ($op) = $ops{$opname};
851 push (@members, "\"$op->{NAME}\"");
853 if ($op->{CATEGORY} eq 'function') {
854 my (@args, @opt_args);
855 for my $arg (@{$op->{ARGS}}) {
856 push (@args, $arg->{TYPE}{HUMAN_NAME}) if !defined $arg->{IDX};
859 if (my ($array) = array_arg ($op)) {
860 if (!defined $op->{MIN_VALID}) {
862 for (my $i = 0; $i < $array->{TIMES}; $i++) {
863 push (@array_args, $array->{TYPE}{HUMAN_NAME});
865 push (@args, @array_args);
866 @opt_args = @array_args;
868 for (my $i = 0; $i < $op->{MIN_VALID}; $i++) {
869 push (@args, $array->{TYPE}{HUMAN_NAME});
871 push (@opt_args, $array->{TYPE}{HUMAN_NAME});
874 my ($human) = "$op->{NAME}(" . join (', ', @args);
875 $human .= '[, ' . join (', ', @opt_args) . ']...' if @opt_args;
877 push (@members, "\"$human\"");
879 push (@members, "NULL");
883 push (@flags, "OPF_ABSORB_MISS") if defined $op->{ABSORB_MISS};
884 push (@flags, "OPF_ARRAY_OPERAND") if array_arg ($op);
885 push (@flags, "OPF_MIN_VALID") if defined $op->{MIN_VALID};
886 push (@flags, "OPF_NONOPTIMIZABLE") if !$op->{OPTIMIZABLE};
887 push (@flags, "OPF_EXTENSION") if $op->{EXTENSION};
888 push (@flags, "OPF_UNIMPLEMENTED") if $op->{UNIMPLEMENTED};
889 push (@flags, "OPF_PERM_ONLY") if $op->{PERM_ONLY};
890 push (@flags, "OPF_NO_ABBREV") if $op->{NO_ABBREV};
891 push (@members, @flags ? join (' | ', @flags) : 0);
893 push (@members, "OP_$op->{RETURNS}{NAME}");
895 push (@members, scalar (@{$op->{ARGS}}));
897 my (@arg_types) = map ("OP_$_->{TYPE}{NAME}", @{$op->{ARGS}});
898 push (@members, "{" . join (', ', @arg_types) . "}");
900 push (@members, $op->{MIN_VALID} || 0);
902 push (@members, array_arg ($op) ? ${array_arg ($op)}{TIMES} : 0);
904 print "{", join (', ', @members), "},\n";
910 # any($target, @list)
912 # Returns true if $target appears in @list,
915 $_ eq $_[0] and return 1 foreach @_[1...$#_];
919 # make_sysmis_decl($op, $min_valid_src)
921 # Returns a declaration for a boolean variable called `force_sysmis',
922 # which will be true when operation $op should be system-missing.
923 # Returns undef if there are no such circumstances.
925 # If $op has a minimum number of valid arguments, $min_valid_src
926 # should be an an expression that evaluates to the minimum number of
927 # valid arguments for $op.
928 sub make_sysmis_decl {
929 my ($op, $min_valid_src) = @_;
931 if (!$op->{ABSORB_MISS}) {
932 for my $arg (@{$op->{ARGS}}) {
933 my ($arg_name) = "arg_$arg->{NAME}";
934 if (!defined $arg->{IDX}) {
935 if (any ($arg->{TYPE}, @type{qw (NUMBER BOOLEAN)})) {
936 push (@sysmis_cond, "!is_valid ($arg_name)");
938 } elsif ($arg->{TYPE} eq $type{NUMBER}) {
939 my ($a) = "$arg_name";
940 my ($n) = "arg_$arg->{IDX}";
941 push (@sysmis_cond, "count_valid ($a, $n) < $n");
944 } elsif (defined $op->{MIN_VALID}) {
945 my ($args) = $op->{ARGS};
946 my ($arg) = ${$args}[$#{$args}];
947 my ($a) = "arg_$arg->{NAME}";
948 my ($n) = "arg_$arg->{IDX}";
949 push (@sysmis_cond, "count_valid ($a, $n) < $min_valid_src");
951 for my $arg (@{$op->{ARGS}}) {
952 push (@sysmis_cond, "!($arg->{CONDITION})")
953 if defined $arg->{CONDITION};
955 return "bool force_sysmis = " . join (' || ', @sysmis_cond)
962 # If $op has an array argument, return it.
963 # Otherwise, returns undef.
966 my ($args) = $op->{ARGS};
968 my ($last_arg) = $args->[@$args - 1];
969 return $last_arg if defined $last_arg->{IDX};