Updated the docs and the parser for EXAMINE to make it clearer which options
[pspp] / src / language / expressions / evaluate.c
1 /* PSPP - computes sample statistics.
2    Copyright (C) 1997-9, 2000, 2006 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/assertion.h>
26 #include <libpspp/message.h>
27 #include "helpers.h"
28 #include "evaluate.h"
29 #include <libpspp/pool.h>
30
31 static void
32 expr_evaluate (struct expression *e, const struct ccase *c, int case_idx,
33                void *result)
34 {
35   struct dataset *ds = e->ds;
36   union operation_data *op = e->ops;
37
38   double *ns = e->number_stack;
39   struct substring *ss = e->string_stack;
40
41   /* Without a dictionary/dataset, the expression can't refer to variables, 
42      and you don't need to specify a case when you evaluate the
43      expression.  With a dictionary/dataset, the expression can refer
44      to variables, so you must specify a case when you evaluate the
45      expression. */
46   assert ((c != NULL) == (e->ds != NULL));
47
48   pool_clear (e->eval_pool);
49
50   for (;;)
51     {
52       assert (op < e->ops + e->op_cnt);
53       switch (op++->operation)
54         {
55         case OP_number:
56         case OP_boolean:
57           *ns++ = op++->number;
58           break;
59
60         case OP_string:
61           {
62             const struct substring *s = &op++->string;
63             *ss++ = copy_string (e, s->string, s->length);
64           }
65           break;
66
67         case OP_return_number:
68           *(double *) result = finite (ns[-1]) ? ns[-1] : SYSMIS;
69           return;
70
71         case OP_return_string:
72           *(struct substring *) result = ss[-1];
73           return;
74
75 #include "evaluate.inc"
76           
77         default:
78           NOT_REACHED ();
79         }
80     }
81 }
82
83 double
84 expr_evaluate_num (struct expression *e, const struct ccase *c, int case_idx)
85 {
86   double d;
87
88   assert (e->type == OP_number || e->type == OP_boolean);
89   expr_evaluate (e, c, case_idx, &d);
90   return d;
91 }
92
93
94
95 void
96 expr_evaluate_str (struct expression *e, const struct ccase *c, int case_idx,
97                    char *dst, size_t dst_size) 
98 {
99   struct substring s;
100
101   assert (e->type == OP_string);
102   assert ((dst == NULL) == (dst_size == 0));
103   expr_evaluate (e, c, case_idx, &s);
104   
105   buf_copy_rpad (dst, dst_size, s.string, s.length);
106 }
107 \f
108 #include <language/lexer/lexer.h>
109 #include <language/command.h>
110
111 int
112 cmd_debug_evaluate (struct dataset *dsother UNUSED)
113 {
114   bool optimize = true;
115   int retval = CMD_FAILURE;
116   bool dump_postfix = false;
117
118   struct ccase *c = NULL;
119
120   struct dataset *ds = NULL;
121
122   struct expression *expr;
123
124   for (;;) 
125     {
126       struct dictionary *d = NULL;
127       if (lex_match_id ("NOOPTIMIZE"))
128         optimize = 0;
129       else if (lex_match_id ("POSTFIX"))
130         dump_postfix = 1;
131       else if (lex_match ('('))
132         {
133           char name[LONG_NAME_LEN + 1];
134           struct variable *v;
135           size_t old_value_cnt;
136           int width;
137
138           if (!lex_force_id ())
139             goto done;
140           strcpy (name, tokid);
141
142           lex_get ();
143           if (!lex_force_match ('='))
144             goto done;
145
146           if (lex_is_number ())
147             {
148               width = 0;
149               fprintf (stderr, "(%s = %.2f)", name, tokval); 
150             }
151           else if (token == T_STRING) 
152             {
153               width = ds_length (&tokstr);
154               fprintf (stderr, "(%s = \"%.2s\")", name, ds_cstr (&tokstr)); 
155             }
156           else
157             {
158               lex_error (_("expecting number or string"));
159               goto done;
160             }
161           
162           if  ( ds == NULL ) 
163             {
164               ds = create_dataset ();
165               d = dataset_dict (ds);
166             }
167           
168           old_value_cnt = dict_get_next_value_idx (d);
169           v = dict_create_var (d, name, width);
170           if (v == NULL)
171             {
172               msg (SE, _("Duplicate variable name %s."), name);
173               goto done;
174             }
175
176           if (c == NULL) 
177             {
178               c = xmalloc (sizeof *c);
179               case_create (c, dict_get_next_value_idx (d));
180             }
181           else
182             case_resize (c, old_value_cnt, dict_get_next_value_idx (d));
183
184           if (lex_is_number ())
185             case_data_rw (c, v->fv)->f = tokval;
186           else
187             memcpy (case_data_rw (c, v->fv)->s, ds_data (&tokstr),
188                     v->width);
189           lex_get ();
190
191           if (!lex_force_match (')'))
192             goto done;
193         }
194       else 
195         break;
196     }
197   if (token != '/') 
198     {
199       lex_force_match ('/');
200       goto done;
201     }
202
203   if ( ds != NULL ) 
204     fprintf(stderr, "; ");
205   fprintf (stderr, "%s => ", lex_rest_of_line (NULL));
206   lex_get ();
207
208   expr = expr_parse_any (ds, optimize);
209   if (!expr || lex_end_of_command () != CMD_SUCCESS)
210     {
211       if (expr != NULL)
212         expr_free (expr);
213       fprintf (stderr, "error\n");
214       goto done;
215     }
216
217   if (dump_postfix) 
218     expr_debug_print_postfix (expr);
219   else 
220     switch (expr->type) 
221       {
222       case OP_number: 
223         {
224           double d = expr_evaluate_num (expr, c, 0);
225           if (d == SYSMIS)
226             fprintf (stderr, "sysmis\n");
227           else
228             fprintf (stderr, "%.2f\n", d); 
229         }
230         break;
231       
232       case OP_boolean: 
233         {
234           double b = expr_evaluate_num (expr, c, 0);
235           fprintf (stderr, "%s\n",
236                    b == SYSMIS ? "sysmis" : b == 0.0 ? "false" : "true"); 
237         }
238         break;
239
240       case OP_string: 
241         {
242           struct substring s;
243           expr_evaluate (expr, c, 0, &s);
244
245           fputc ('"', stderr);
246           fwrite (s.string, s.length, 1, stderr);
247           fputs ("\"\n", stderr);
248           break; 
249         }
250
251       default:
252         NOT_REACHED ();
253       }
254
255   expr_free (expr);
256   retval = CMD_SUCCESS;
257
258  done:
259   if (ds)
260     destroy_dataset (ds);
261
262   if (c != NULL) 
263     {
264       case_destroy (c);
265       free (c); 
266     }
267
268   return retval;
269 }
270
271 void
272 expr_debug_print_postfix (const struct expression *e) 
273 {
274   size_t i;
275
276   for (i = 0; i < e->op_cnt; i++) 
277     {
278       union operation_data *op = &e->ops[i];
279       if (i > 0)
280         putc (' ', stderr);
281       switch (e->op_types[i]) 
282         {
283         case OP_operation:
284           if (op->operation == OP_return_number)
285             fprintf (stderr, "return_number");
286           else if (op->operation == OP_return_string)
287             fprintf (stderr, "return_string");
288           else if (is_function (op->operation)) 
289             fprintf (stderr, "%s", operations[op->operation].prototype);
290           else if (is_composite (op->operation)) 
291             fprintf (stderr, "%s", operations[op->operation].name);
292           else
293             fprintf (stderr, "%s:", operations[op->operation].name);
294           break;
295         case OP_number:
296           if (op->number != SYSMIS)
297             fprintf (stderr, "n<%g>", op->number);
298           else
299             fprintf (stderr, "n<SYSMIS>");
300           break;
301         case OP_string:
302           fprintf (stderr, "s<%.*s>",
303                    (int) op->string.length,
304                    op->string.string != NULL ? op->string.string : "");
305           break;
306         case OP_format:
307           {
308             char str[FMT_STRING_LEN_MAX + 1];
309             fmt_to_string (op->format, str);
310             fprintf (stderr, "f<%s>", str); 
311           }
312           break;
313         case OP_variable:
314           fprintf (stderr, "v<%s>", op->variable->name);
315           break;
316         case OP_vector:
317           fprintf (stderr, "vec<%s>", op->vector->name);
318           break;
319         case OP_integer:
320           fprintf (stderr, "i<%d>", op->integer);
321           break;
322         default:
323           NOT_REACHED ();
324         } 
325     }
326   fprintf (stderr, "\n");
327 }