X-Git-Url: https://pintos-os.org/cgi-bin/gitweb.cgi?a=blobdiff_plain;f=src%2Flanguage%2Fexpressions%2Fgenerate.pl;h=228095db9443c098f8929c9da6fcf97e002cbf1f;hb=3b54533821614d17afc61f1cd3b87d3a06fbf4da;hp=4ad1764b1c3c96152703b90e8a22afb85f8120db;hpb=ca31bef58d82ef1dfdb00a7a65667608ddc6ec9f;p=pspp
diff --git a/src/language/expressions/generate.pl b/src/language/expressions/generate.pl
index 4ad1764b1c..228095db94 100644
--- a/src/language/expressions/generate.pl
+++ b/src/language/expressions/generate.pl
@@ -1,11 +1,25 @@
+# PSPP - a program for statistical analysis.
+# Copyright (C) 2017 Free Software Foundation, Inc.
+#
+# This program is free software: you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation, either version 3 of the License, or
+# (at your option) any later version.
+#
+# This program is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this program. If not, see .
+#
use strict;
use warnings 'all';
use Getopt::Long;
# Parse command line.
-our ($default_output_file) = $0;
-$default_output_file =~ s/\.pl//;
our ($input_file);
our ($output_file);
parse_cmd_line ();
@@ -16,12 +30,24 @@ init_all_types ();
# Parse input file.
our (%ops);
-our (@funcs, @opers);
+our (@funcs, @opers, @order);
parse_input ();
# Produce output.
print_header ();
-generate_output ();
+if ($output_file =~ /evaluate\.h$/) {
+ generate_evaluate_h ();
+} elsif ($output_file =~ /evaluate\.inc$/) {
+ generate_evaluate_inc ();
+} elsif ($output_file =~ /operations\.h$/) {
+ generate_operations_h ();
+} elsif ($output_file =~ /optimize\.inc$/) {
+ generate_optimize_inc ();
+} elsif ($output_file =~ /parse\.inc$/) {
+ generate_parse_inc ();
+} else {
+ die "$output_file: unknown output type\n";
+}
print_trailer ();
# Command line.
@@ -36,7 +62,7 @@ sub parse_cmd_line {
or exit 1;
$input_file = "operations.def" if !defined $input_file;
- $output_file = $default_output_file if !defined $output_file;
+ die "$0: output file must be specified\n" if !defined $output_file;
open (INPUT, "<$input_file") or die "$input_file: open: $!\n";
open (OUTPUT, ">$output_file") or die "$output_file: create: $!\n";
@@ -46,10 +72,10 @@ sub parse_cmd_line {
sub usage {
print < 'double',
- ATOM => 'number', MANGLE => 'n', HUMAN_NAME => 'num',
+ ATOM => 'number', MANGLE => 'n', HUMAN_NAME => 'number',
STACK => 'ns', MISSING_VALUE => 'SYSMIS');
- init_type ('string', 'any', C_TYPE => 'struct fixed_string',
+ init_type ('string', 'any', C_TYPE => 'struct substring',
ATOM => 'string', MANGLE => 's', HUMAN_NAME => 'string',
STACK => 'ss', MISSING_VALUE => 'empty_string');
init_type ('boolean', 'any', C_TYPE => 'double',
@@ -99,6 +125,9 @@ sub init_all_types {
init_type ('str_var', 'leaf', C_TYPE => 'const struct variable *',
ATOM => 'variable', MANGLE => 'Vs',
HUMAN_NAME => 'string_variable');
+ init_type ('var', 'leaf', C_TYPE => 'const struct variable *',
+ ATOM => 'variable', MANGLE => 'V',
+ HUMAN_NAME => 'variable');
# Vectors.
init_type ('vector', 'leaf', C_TYPE => 'const struct vector *',
@@ -111,6 +140,8 @@ sub init_all_types {
FIXED_VALUE => 'c');
init_type ('case_idx', 'fixed', C_TYPE => 'size_t',
FIXED_VALUE => 'case_idx');
+ init_type ('dataset', 'fixed', C_TYPE => 'struct dataset *',
+ FIXED_VALUE => 'ds');
# One of these is emitted at the end of each expression as a sentinel
# that tells expr_evaluate() to return the value on the stack.
@@ -243,6 +274,8 @@ sub parse_input {
$op{ABSORB_MISS} = 1;
} elsif (match ('perm_only')) {
$op{PERM_ONLY} = 1;
+ } elsif (match ('no_abbrev')) {
+ $op{NO_ABBREV} = 1;
} else {
last;
}
@@ -373,7 +406,7 @@ sub parse_input {
$ops{$a}->{OPNAME} cmp $ops{$b}->{OPNAME}}
@funcs;
@opers = sort {$ops{$a}->{NAME} cmp $ops{$b}->{NAME}} @opers;
- our (@order) = (@funcs, @opers);
+ @order = (@funcs, @opers);
}
# Reads the next token into $token, $toktype.
@@ -550,7 +583,7 @@ sub parse_arg {
sub print_header {
print <{UNIMPLEMENTED};
+
+ my (@args);
+ for my $arg (@{$op->{ARGS}}) {
+ if (!defined $arg->{IDX}) {
+ push (@args, c_type ($arg->{TYPE}) . $arg->{NAME});
+ } else {
+ push (@args, c_type ($arg->{TYPE}) . "$arg->{NAME}" . "[]");
+ push (@args, "size_t $arg->{IDX}");
+ }
+ }
+ for my $aux (@{$op->{AUX}}) {
+ push (@args, c_type ($aux->{TYPE}) . $aux->{NAME});
+ }
+ push (@args, "void") if !@args;
+
+ my ($statements) = $op->{BLOCK} || " return $op->{EXPRESSION};\n";
+
+ print "static inline ", c_type ($op->{RETURNS}), "\n";
+ print "eval_$opname (", join (', ', @args), ")\n";
+ print "{\n";
+ print "$statements";
+ print "}\n\n";
+ }
+}
+
+sub generate_evaluate_inc {
+ for my $opname (@order) {
+ my ($op) = $ops{$opname};
+
+ if ($op->{UNIMPLEMENTED}) {
+ print "case $opname:\n";
+ print " NOT_REACHED ();\n\n";
+ next;
+ }
+
+ my (@decls);
+ my (@args);
+ for my $arg (@{$op->{ARGS}}) {
+ my ($name) = $arg->{NAME};
+ my ($type) = $arg->{TYPE};
+ my ($c_type) = c_type ($type);
+ my ($idx) = $arg->{IDX};
+ push (@args, "arg_$arg->{NAME}");
+ if (!defined ($idx)) {
+ my ($decl) = "${c_type}arg_$name";
+ if ($type->{ROLE} eq 'any') {
+ unshift (@decls, "$decl = *--$type->{STACK}");
+ } elsif ($type->{ROLE} eq 'leaf') {
+ push (@decls, "$decl = op++->$type->{ATOM}");
+ } else {
+ die;
+ }
+ } else {
+ my ($stack) = $type->{STACK};
+ defined $stack or die;
+ unshift (@decls,
+ "$c_type*arg_$arg->{NAME} = $stack -= arg_$idx");
+ unshift (@decls, "size_t arg_$arg->{IDX} = op++->integer");
+
+ my ($idx) = "arg_$idx";
+ if ($arg->{TIMES} != 1) {
+ $idx .= " / $arg->{TIMES}";
+ }
+ push (@args, $idx);
+ }
+ }
+ for my $aux (@{$op->{AUX}}) {
+ my ($type) = $aux->{TYPE};
+ my ($name) = $aux->{NAME};
+ if ($type->{ROLE} eq 'leaf') {
+ my ($c_type) = c_type ($type);
+ push (@decls, "${c_type}aux_$name = op++->$type->{ATOM}");
+ push (@args, "aux_$name");
+ } elsif ($type->{ROLE} eq 'fixed') {
+ push (@args, $type->{FIXED_VALUE});
+ }
+ }
+
+ my ($sysmis_cond) = make_sysmis_decl ($op, "op++->integer");
+ push (@decls, $sysmis_cond) if defined $sysmis_cond;
+
+ my ($result) = "eval_$op->{OPNAME} (" . join (', ', @args) . ")";
+
+ my ($stack) = $op->{RETURNS}{STACK};
+
+ print "case $opname:\n";
+ if (@decls) {
+ print " {\n";
+ print " $_;\n" foreach @decls;
+ if (defined $sysmis_cond) {
+ my ($miss_ret) = $op->{RETURNS}{MISSING_VALUE};
+ print " *$stack++ = force_sysmis ? $miss_ret : $result;\n";
+ } else {
+ print " *$stack++ = $result;\n";
+ }
+ print " }\n";
+ } else {
+ print " *$stack++ = $result;\n";
+ }
+ print " break;\n\n";
+ }
+}
+
+sub generate_operations_h {
+ print "#include \n";
+ print "#include \n\n";
+
+ print "typedef enum";
+ print " {\n";
+ my (@atoms);
+ foreach my $type (@types) {
+ next if $type->{ROLE} eq 'fixed';
+ push (@atoms, "OP_$type->{NAME}");
+ }
+ print_operations ('atom', 1, \@atoms);
+ print_operations ('function', "OP_atom_last + 1", \@funcs);
+ print_operations ('operator', "OP_function_last + 1", \@opers);
+ print_range ("OP_composite", "OP_function_first", "OP_operator_last");
+ print ",\n\n";
+ print_range ("OP", "OP_atom_first", "OP_composite_last");
+ print "\n }\n";
+ print "operation_type, atom_type;\n";
+
+ print_predicate ('is_operation', 'OP');
+ print_predicate ("is_$_", "OP_$_")
+ foreach qw (atom composite function operator);
+}
+
+sub print_operations {
+ my ($type, $first, $names) = @_;
+ print " /* \u$type types. */\n";
+ print " $names->[0] = $first,\n";
+ print " $_,\n" foreach @$names[1...$#{$names}];
+ print_range ("OP_$type", $names->[0], $names->[$#{$names}]);
+ print ",\n\n";
+}
+
+sub print_range {
+ my ($prefix, $first, $last) = @_;
+ print " ${prefix}_first = $first,\n";
+ print " ${prefix}_last = $last,\n";
+ print " ${prefix}_cnt = ${prefix}_last - ${prefix}_first + 1";
+}
+
+sub print_predicate {
+ my ($function, $category) = @_;
+ my ($assertion) = "";
+
+ print "\nstatic inline bool\n";
+ print "$function (operation_type op)\n";
+ print "{\n";
+ print " assert (is_operation (op));\n" if $function ne 'is_operation';
+ print " return op >= ${category}_first && op <= ${category}_last;\n";
+ print "}\n";
+}
+
+sub generate_optimize_inc {
+ for my $opname (@order) {
+ my ($op) = $ops{$opname};
+
+ if (!$op->{OPTIMIZABLE} || $op->{UNIMPLEMENTED}) {
+ print "case $opname:\n";
+ print " NOT_REACHED ();\n\n";
+ next;
+ }
+
+ my (@decls);
+ my ($arg_idx) = 0;
+ for my $arg (@{$op->{ARGS}}) {
+ my ($decl);
+ my ($name) = $arg->{NAME};
+ my ($type) = $arg->{TYPE};
+ my ($ctype) = c_type ($type);
+ my ($idx) = $arg->{IDX};
+ if (!defined ($idx)) {
+ my ($func) = "get_$type->{ATOM}_arg";
+ push (@decls, "${ctype}arg_$name = $func (node, $arg_idx)");
+ } else {
+ my ($decl) = "size_t arg_$idx = node->arg_cnt";
+ $decl .= " - $arg_idx" if $arg_idx;
+ push (@decls, $decl);
+
+ push (@decls, "${ctype}*arg_$name = "
+ . "get_$type->{ATOM}_args "
+ . " (node, $arg_idx, arg_$idx, e)");
+ }
+ $arg_idx++;
+ }
+
+ my ($sysmis_cond) = make_sysmis_decl ($op, "node->min_valid");
+ push (@decls, $sysmis_cond) if defined $sysmis_cond;
+
+ my (@args);
+ for my $arg (@{$op->{ARGS}}) {
+ push (@args, "arg_$arg->{NAME}");
+ if (defined $arg->{IDX}) {
+ my ($idx) = "arg_$arg->{IDX}";
+ $idx .= " / $arg->{TIMES}" if $arg->{TIMES} != 1;
+ push (@args, $idx);
+ }
+ }
+ for my $aux (@{$op->{AUX}}) {
+ my ($type) = $aux->{TYPE};
+ if ($type->{ROLE} eq 'leaf') {
+ my ($func) = "get_$type->{ATOM}_arg";
+ push (@args, "$func (node, $arg_idx)");
+ $arg_idx++;
+ } elsif ($type->{ROLE} eq 'fixed') {
+ push (@args, $type->{FIXED_VALUE});
+ } else {
+ die;
+ }
+ }
+
+ my ($result) = "eval_$op->{OPNAME} (" . join (', ', @args) . ")";
+ if (@decls && defined ($sysmis_cond)) {
+ my ($miss_ret) = $op->{RETURNS}{MISSING_VALUE};
+ push (@decls, c_type ($op->{RETURNS}) . "result = "
+ . "force_sysmis ? $miss_ret : $result");
+ $result = "result";
+ }
+
+ print "case $opname:\n";
+ my ($alloc_func) = "expr_allocate_$op->{RETURNS}{NAME}";
+ if (@decls) {
+ print " {\n";
+ print " $_;\n" foreach @decls;
+ print " return $alloc_func (e, $result);\n";
+ print " }\n";
+ } else {
+ print " return $alloc_func (e, $result);\n";
+ }
+ print "\n";
+ }
+}
+
+sub generate_parse_inc {
+ my (@members) = ("\"\"", "\"\"", 0, 0, 0, "{}", 0, 0);
+ print "{", join (', ', @members), "},\n";
+
+ for my $type (@types) {
+ next if $type->{ROLE} eq 'fixed';
+
+ my ($human_name) = $type->{HUMAN_NAME};
+ $human_name = $type->{NAME} if !defined $human_name;
+
+ my (@members) = ("\"$type->{NAME}\"", "\"$human_name\"",
+ 0, "OP_$type->{NAME}", 0, "{}", 0, 0);
+ print "{", join (', ', @members), "},\n";
+ }
+
+ for my $opname (@order) {
+ my ($op) = $ops{$opname};
+
+ my (@members);
+
+ push (@members, "\"$op->{NAME}\"");
+
+ if ($op->{CATEGORY} eq 'function') {
+ my (@args, @opt_args);
+ for my $arg (@{$op->{ARGS}}) {
+ push (@args, $arg->{TYPE}{HUMAN_NAME}) if !defined $arg->{IDX};
+ }
+
+ if (my ($array) = array_arg ($op)) {
+ if (!defined $op->{MIN_VALID}) {
+ my (@array_args);
+ for (my $i = 0; $i < $array->{TIMES}; $i++) {
+ push (@array_args, $array->{TYPE}{HUMAN_NAME});
+ }
+ push (@args, @array_args);
+ @opt_args = @array_args;
+ } else {
+ for (my $i = 0; $i < $op->{MIN_VALID}; $i++) {
+ push (@args, $array->{TYPE}{HUMAN_NAME});
+ }
+ push (@opt_args, $array->{TYPE}{HUMAN_NAME});
+ }
+ }
+ my ($human) = "$op->{NAME}(" . join (', ', @args);
+ $human .= '[, ' . join (', ', @opt_args) . ']...' if @opt_args;
+ $human .= ')';
+ push (@members, "\"$human\"");
+ } else {
+ push (@members, "NULL");
+ }
+
+ my (@flags);
+ push (@flags, "OPF_ABSORB_MISS") if defined $op->{ABSORB_MISS};
+ push (@flags, "OPF_ARRAY_OPERAND") if array_arg ($op);
+ push (@flags, "OPF_MIN_VALID") if defined $op->{MIN_VALID};
+ push (@flags, "OPF_NONOPTIMIZABLE") if !$op->{OPTIMIZABLE};
+ push (@flags, "OPF_EXTENSION") if $op->{EXTENSION};
+ push (@flags, "OPF_UNIMPLEMENTED") if $op->{UNIMPLEMENTED};
+ push (@flags, "OPF_PERM_ONLY") if $op->{PERM_ONLY};
+ push (@flags, "OPF_NO_ABBREV") if $op->{NO_ABBREV};
+ push (@members, @flags ? join (' | ', @flags) : 0);
+
+ push (@members, "OP_$op->{RETURNS}{NAME}");
+
+ push (@members, scalar (@{$op->{ARGS}}));
+
+ my (@arg_types) = map ("OP_$_->{TYPE}{NAME}", @{$op->{ARGS}});
+ push (@members, "{" . join (', ', @arg_types) . "}");
+
+ push (@members, $op->{MIN_VALID} || 0);
+
+ push (@members, array_arg ($op) ? ${array_arg ($op)}{TIMES} : 0);
+
+ print "{", join (', ', @members), "},\n";
+ }
+}
# Utilities.
@@ -591,7 +943,7 @@ sub any {
# valid arguments for $op.
sub make_sysmis_decl {
my ($op, $min_valid_src) = @_;
- my (@sysmis_cond);
+ my (@sysmis_cond);
if (!$op->{ABSORB_MISS}) {
for my $arg (@{$op->{ARGS}}) {
my ($arg_name) = "arg_$arg->{NAME}";