1 /*****************************************************************************
2 *
3 * Elmer, A Finite Element Software for Multiphysical Problems
4 *
5 * Copyright 1st April 1995 - , CSC - IT Center for Science Ltd., Finland
6 *
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public
9 * License as published by the Free Software Foundation; either
10 * version 2.1 of the License, or (at your option) any later version.
11 *
12 * This library is distributed in the hope that it will be useful,
13 * but WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
16 *
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library (in file ../LGPL-2.1); if not, write
19 * to the Free Software Foundation, Inc., 51 Franklin Street,
20 * Fifth Floor, Boston, MA 02110-1301 USA
21 *
22 *****************************************************************************/
23
24 /*******************************************************************************
25 *
26 * MATC user function utilities.
27 *
28 *******************************************************************************
29 *
30 * Author: Juha Ruokolainen
31 *
32 * Address: CSC - IT Center for Science Ltd.
33 * Keilaranta 14, P.O. BOX 405
34 * 02101 Espoo, Finland
35 * Tel. +358 0 457 2723
36 * Telefax: +358 0 457 2302
37 * EMail: Juha.Ruokolainen@csc.fi
38 *
39 * Date: 30 May 1996
40 *
41 * Modified by:
42 *
43 * Date of modification:
44 *
45 ******************************************************************************/
46 /***********************************************************************
47 |
48 | FUNCS.C - Last Edited 7. 8. 1988
49 |
50 ***********************************************************************/
51
52 /*======================================================================
53 |Syntax of the manual pages:
54 |
55 |FUNCTION NAME(...) params ...
56 |
57 $ usage of the function and type of the parameters
58 ? explane the effects of the function
59 = return value and the type of value if not of type int
60 @ globals effected directly by this routine
61 ! current known bugs or limitations
62 & functions called by this function
63 ~ these functions may interest you as an alternative function or
64 | because they control this function somehow
65 ^=====================================================================*/
66
67
68 /*
69 * $Id: funcs.c,v 1.2 2005/05/27 12:26:20 vierinen Exp $
70 *
71 * $Log: funcs.c,v $
72 * Revision 1.2 2005/05/27 12:26:20 vierinen
73 * changed header install location
74 *
75 * Revision 1.1.1.1 2005/04/14 13:29:14 vierinen
76 * initial matc automake package
77 *
78 * Revision 1.3 2003/05/06 09:14:49 jpr
79 * *** empty log message ***
80 *
81 * Revision 1.2 1998/08/01 12:34:39 jpr
82 *
83 * Added Id, started Log.
84 *
85 *
86 */
87
88 #include "elmer/matc.h"
89
fnc_check(name)90 FUNCTION *fnc_check(name) char *name;
91 /*======================================================================
92 ? Look for specified user defined function from the FUNCTIONS list
93 |
94 = NULL if not found, otherwise FUNCTION *fnc
95 & lst_find()
96 ^=====================================================================*/
97 {
98 return (FUNCTION *)lst_find(FUNCTIONS, name);
99 }
100
fnc_delete(ptr)101 VARIABLE *fnc_delete(ptr) VARIABLE *ptr;
102 /*======================================================================
103 ? Unlink given function definition from list FUNCTION *FUNC_HEAD,
104 | and free associated memory.
105 |
106 | user command fdel("name")
107 |
108 @ FUNC_HEAD
109 & FREEMEM, var_to_string(), fprintf(), fnc_free_entry(), fnc_check()
110 ^=====================================================================*/
111 {
112 FUNCTION *fnc; /* all these exist just because */
113 char *s; /* i can't get this done without them */
114
115 /*
116 convert string from ptr
117 */
118 s = var_to_string(ptr);
119
120 /*
121 function exists. Unlink from list, and free memory.
122 */
123 if ((fnc = fnc_check(s)) != (FUNCTION *)NULL) {
124
125 fnc_free_entry(fnc);
126
127 }
128
129 /*
130 we did not found the function.
131 */
132 else {
133 error("Function definition not found: %s.\n", s);
134 }
135
136 FREEMEM(s);
137
138 return (VARIABLE *)NULL;
139 }
140
fnc_list(ptr)141 VARIABLE *fnc_list(ptr) VARIABLE *ptr;
142 /*======================================================================
143 ? Print given function definition from list FUNCTION *FUNC_HEAD,
144 |
145 | user command flist("name")
146 |
147 & FREEMEM, var_to_string(), printclause(), fnc_check()
148 ^=====================================================================*/
149 {
150 FUNCTION *fnc; /* all these exist just because */
151 char *s, *file; /* i can't get this done without */
152 int i; /* them. */
153
154 FILE *fp = math_out;
155
156 /*
157 convert string from ptr
158 */
159 s = var_to_string(ptr);
160
161 /*
162 function exists. try listing the definition
163 */
164 if ((fnc = fnc_check(s)) != (FUNCTION *)NULL) {
165
166 /*
167 If file name given try opening it.
168 */
169 if (NEXT(ptr) != (VARIABLE *)NULL) {
170 file = var_to_string(NEXT(ptr));
171 if ((fp = fopen(file, "a")) == (FILE *)NULL) {
172 error( "flist: can't open file: %s.",file );
173 }
174 FREEMEM(file);
175 }
176
177 /*
178 * print function header.
179 */
180 PrintOut( "function %s", NAME(fnc) );
181 if ( fnc->parcount != 0 )
182 {
183 PrintOut( "(%s", fnc->parnames[0] );
184 for( i = 1; i < fnc -> parcount; i++ )
185 PrintOut( ",%s", fnc -> parnames[i] );
186 PrintOut( ")" );
187 }
188 PrintOut( "\n" );
189
190 /*
191 and then the body
192 */
193 /*
194 printclause(fnc->body, fp, 1); PrintOut( "end\n" );
195 */
196 if ( fp != math_out ) fclose(fp);
197 }
198
199 /*
200 we did not found the function.
201 */
202 else {
203 error( "Function definition not found: %s\n", s );
204 }
205
206 FREEMEM(s);
207
208 return (VARIABLE *)NULL;
209 }
210
211
fnc_free_entry(fnc)212 void fnc_free_entry(fnc) FUNCTION *fnc;
213 /*======================================================================
214 ? Free allocated memory from FUNCTION structure.
215 |
216 & FREEMEM, free_clause(), lst_free()
217 ^=====================================================================*/
218 {
219 int i;
220
221 free_clause(fnc->body); /* function body */
222 if (fnc -> parcount > 0) {
223 for(i = 0; i < fnc -> parcount; i++) {
224 FREEMEM(fnc -> parnames[i]); /* parameter names, if any */
225 }
226 FREEMEM((char *)fnc -> parnames); /* parameter name array */
227 }
228
229 if (fnc -> imports) {
230 for(i = 0; fnc->imports[i] != NULL; i++) {
231 FREEMEM(fnc -> imports[i]); /* imported variable names, if any */
232 }
233 FREEMEM((char *)fnc -> imports); /* name array */
234 }
235
236 if (fnc -> exports) {
237 for(i = 0; fnc->exports[i] != NULL; i++) {
238 FREEMEM(fnc -> exports[i]); /* exported variable names, if any */
239 }
240 FREEMEM((char *)fnc -> exports); /* name array */
241 }
242
243 lst_free(FUNCTIONS, (LIST *)fnc);
244 }
245
fnc_free()246 void fnc_free()
247 /*======================================================================
248 ? Deallocate memory reserved for user defined functions
249 | and unlink the list FUNCTION *FUNC_HEAD.
250 |
251 @ FUNCTION *FUNC_HEAD
252 & free_clause(), FREEMEM
253 ^=====================================================================*/
254 {
255 FUNCTION *fnc, *fnc1;
256
257 for(fnc = (FUNCTION *)FUNC_HEAD; fnc;)
258 {
259 fnc1 = NEXT(fnc);
260 fnc_free_entry(fnc); /* just plain and cold */
261 fnc = fnc1;
262 }
263
264 FUNC_HEAD = (LIST *)NULL; /* security */
265 }
266
fnc_exec(fnc,par)267 VARIABLE *fnc_exec(fnc, par) FUNCTION *fnc; VARIABLE *par;
268 /*======================================================================
269 ? Execute function from parameter FUNCTION *fnc, with it's
270 | parameters in VARIABLE VARIABLE *par;
271 |
272 = Return value is the executed function's value, which is
273 | given in VARIABLE _function_name, or if nonexeistent,
274 | the return value of the last executed statement in
275 | function body.
276 |
277 @ VAR_HEAD
278 & ALLOCMEM, FREEMEM, STRCOPY, strcpy(), fprintf(),
279 | lst_unlink, var_free(), evalclause()
280 ^=====================================================================*/
281 {
282 VARIABLE *ptr, *imp, *res, *headsave, *var;
283 char *str;
284 int i;
285
286 /*
287 we make new global VARIABLE list for this function,
288 have to save the old one.
289 */
290 headsave = (VARIABLE *)VAR_HEAD;
291
292 /*
293 * rename parameter from function header
294 */
295 for(i = 0, ptr = par; ptr; ptr = NEXT(ptr), i++)
296 {
297 if (ptr == NULL) break;
298 if (i < fnc->parcount)
299 NAME(ptr) = STRCOPY(fnc -> parnames[i]);
300 else
301 NAME(ptr) = ALLOCMEM(1);
302 }
303
304 /*
305 * check for imported variables
306 */
307 if (fnc->imports != NULL)
308 for(i = 0; fnc->imports[i] != NULL; i++)
309 if ((ptr = var_check(fnc->imports[i])) != NULL)
310 {
311 VAR_HEAD = (LIST *)par;
312 if (var_check(fnc->imports[i]) == NULL)
313 {
314 ptr = var_temp_copy(ptr);
315 NAME(ptr) = STRCOPY(fnc->imports[i]);
316 lst_add(VARIABLES, (LIST *)ptr);
317 }
318 par = (VARIABLE *)VAR_HEAD;
319 VAR_HEAD = (LIST *)headsave;
320 }
321 else
322 PrintOut( "WARNING: %s: imported variable [%s] doesn't exist\n",
323 NAME(fnc), fnc->imports[i]);
324
325
326 /*
327 parameters to functions own list of VARIABLES.
328 */
329 VAR_HEAD = (LIST *)par;
330
331 /*
332 initializations done, execute the function body.
333 */
334 res = evalclause(fnc->body);
335
336 par = (VARIABLE *)VAR_HEAD;
337 /*
338 * check for exported variables
339 */
340 if (fnc->exports != NULL)
341 for(i = 0; fnc->exports[i] != NULL; i++)
342 if ((ptr = var_check(fnc->exports[i])) != NULL)
343 {
344 VAR_HEAD = (LIST *)headsave;
345 #if 0
346 ptr = var_temp_copy(ptr);
347 NAME(ptr) = STRCOPY( fnc->exports[i] );
348 #else
349 var = (VARIABLE *)ALLOCMEM(VARIABLESIZE);
350 var->this = ptr->this;
351 REFCNT(ptr)++;
352 NAME(var) = STRCOPY( fnc->exports[i] );
353 #endif
354 var_delete( fnc->exports[i] );
355 lst_add( VARIABLES, (LIST *)var );
356 headsave = (VARIABLE *)VAR_HEAD;
357
358 VAR_HEAD = (LIST *)par;
359 }
360
361 /*
362 check for explicit return value from
363 VARIABLE named "_function_name"
364 */
365 str = ALLOCMEM(strlen(NAME(fnc)) + 2);
366 str[0] = '_'; strcat(str, NAME(fnc));
367
368 if ((res = var_check(str)) != NULL)
369 {
370 lst_unlink(VARIABLES, (LIST *)res);
371 FREEMEM(NAME(res));
372 NEXT(res) = NULL;
373 }
374 else {
375 var_delete_temp(res);
376 res = NULL;
377 }
378
379 FREEMEM(str);
380
381 /*
382 rebuild the environment and return
383 */
384 var_free();
385 VAR_HEAD = (LIST *)headsave;
386
387 return res;
388 }
389
390
fnc_com_init()391 void fnc_com_init()
392 /*======================================================================
393 ? Initialize function handling commands.
394 |
395 & com_init()
396 ~ com_init()
397 ^=====================================================================*/
398 {
399 com_init(
400 "funcdel", FALSE, FALSE, fnc_delete, 1, 1,
401 "funcdel(name)\nDelete function definition from parser.\n"
402 );
403
404 com_init(
405 "funclist", FALSE, FALSE, fnc_list, 1, 2,
406 "funclist(name)\nGive header of a given function.\n\nSEE ALSO: help.\n"
407 );
408 }
409