1 /*
2 Copyright (C) 2002 M. Marques, A. Castro, A. Rubio, G. Bertsch, D. Strubbe
3
4 This program is free software; you can redistribute it and/or modify
5 it under the terms of the GNU General Public License as published by
6 the Free Software Foundation; either version 2, or (at your option)
7 any later version.
8
9 This program is distributed in the hope that it will be useful,
10 but WITHOUT ANY WARRANTY; without even the implied warranty of
11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 GNU General Public License for more details.
13
14 You should have received a copy of the GNU General Public License
15 along with this program; if not, write to the Free Software
16 Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
17 02110-1301, USA.
18
19 */
20
21 #include <stdio.h>
22 #include <stdlib.h>
23 #include <string.h>
24 #include <strings.h>
25 #include <ctype.h>
26 #include <math.h>
27 #include <gsl/gsl_complex_math.h>
28
29 #include "symbols.h"
30 #include "gsl_userdef.h"
31
32 /* The symbol table: a chain of `struct symrec'. */
33 symrec *sym_table = (symrec *)0;
34
str_tolower(char * in)35 void str_tolower(char *in)
36 {
37 for(; *in; in++)
38 *in = (char)tolower(*in);
39 }
40
sym_mark_table_used()41 void sym_mark_table_used ()
42 {
43 symrec *ptr;
44
45 for (ptr = sym_table; ptr != (symrec *) 0;
46 ptr = (symrec *)ptr->next)
47 {
48 ptr->used = 1;
49 }
50 }
51
putsym(const char * sym_name,symrec_type sym_type)52 symrec *putsym (const char *sym_name, symrec_type sym_type)
53 {
54 symrec *ptr;
55 ptr = (symrec *)malloc(sizeof(symrec));
56
57 /* names are always lowercase */
58 ptr->name = strdup(sym_name);
59 str_tolower(ptr->name);
60
61 ptr->def = 0;
62 ptr->used = 0;
63 ptr->type = sym_type;
64 GSL_SET_COMPLEX(&ptr->value.c, 0, 0); /* set value to 0 even if fctn. */
65 ptr->next = (struct symrec *)sym_table;
66 sym_table = ptr;
67 return ptr;
68 }
69
getsym(const char * sym_name)70 symrec *getsym (const char *sym_name)
71 {
72 symrec *ptr;
73 for (ptr = sym_table; ptr != (symrec *) 0;
74 ptr = (symrec *)ptr->next)
75 if (strcasecmp(ptr->name,sym_name) == 0){
76 ptr->used = 1;
77 return ptr;
78 }
79 return (symrec *) 0;
80 }
81
rmsym(const char * sym_name)82 int rmsym (const char *sym_name)
83 {
84 symrec *ptr, *prev;
85 for (prev = (symrec *) 0, ptr = sym_table; ptr != (symrec *) 0;
86 prev = ptr, ptr = ptr->next)
87 if (strcasecmp(ptr->name,sym_name) == 0){
88 if(prev == (symrec *) 0)
89 sym_table = ptr->next;
90 else
91 prev->next = ptr->next;
92 free(ptr->name);
93 free(ptr);
94
95 return 1;
96 }
97
98 return 0;
99 }
100
101 struct init_fntc{
102 char *fname;
103 int nargs;
104 gsl_complex (*fnctptr)();
105 };
106
sym_notdef(symrec * sym)107 void sym_notdef (symrec *sym)
108 {
109 fprintf(stderr, "Parser error: symbol '%s' used before being defined.\n", sym->name);
110 exit(1);
111 }
112
sym_redef(symrec * sym)113 void sym_redef (symrec *sym)
114 {
115 fprintf(stderr, "Parser warning: redefining symbol, previous value ");
116 sym_print(stderr, sym);
117 fprintf(stderr, "\n");
118 }
119
sym_wrong_arg(symrec * sym)120 void sym_wrong_arg (symrec *sym)
121 {
122 if(sym->type == S_BLOCK) {
123 fprintf(stderr, "Parser error: block name '%s' used in variable context.\n", sym->name);
124 } else if(sym->type == S_STR) {
125 fprintf(stderr, "Parser error: string variable '%s' used in expression context.\n", sym->name);
126 } else {
127 fprintf(stderr, "Parser error: function '%s' requires %d argument(s).\n", sym->name, sym->nargs);
128 }
129 exit(1);
130 }
131
132 static struct init_fntc arith_fncts[] = {
133 {"sqrt", 1, (gsl_complex (*)()) &gsl_complex_sqrt},
134 {"exp", 1, (gsl_complex (*)()) &gsl_complex_exp},
135 {"ln", 1, (gsl_complex (*)()) &gsl_complex_log},
136 {"log", 1, (gsl_complex (*)()) &gsl_complex_log},
137 {"log10", 1, (gsl_complex (*)()) &gsl_complex_log10},
138 {"logb", 2, (gsl_complex (*)()) &gsl_complex_log_b}, /* takes two arguments logb(z, b) = log_b(z) */
139
140 {"arg", 1, (gsl_complex (*)()) &gsl_complex_carg},
141 {"abs", 1, (gsl_complex (*)()) &gsl_complex_cabs},
142 {"abs2", 1, (gsl_complex (*)()) &gsl_complex_cabs2},
143 {"logabs", 1, (gsl_complex (*)()) &gsl_complex_clogabs},
144
145 {"conjg", 1, (gsl_complex (*)()) &gsl_complex_conjugate},
146 {"inv", 1, (gsl_complex (*)()) &gsl_complex_inverse},
147
148 {"sin", 1, (gsl_complex (*)()) &gsl_complex_sin},
149 {"cos", 1, (gsl_complex (*)()) &gsl_complex_cos},
150 {"tan", 1, (gsl_complex (*)()) &gsl_complex_tan},
151 {"sec", 1, (gsl_complex (*)()) &gsl_complex_sec},
152 {"csc", 1, (gsl_complex (*)()) &gsl_complex_csc},
153 {"cot", 1, (gsl_complex (*)()) &gsl_complex_cot},
154
155 {"asin", 1, (gsl_complex (*)()) &gsl_complex_arcsin},
156 {"acos", 1, (gsl_complex (*)()) &gsl_complex_arccos},
157 {"atan", 1, (gsl_complex (*)()) &gsl_complex_arctan},
158 {"atan2", 2, (gsl_complex (*)()) &gsl_complex_arctan2}, /* takes two arguments atan2(y,x) = atan(y/x) */
159 {"asec", 1, (gsl_complex (*)()) &gsl_complex_arcsec},
160 {"acsc", 1, (gsl_complex (*)()) &gsl_complex_arccsc},
161 {"acot", 1, (gsl_complex (*)()) &gsl_complex_arccot},
162
163 {"sinh", 1, (gsl_complex (*)()) &gsl_complex_sinh},
164 {"cosh", 1, (gsl_complex (*)()) &gsl_complex_cosh},
165 {"tanh", 1, (gsl_complex (*)()) &gsl_complex_tanh},
166 {"sech", 1, (gsl_complex (*)()) &gsl_complex_sech},
167 {"csch", 1, (gsl_complex (*)()) &gsl_complex_csch},
168 {"coth", 1, (gsl_complex (*)()) &gsl_complex_coth},
169
170 {"asinh", 1, (gsl_complex (*)()) &gsl_complex_arcsinh},
171 {"acosh", 1, (gsl_complex (*)()) &gsl_complex_arccosh},
172 {"atanh", 1, (gsl_complex (*)()) &gsl_complex_arctanh},
173 {"asech", 1, (gsl_complex (*)()) &gsl_complex_arcsech},
174 {"acsch", 1, (gsl_complex (*)()) &gsl_complex_arccsch},
175 {"acoth", 1, (gsl_complex (*)()) &gsl_complex_arccoth},
176
177 /* user-defined step function. this is not available in GSL,
178 but we use GSL namespacing and macros here. */
179 {"step", 1, (gsl_complex (*)()) &gsl_complex_step_real},
180
181 /* Minimum and maximum of two arguments (comparing real parts) */
182 {"min", 2, (gsl_complex (*)()) &gsl_complex_min_real},
183 {"max", 2, (gsl_complex (*)()) &gsl_complex_max_real},
184
185 {"erf", 1, (gsl_complex (*)()) &gsl_complex_erf},
186
187 {"realpart", 1, (gsl_complex (*)()) &gsl_complex_realpart},
188 {"imagpart", 1, (gsl_complex (*)()) &gsl_complex_imagpart},
189 {"round", 1, (gsl_complex (*)()) &gsl_complex_round},
190 {"floor", 1, (gsl_complex (*)()) &gsl_complex_floor},
191 {"ceiling", 1, (gsl_complex (*)()) &gsl_complex_ceiling},
192
193 {"rand", 0, (gsl_complex (*)()) &gsl_complex_rand},
194
195 {0, 0, 0}
196 };
197
198 struct init_cnst{
199 char *fname;
200 double re;
201 double im;
202 };
203
204 static struct init_cnst arith_cnts[] = {
205 {"pi", M_PI, 0},
206 {"e", M_E, 0},
207 {"i", 0, 1},
208 {"true", 1, 0},
209 {"yes", 1, 0},
210 {"false", 0, 0},
211 {"no", 0, 0},
212 {0, 0, 0}
213 };
214
215 char *reserved_symbols[] = {
216 "x", "y", "z", "r", "w", "t", 0
217 };
218
sym_init_table()219 void sym_init_table () /* puts arithmetic functions in table. */
220 {
221 int i;
222 symrec *ptr;
223 for (i = 0; arith_fncts[i].fname != 0; i++){
224 ptr = putsym (arith_fncts[i].fname, S_FNCT);
225 ptr->def = 1;
226 ptr->used = 1;
227 ptr->nargs = arith_fncts[i].nargs;
228 ptr->value.fnctptr = arith_fncts[i].fnctptr;
229 }
230
231 /* now the constants */
232 for (i = 0; arith_cnts[i].fname != 0; i++){
233 ptr = putsym(arith_cnts[i].fname, S_CMPLX);
234 ptr->def = 1;
235 ptr->used = 1;
236 GSL_SET_COMPLEX(&ptr->value.c, arith_cnts[i].re, arith_cnts[i].im);
237 }
238 }
239
sym_end_table()240 void sym_end_table()
241 {
242 symrec *ptr, *ptr2;
243
244 for (ptr = sym_table; ptr != NULL;){
245 free(ptr->name);
246 switch(ptr->type){
247 case S_STR:
248 free(ptr->value.str);
249 break;
250 case S_BLOCK:
251 if(ptr->value.block->n > 0){
252 free(ptr->value.block->lines);
253 }
254 free(ptr->value.block);
255 break;
256 case S_CMPLX:
257 case S_FNCT:
258 break;
259 }
260 ptr2 = ptr->next;
261 free(ptr);
262 ptr = ptr2;
263 }
264
265 sym_table = NULL;
266 }
267
268 /* this function is defined in src/basic/varinfo_low.c */
269 int varinfo_variable_exists(const char * var_name);
270
sym_output_table(int only_unused,int mpiv_node)271 void sym_output_table(int only_unused, int mpiv_node)
272 {
273 FILE *f;
274 symrec *ptr;
275 int any_unused = 0;
276
277 if(mpiv_node != 0) {
278 return;
279 }
280
281 if(only_unused) {
282 f = stderr;
283 } else {
284 f = stdout;
285 }
286
287 for(ptr = sym_table; ptr != NULL; ptr = ptr->next){
288 if(only_unused && ptr->used == 1) continue;
289 if(only_unused && varinfo_variable_exists(ptr->name)) continue;
290 if(any_unused == 0) {
291 fprintf(f, "\nParser warning: possible mistakes in input file.\n");
292 fprintf(f, "List of variable assignments not used by parser:\n");
293 any_unused = 1;
294 }
295
296 sym_print(f, ptr);
297 }
298 if(any_unused == 1) {
299 fprintf(f, "\n");
300 }
301 }
302
sym_print(FILE * f,const symrec * ptr)303 void sym_print(FILE *f, const symrec *ptr)
304 {
305 fprintf(f, "%s", ptr->name);
306 switch(ptr->type){
307 case S_CMPLX:
308 if(fabs(GSL_IMAG(ptr->value.c)) < 1.0e-14){
309 fprintf(f, " = %f\n", GSL_REAL(ptr->value.c));
310 } else {
311 fprintf(f, " = (%f,%f)\n", GSL_REAL(ptr->value.c), GSL_IMAG(ptr->value.c));
312 }
313 break;
314 case S_STR:
315 fprintf(f, " = \"%s\"\n", ptr->value.str);
316 break;
317 case S_BLOCK:
318 fprintf(f, "%s\n", " <= BLOCK");
319 break;
320 case S_FNCT:
321 fprintf(f, "%s\n", " <= FUNCTION");
322 break;
323 }
324 }
325