Separate random numbers from other settings because of GSL dependency.
[pspp] / src / 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 "alloc.h"
25 #include "error.h"
26 #include "helpers.h"
27 #include "evaluate.h"
28 #include "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 void
86 expr_evaluate_str (struct expression *e, const struct ccase *c, int case_idx,
87                    char *dst, size_t dst_size) 
88 {
89   struct fixed_string s;
90
91   assert (e->type == OP_string);
92   assert ((dst == NULL) == (dst_size == 0));
93   expr_evaluate (e, c, case_idx, &s);
94   buf_copy_rpad (dst, dst_size, s.string, s.length);
95 }
96 \f
97 #include "lexer.h"
98 #include "command.h"
99
100 int
101 cmd_debug_evaluate (void)
102 {
103   bool optimize = true;
104   int retval = CMD_FAILURE;
105   bool dump_postfix = false;
106   struct dictionary *d = NULL;
107   struct ccase *c = NULL;
108
109   struct expression *expr;
110
111   for (;;) 
112     {
113       if (lex_match_id ("NOOPTIMIZE"))
114         optimize = 0;
115       else if (lex_match_id ("POSTFIX"))
116         dump_postfix = 1;
117       else if (lex_match ('('))
118         {
119           char name[LONG_NAME_LEN + 1];
120           struct variable *v;
121           size_t old_value_cnt;
122           int width;
123
124           if (!lex_force_id ())
125             goto done;
126           strcpy (name, tokid);
127
128           lex_get ();
129           if (!lex_force_match ('='))
130             goto done;
131
132           if (lex_is_number ())
133             {
134               width = 0;
135               fprintf (stderr, "(%s = %.2f)", name, tokval); 
136             }
137           else if (token == T_STRING) 
138             {
139               width = ds_length (&tokstr);
140               fprintf (stderr, "(%s = \"%.2s\")", name, ds_c_str (&tokstr)); 
141             }
142           else
143             {
144               lex_error (_("expecting number or string"));
145               goto done;
146             }
147
148           if (d == NULL)
149             d = dict_create ();
150           
151           old_value_cnt = dict_get_next_value_idx (d);
152           v = dict_create_var (d, name, width);
153           if (v == NULL)
154             {
155               msg (SE, _("Duplicate variable name %s."), name);
156               goto done;
157             }
158
159           if (c == NULL) 
160             {
161               c = xmalloc (sizeof *c);
162               case_nullify (c);
163             }
164           case_resize (c, old_value_cnt, dict_get_next_value_idx (d));
165
166           if (lex_is_number ())
167             case_data_rw (c, v->fv)->f = tokval;
168           else
169             memcpy (case_data_rw (c, v->fv)->s, ds_data (&tokstr),
170                     v->width);
171           lex_get ();
172
173           if (!lex_force_match (')'))
174             goto done;
175         }
176       else 
177         break;
178     }
179   if (token != '/') 
180     {
181       lex_force_match ('/');
182       goto done;
183     }
184   if (d != NULL)
185     fprintf (stderr, "; ");
186   fprintf (stderr, "%s => ", lex_rest_of_line (NULL));
187   lex_get ();
188
189   expr = expr_parse_any (d, optimize);
190   if (!expr || lex_end_of_command () != CMD_SUCCESS)
191     {
192       if (expr != NULL)
193         expr_free (expr);
194       fprintf (stderr, "error\n");
195       goto done;
196     }
197
198   if (dump_postfix) 
199     expr_debug_print_postfix (expr);
200   else 
201     switch (expr->type) 
202       {
203       case OP_number: 
204         {
205           double d = expr_evaluate_num (expr, c, 0);
206           if (d == SYSMIS)
207             fprintf (stderr, "sysmis\n");
208           else
209             fprintf (stderr, "%.2f\n", d); 
210         }
211         break;
212       
213       case OP_boolean: 
214         {
215           double b = expr_evaluate_num (expr, c, 0);
216           fprintf (stderr, "%s\n",
217                    b == SYSMIS ? "sysmis" : b == 0.0 ? "false" : "true"); 
218         }
219         break;
220
221       case OP_string: 
222         {
223           struct fixed_string s;
224           expr_evaluate (expr, c, 0, &s);
225
226           fputc ('"', stderr);
227           fwrite (s.string, s.length, 1, stderr);
228           fputs ("\"\n", stderr);
229           break; 
230         }
231
232       default:
233         assert (0);
234       }
235
236   expr_free (expr);
237   retval = CMD_SUCCESS;
238
239  done:
240   if (c != NULL) 
241     {
242       case_destroy (c);
243       free (c); 
244     }
245   dict_destroy (d);
246   return retval;
247 }
248
249 void
250 expr_debug_print_postfix (const struct expression *e) 
251 {
252   size_t i;
253
254   for (i = 0; i < e->op_cnt; i++) 
255     {
256       union operation_data *op = &e->ops[i];
257       if (i > 0)
258         putc (' ', stderr);
259       switch (e->op_types[i]) 
260         {
261         case OP_operation:
262           if (op->operation == OP_return_number)
263             fprintf (stderr, "return_number");
264           else if (op->operation == OP_return_string)
265             fprintf (stderr, "return_string");
266           else if (is_function (op->operation)) 
267             fprintf (stderr, "%s", operations[op->operation].prototype);
268           else if (is_composite (op->operation)) 
269             fprintf (stderr, "%s", operations[op->operation].name);
270           else
271             fprintf (stderr, "%s:", operations[op->operation].name);
272           break;
273         case OP_number:
274           if (op->number != SYSMIS)
275             fprintf (stderr, "n<%g>", op->number);
276           else
277             fprintf (stderr, "n<SYSMIS>");
278           break;
279         case OP_string:
280           fprintf (stderr, "s<%.*s>",
281                    (int) op->string.length,
282                    op->string.string != NULL ? op->string.string : "");
283           break;
284         case OP_format:
285           fprintf (stderr, "f<%s%d.%d>",
286                   formats[op->format->type].name,
287                   op->format->w, op->format->d);
288           break;
289         case OP_variable:
290           fprintf (stderr, "v<%s>", op->variable->name);
291           break;
292         case OP_vector:
293           fprintf (stderr, "vec<%s>", op->vector->name);
294           break;
295         case OP_integer:
296           fprintf (stderr, "i<%d>", op->integer);
297           break;
298         default:
299           abort ();
300         } 
301     }
302   fprintf (stderr, "\n");
303 }