Use a casefile, instead of a case sink, for MATCH FILES output.
[pspp] / src / language / expressions / evaluate.c
1 /* PSPP - computes sample statistics.
2    Copyright (C) 1997-9, 2000 Free Software Foundation, Inc.
3    Written by Ben Pfaff <blp@gnu.org>.
4
5    This program is free software; you can redistribute it and/or
6    modify it under the terms of the GNU General Public License as
7    published by the Free Software Foundation; either version 2 of the
8    License, or (at your option) any later version.
9
10    This program is distributed in the hope that it will be useful, but
11    WITHOUT ANY WARRANTY; without even the implied warranty of
12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13    General Public License for more details.
14
15    You should have received a copy of the GNU General Public License
16    along with this program; if not, write to the Free Software
17    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
18    02110-1301, USA. */
19
20 #include <config.h>
21 #include "private.h"
22
23 #include <ctype.h>
24 #include <libpspp/alloc.h>
25 #include <libpspp/message.h>
26 #include "helpers.h"
27 #include "evaluate.h"
28 #include <libpspp/pool.h>
29
30 static void
31 expr_evaluate (struct expression *e, const struct ccase *c, int case_idx,
32                void *result)
33 {
34   union operation_data *op = e->ops;
35
36   double *ns = e->number_stack;
37   struct fixed_string *ss = e->string_stack;
38
39   assert ((c != NULL) == (e->dict != NULL));
40   pool_clear (e->eval_pool);
41
42   for (;;)
43     {
44       assert (op < e->ops + e->op_cnt);
45       switch (op++->operation)
46         {
47         case OP_number:
48         case OP_boolean:
49           *ns++ = op++->number;
50           break;
51
52         case OP_string:
53           {
54             const struct fixed_string *s = &op++->string;
55             *ss++ = copy_string (e, s->string, s->length);
56           }
57           break;
58
59         case OP_return_number:
60           *(double *) result = finite (ns[-1]) ? ns[-1] : SYSMIS;
61           return;
62
63         case OP_return_string:
64           *(struct fixed_string *) result = ss[-1];
65           return;
66
67 #include "evaluate.inc"
68           
69         default:
70           abort ();
71         }
72     }
73 }
74
75 double
76 expr_evaluate_num (struct expression *e, const struct ccase *c, int case_idx)
77 {
78   double d;
79
80   assert (e->type == OP_number || e->type == OP_boolean);
81   expr_evaluate (e, c, case_idx, &d);
82   return d;
83 }
84
85
86
87 void
88 expr_evaluate_str (struct expression *e, const struct ccase *c, int case_idx,
89                    char *dst, size_t dst_size) 
90 {
91   struct fixed_string s;
92
93   assert (e->type == OP_string);
94   assert ((dst == NULL) == (dst_size == 0));
95   expr_evaluate (e, c, case_idx, &s);
96   
97   copy_mangle (dst, dst_size, s.string, s.length);
98 }
99 \f
100 #include <language/lexer/lexer.h>
101 #include <language/command.h>
102
103 int
104 cmd_debug_evaluate (void)
105 {
106   bool optimize = true;
107   int retval = CMD_FAILURE;
108   bool dump_postfix = false;
109   struct dictionary *d = NULL;
110   struct ccase *c = NULL;
111
112   struct expression *expr;
113
114   for (;;) 
115     {
116       if (lex_match_id ("NOOPTIMIZE"))
117         optimize = 0;
118       else if (lex_match_id ("POSTFIX"))
119         dump_postfix = 1;
120       else if (lex_match ('('))
121         {
122           char name[LONG_NAME_LEN + 1];
123           struct variable *v;
124           size_t old_value_cnt;
125           int width;
126
127           if (!lex_force_id ())
128             goto done;
129           strcpy (name, tokid);
130
131           lex_get ();
132           if (!lex_force_match ('='))
133             goto done;
134
135           if (lex_is_number ())
136             {
137               width = 0;
138               fprintf (stderr, "(%s = %.2f)", name, tokval); 
139             }
140           else if (token == T_STRING) 
141             {
142               width = ds_length (&tokstr);
143               fprintf (stderr, "(%s = \"%.2s\")", name, ds_c_str (&tokstr)); 
144             }
145           else
146             {
147               lex_error (_("expecting number or string"));
148               goto done;
149             }
150
151           if (d == NULL)
152             d = dict_create ();
153           
154           old_value_cnt = dict_get_next_value_idx (d);
155           v = dict_create_var (d, name, width);
156           if (v == NULL)
157             {
158               msg (SE, _("Duplicate variable name %s."), name);
159               goto done;
160             }
161
162           if (c == NULL) 
163             {
164               c = xmalloc (sizeof *c);
165               case_nullify (c);
166             }
167           case_resize (c, old_value_cnt, dict_get_next_value_idx (d));
168
169           if (lex_is_number ())
170             case_data_rw (c, v->fv)->f = tokval;
171           else
172             memcpy (case_data_rw (c, v->fv)->s, ds_data (&tokstr),
173                     v->width);
174           lex_get ();
175
176           if (!lex_force_match (')'))
177             goto done;
178         }
179       else 
180         break;
181     }
182   if (token != '/') 
183     {
184       lex_force_match ('/');
185       goto done;
186     }
187   if (d != NULL)
188     fprintf (stderr, "; ");
189   fprintf (stderr, "%s => ", lex_rest_of_line (NULL));
190   lex_get ();
191
192   expr = expr_parse_any (d, optimize);
193   if (!expr || lex_end_of_command () != CMD_SUCCESS)
194     {
195       if (expr != NULL)
196         expr_free (expr);
197       fprintf (stderr, "error\n");
198       goto done;
199     }
200
201   if (dump_postfix) 
202     expr_debug_print_postfix (expr);
203   else 
204     switch (expr->type) 
205       {
206       case OP_number: 
207         {
208           double d = expr_evaluate_num (expr, c, 0);
209           if (d == SYSMIS)
210             fprintf (stderr, "sysmis\n");
211           else
212             fprintf (stderr, "%.2f\n", d); 
213         }
214         break;
215       
216       case OP_boolean: 
217         {
218           double b = expr_evaluate_num (expr, c, 0);
219           fprintf (stderr, "%s\n",
220                    b == SYSMIS ? "sysmis" : b == 0.0 ? "false" : "true"); 
221         }
222         break;
223
224       case OP_string: 
225         {
226           struct fixed_string s;
227           expr_evaluate (expr, c, 0, &s);
228
229           fputc ('"', stderr);
230           fwrite (s.string, s.length, 1, stderr);
231           fputs ("\"\n", stderr);
232           break; 
233         }
234
235       default:
236         assert (0);
237       }
238
239   expr_free (expr);
240   retval = CMD_SUCCESS;
241
242  done:
243   if (c != NULL) 
244     {
245       case_destroy (c);
246       free (c); 
247     }
248   dict_destroy (d);
249   return retval;
250 }
251
252 void
253 expr_debug_print_postfix (const struct expression *e) 
254 {
255   size_t i;
256
257   for (i = 0; i < e->op_cnt; i++) 
258     {
259       union operation_data *op = &e->ops[i];
260       if (i > 0)
261         putc (' ', stderr);
262       switch (e->op_types[i]) 
263         {
264         case OP_operation:
265           if (op->operation == OP_return_number)
266             fprintf (stderr, "return_number");
267           else if (op->operation == OP_return_string)
268             fprintf (stderr, "return_string");
269           else if (is_function (op->operation)) 
270             fprintf (stderr, "%s", operations[op->operation].prototype);
271           else if (is_composite (op->operation)) 
272             fprintf (stderr, "%s", operations[op->operation].name);
273           else
274             fprintf (stderr, "%s:", operations[op->operation].name);
275           break;
276         case OP_number:
277           if (op->number != SYSMIS)
278             fprintf (stderr, "n<%g>", op->number);
279           else
280             fprintf (stderr, "n<SYSMIS>");
281           break;
282         case OP_string:
283           fprintf (stderr, "s<%.*s>",
284                    (int) op->string.length,
285                    op->string.string != NULL ? op->string.string : "");
286           break;
287         case OP_format:
288           fprintf (stderr, "f<%s%d.%d>",
289                   formats[op->format->type].name,
290                   op->format->w, op->format->d);
291           break;
292         case OP_variable:
293           fprintf (stderr, "v<%s>", op->variable->name);
294           break;
295         case OP_vector:
296           fprintf (stderr, "vec<%s>", op->vector->name);
297           break;
298         case OP_integer:
299           fprintf (stderr, "i<%d>", op->integer);
300           break;
301         default:
302           abort ();
303         } 
304     }
305   fprintf (stderr, "\n");
306 }