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 main module.
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 | MATC - Last Edited 9. 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: matc.c,v 1.7 2007/06/08 08:12:17 jpr Exp $
70 *
71 * $Log: matc.c,v $
72 * Revision 1.7 2007/06/08 08:12:17 jpr
73 * *** empty log message ***
74 *
75 * Revision 1.6 2006/02/07 10:21:42 jpr
76 * Changed visibility of some variables to local scope.
77 *
78 * Revision 1.5 2006/02/02 06:54:44 jpr
79 * small formatting changes.
80 *
81 * Revision 1.3 2005/08/25 13:44:22 vierinen
82 * windoze stuff
83 *
84 * Revision 1.2 2005/05/27 12:26:20 vierinen
85 * changed header install location
86 *
87 * Revision 1.1.1.1 2005/04/14 13:29:14 vierinen
88 * initial matc automake package
89 *
90 * Revision 1.2 1998/08/01 12:34:48 jpr
91 *
92 * Added Id, started Log.
93 *
94 *
95 */
96
97 #define MODULE_MATC
98 #include "elmer/matc.h"
99 #include "str.h"
100 #include "../config.h"
101
102 #ifdef DEBUG
103 static FILE *fplog;
104 static int tot;
105 #pragma omp threadprivate (fplog, tot)
106 #endif
107 /*======================================================================
108 ? main program, initialize few constants and go for it.
109 ^=====================================================================*/
mtc_init(FILE * input_file,FILE * output_file,FILE * error_file)110 void mtc_init( FILE *input_file, FILE *output_file, FILE *error_file )
111 {
112 VARIABLE *ptr;
113
114 char str[256];
115
116 int i; /* i'm getting tired with all these i's */
117
118 static char *evalHelp =
119 {
120 "eval( str )\n\n"
121 "Evaluate content variable. Another form of this command is @str.\n"
122 };
123
124 static char *sourceHelp =
125 {
126 "source( name )\n\n"
127 "Execute commands from file given name.\n"
128 };
129
130 static char *helpHelp =
131 {
132 "help or help(\"symbol\")\n\n"
133 "First form of the command gives list of available commands.\n"
134 "Second form gives help on specific routine.\n"
135 };
136
137 #ifdef _OPENMP
138 /* Allocate listheaders for each thread separately */
139 #pragma omp parallel
140 {
141 /* Do malloc and initialize listheaders */
142 listheaders = (LIST *) malloc(sizeof(LIST)*MAX_HEADERS);
143 /* memory allocations */
144 listheaders[ALLOCATIONS].next = NULL;
145 listheaders[ALLOCATIONS].name = "Allocations";
146 /* global CONSTANTS */
147 listheaders[CONSTANTS].next = NULL;
148 listheaders[CONSTANTS].name = "Constants";
149 /* global VARIABLES */
150 listheaders[VARIABLES].next = NULL;
151 listheaders[VARIABLES].name = "Currently defined VARIABLES";
152 /* internal commands */
153 listheaders[COMMANDS].next = NULL;
154 listheaders[COMMANDS].name = "Builtin Functions";
155 /* user defined functions */
156 listheaders[FUNCTIONS].next = NULL;
157 listheaders[FUNCTIONS].name = "User Functions";
158 }
159 #endif /* _OPENMP */
160
161 #ifdef DEBUG
162 fplog = fopen("matcdbg","w");
163 #endif
164 ALLOC_HEAD = (LIST *)NULL;
165
166 /*
167 * input & output & error streams
168 */
169 math_in = input_file;
170 math_err = error_file;
171 math_out = output_file;
172
173 mtr_com_init(); /* initialize matrix handling commands */
174 var_com_init(); /* "" VARIABLE "" "" */
175 fnc_com_init(); /* "" function handling commands */
176 fil_com_init(); /* "" file handling commands */
177 gra_com_init(); /* "" graphics commands */
178 str_com_init(); /* "" string handling */
179
180 /*
181 * and few others.
182 */
183 com_init( "eval" , FALSE, FALSE, com_apply, 1, 1, evalHelp );
184 com_init( "source" , FALSE, FALSE, com_source, 1, 1, sourceHelp );
185 com_init( "help" , FALSE, FALSE, com_help , 0, 1, helpHelp );
186 com_init( "quit" , FALSE, FALSE, com_quit , 0, 0, "quit\n" );
187 com_init( "exit" , FALSE, FALSE, com_quit , 0, 0, "exit\n" );
188
189 /*
190 * these constants will always be there for you.
191 */
192 ptr = const_new("true", TYPE_DOUBLE, 1, 1);
193 M(ptr,0,0) = 1.0;
194
195 ptr = const_new("false", TYPE_DOUBLE, 1, 1);
196 M(ptr,0,0) = 0.0;
197
198 ptr = const_new("stdin", TYPE_DOUBLE, 1, 1);
199 M(ptr,0,0) = 0;
200
201 ptr = const_new("stdout", TYPE_DOUBLE, 1, 1);
202 M(ptr,0,0) = 1;
203
204 ptr = const_new("stderr", TYPE_DOUBLE, 1, 1);
205 M(ptr,0,0) = 2;
206
207 ptr = const_new("pi", TYPE_DOUBLE, 1, 1);
208 M(ptr,0,0) = 2*acos(0.0);
209
210 #if 0
211 /*
212 * trap INTERRUPT and Floating Point Exeption signals
213 */
214 signal(SIGFPE, sig_trap);
215
216 sprintf( str, "%s/lib/mc.ini", getenv("ELMER_POST_HOME") );
217
218 if ( (math_in = fopen( str, "r" ) ) != (FILE *)NULL)
219 {
220 doread();
221 fclose( math_in );
222 }
223
224 /*
225 * and finally standard input.
226 */
227 math_in = stdin;
228
229 doread();
230
231 var_free();
232 com_free();
233 fnc_free();
234 const_free();
235
236 mem_free_all();
237
238 #ifdef DEBUG
239 fclose(fplog);
240 #endif
241 #endif
242
243 return; /* done */
244 }
245
mtc_domath(char * str)246 char * mtc_domath( char *str )
247 {
248 VARIABLE *headsave; /* this should not be here */
249
250 jmp_buf jmp, *savejmp; /* save program context */
251
252 void (*sigfunc)() = (void (*)())signal( SIGINT, sig_trap );
253
254 if ( !str || !*str )
255 {
256 str = (char *)doread();
257 signal( SIGINT, sigfunc );
258 return math_out_str;
259 }
260
261 savejmp = jmpbuf;
262 jmpbuf = &jmp;
263
264 #ifdef DEBUG
265 fprintf( stderr, "got [%s]\n", str );
266 #endif
267 if ( math_out_str ) math_out_str[0] = '\0';
268 math_out_count = 0;
269
270 /*
271 * try it
272 */
273 if (*str != '\0')
274 {
275 ALLOC_HEAD = (LIST *)NULL;
276 headsave = (VARIABLE *)VAR_HEAD;
277
278 /*
279 * normal return takes branch 1,
280 * error() takes branch 2,
281 * quit() takes branch 3.
282 */
283 switch (setjmp(*jmpbuf))
284 {
285 case 0:
286 (void)doit( str );
287 longjmp(*jmpbuf, 1);
288 break;
289
290 case 1:
291 break;
292
293 case 2:
294 VAR_HEAD = (LIST *)headsave;
295 break;
296
297 case 3:
298 break;
299 }
300 }
301
302 jmpbuf = savejmp;
303
304 signal( SIGINT, sigfunc );
305
306 return math_out_str;
307 }
308
doread()309 char *doread()
310 /*======================================================================
311 ? doread() is really the main loop of this program. Function reads
312 | it's input as strings and gives them to function doit() for
313 | execution. setjmp() function is used for error recovery.
314 |
315 | Memory allocated during the lifetime of this function is
316 | collected to a list represented by the global VARIABLE
317 | ALLOCLIST *alloc_list. If function error() is called, this
318 | list is used to deallocte memory. Normally (well I certainly
319 | hope so) functions which allocate memory deallocate it themselves.
320 |
321 | Program stays in this function until an end of file -condition
322 | is reached or exit- or quit-commands are given.
323 |
324 @ jmp_buf *jmpbuf, ALLOC_LIST *alloc_list
325 & ALLOCMEM, FREEMEM, setjmp(), longjmp()
326 ~ doit(), quit(), error()
327 ^=====================================================================*/
328 {
329 VARIABLE *headsave; /* this should not be here */
330
331 jmp_buf jmp, *savejmp; /* save program context */
332
333 char *p, *q; /* buffer for input stream */
334
335 savejmp = jmpbuf;
336 jmpbuf = &jmp;
337
338 if ( math_out_str ) math_out_str[0] = '\0';
339 math_out_count = 0;
340
341 p = q = ALLOCMEM(4096);
342 /*
343 * try it
344 */
345 while(dogets(p, PMODE_MAIN))
346 {
347 if (*p != '\0')
348 {
349 ALLOC_HEAD = (LIST *)NULL;
350 headsave = (VARIABLE *)VAR_HEAD;
351
352 /*
353 * normal return takes branch 1,
354 * error() takes branch 2,
355 * quit() takes branch 3.
356 */
357 switch (setjmp(*jmpbuf))
358 {
359 case 0:
360 (void)doit(p);
361 longjmp(*jmpbuf, 1);
362 break;
363
364 case 1:
365 break;
366
367 case 2:
368 VAR_HEAD = (LIST *)headsave;
369 break;
370
371 case 3:
372 goto ret;
373 break;
374 }
375 }
376 }
377
378 ret:
379
380 jmpbuf = savejmp;
381
382 FREEMEM(q);
383
384 return math_out_str;
385 }
386
com_quit()387 VARIABLE *com_quit()
388 /*======================================================================
389 ? Quit current doread entry by longjumping back to it (nasty).
390 & longjmp
391 ~ doread
392 ^=====================================================================*/
393 {
394 longjmp(*jmpbuf, 3);
395
396 return (VARIABLE *)NULL; /* won't be executed (hopefully) */
397 }
398
dogets(buff,prompt)399 int dogets(buff, prompt) char *buff; char *prompt;
400 /*======================================================================
401 ? Get line from input stream. If both input & output streams are
402 | connected to terminal, this function gives user one of three
403 | (default) prompts:
404 |
405 | MATC>
406 | - normal prompt (PMODE_MAIN)
407 | ....>
408 | - begin end- block is beign defined (PMODE_BLOCK)
409 | ####> (PMODE_CONT)
410 | - user has given a #-sign as a last character of
411 | previous line, this line will be catenated with it
412 |
413 | If current comment character is found from input stream, the
414 | line after this character is discarded. Likewise if current
415 | system command character is found, the rest of the line is
416 | passed to system()-call.
417 |
418 = line got -> TRUE, EOF -> FALSE
419 ! There should be a way to get an echo when reading from file.
420 & fprintf(), isatty(), fileno(), strlen(), fgets(), system()
421 ^=====================================================================*/
422 {
423 char *ptr = buff, *p; /* Can't get rid of these. */
424
425 if ( !math_in ) return FALSE;
426
427 /*
428 Try figuring out if input & output streams are
429 terminals, if they both are, give user a prompt.
430 */
431 if (isatty(fileno(math_in)) && isatty(fileno(math_out)))
432 PrintOut( "%s", prompt );
433
434 /*
435 i'm not in the mood to explain this.
436 */
437 *ptr++ = ' ';
438
439 /*
440 Go for it.
441 */
442 while((ptr = fgets(ptr, 256, math_in)) != NULL)
443 {
444
445 ptr[strlen(ptr)-1] = '\0';
446
447 /*
448 * Check if the user wants to continue with this line.
449 */
450 while(ptr[strlen(ptr)-1] == '\\')
451 {
452 ptr += strlen(ptr) - 1;
453 dogets(ptr, PMODE_CONT);
454 }
455
456 /*
457 * if there is only spaces in this line,
458 * don't bother returning it, instead
459 * let's read afresh, otherwise return.
460 */
461 p = ptr; while(isspace(*p)) p++;
462
463 if (*p != '\0') /* GOOD EXIT HERE */
464 {
465 #if 0
466 /*
467 * Look for the system character, if found
468 * pass rest of the line to system()-call
469 */
470 for(p = buff; *p; p++)
471 {
472 switch(*p)
473 {
474 case SYSTEM:
475 system(p + 1);
476 PrintOut("\n");
477 *p = '\0'; p--;
478 break;
479 }
480 }
481 #endif
482 if (*buff != '\0')
483 return TRUE; /* OR IF WE ARE HONEST, IT'S HERE */
484 }
485
486 /*
487 if it's terminal give a prompt.
488 */
489 if (isatty(fileno(math_in)) && isatty(fileno(math_out)))
490 PrintOut("%s", prompt);
491 }
492
493 return FALSE;
494 }
495
496
com_init(word,flag_pw,flag_ce,sub,minp,maxp,help_text)497 void com_init(word, flag_pw, flag_ce, sub, minp, maxp, help_text )
498 /*======================================================================
499 ? Adds commands to global command list.
500 |
501 | Parameters:
502 | char *word
503 | - the keyword user gives for this command to be executed.
504 | int flag_pw
505 | - flag telling if the command can be executed element
506 | by element using function *(*sub)().
507 | int flag_ce
508 | - flag telling if the command can be executed when
509 | preprosessing if constant arguments
510 | double *(*sub)()
511 | - function to be executed when this command is given
512 | int minp, maxp
513 | - maximum and minimum number of parameters to command
514 |
515 | The global list of available commands is updated (or created if
516 | nonexistent).
517 |
518 & lst_add()
519 ~ *_com_init()
520 ^=====================================================================*/
521 char *word;
522 VARIABLE *(*sub)();
523 int minp, maxp, flag_pw, flag_ce;
524 char *help_text;
525 {
526 COMMAND *ptr; /* can't get rid of this */
527
528
529 /*
530 Fill the structure...
531 */
532 ptr = (COMMAND *)ALLOCMEM(COMSIZE);
533 NAME(ptr) = STRCOPY(word);
534 if (flag_pw)
535 ptr->flags |= CMDFLAG_PW;
536 if (flag_ce)
537 ptr->flags |= CMDFLAG_CE;
538 ptr->minp = minp;
539 ptr->maxp = maxp;
540 ptr->sub = sub;
541 ptr->help = help_text;
542
543 /*
544 ...and update the list.
545 */
546 lst_add(COMMANDS, (LIST *)ptr);
547
548 return;
549 }
550
com_free()551 void com_free()
552 /*======================================================================
553 ? Deletes the list of commands and frees associated memory.
554 |
555 & lst_purge()
556 ^=====================================================================*/
557 {
558 /*
559 Give memory back to system
560 */
561 lst_purge(COMMANDS);
562
563 return;
564 }
565
com_check(str)566 COMMAND *com_check(str) char *str;
567 /*======================================================================
568 ? Look for command from COMMANDS list by name.
569 |
570 = COMMAND *NULL if does not exist, pointer to command otherwise
571 & lst_find()
572 ^=====================================================================*/
573 {
574 return (COMMAND *)lst_find(COMMANDS, str);
575 }
576
com_help(VARIABLE * ptr)577 VARIABLE *com_help( VARIABLE *ptr )
578 /*======================================================================
579 ? Print list of commands and user defined functions from global lists.
580 |
581 ! The command to get here is "help" but it really is not very helpful.
582 |
583 & lst_print()
584 ^=====================================================================*/
585 {
586 COMMAND *cmd;
587 FUNCTION *fnc;
588 char *name;
589
590 if ( !ptr )
591 {
592
593 lst_print(COMMANDS);
594 lst_print(FUNCTIONS);
595
596 } else {
597
598 name = var_to_string( ptr );
599
600 if ( (cmd = com_check( name ) ) != (COMMAND *)NULL )
601 {
602
603 if ( cmd->help )
604 PrintOut( "\n%s\n", cmd->help );
605 else
606 PrintOut( "\nSorry: no help available on [%s].\n", name );
607
608 } else if ( (fnc = fnc_check( name ) ) != (FUNCTION *)NULL )
609 {
610
611 if ( fnc->help )
612 PrintOut( "\n%s", fnc->help );
613 else
614 PrintOut( "\nSorry: no help available on [%s].\n", name );
615
616 } else {
617
618 error( "help: symbol not found: [%s]\n", name );
619
620 }
621
622 FREEMEM( name );
623 }
624
625 return (VARIABLE *)NULL;
626 }
627
628 VARIABLE *com_pointw(sub, ptr) double (*sub)(); VARIABLE *ptr;
629 /*======================================================================
630 ? This routine does a function call (*sub)(), for each element in
631 | matrix given by ptr.
632 |
633 = a temporay VARIABLE for which M(res, i, j) = (*sub)(M(ptr, i, j)
634 & var_temp_new(), *(sub)()
635 ^=====================================================================*/
636 {
637 VARIABLE *res,*ptr2; /* pointer to result structure */
638
639 double *a, *a2, *a3, *b; /* pointer to matrices */
640 int n, m, sz; /* matrix dimensions */
641
642 int i; /* loop index */
643
644 /*
645 Get space for result and ...
646 */
647 n = NROW(ptr); m = NCOL(ptr);
648 res = var_temp_new(TYPE(ptr) ,n , m);
649
650 sz = n*m;
651 a = MATR(ptr); b = MATR(res);
652
653 /*
654 ...to action.
655 */
656 ptr2 = NEXT(ptr);
657 if(ptr2)
658 {
659 if(n!=NROW(ptr2)||m!=NCOL(ptr2))
660 {
661 error("Pointwise function arguments must all be of same size.");
662 }
663 a2 = MATR(ptr2);
664
665 ptr2 = NEXT(ptr2);
666 if(ptr2)
667 {
668 if(n!=NROW(ptr2)||m!=NCOL(ptr2))
669 {
670 error("Pointwise function arguments must all be of same size,");
671 }
672 if(NEXT(ptr2))
673 {
674 error("Currently at most three arguments for pointwise functions allowd,sorry.");
675 }
676 a3 = MATR(ptr2);
677 for(i = 0; i < sz; i++) *b++ = (*sub)(*a++,*a2++,*a3++);
678 }
679 else
680 {
681 for(i = 0; i < sz; i++) *b++ = (*sub)(*a++,*a2++);
682 }
683 }
684 else
685 {
686 for(i = 0; i < sz; i++) *b++ = (*sub)(*a++);
687 }
688
689 return res;
690 }
691
com_el(ptr)692 VARIABLE *com_el(ptr) VARIABLE *ptr;
693 /*======================================================================
694 ? Extracts specified elements from a matrix. Indexes are given by two
695 | column vectors. The values of the elements of these vectors give
696 | the required indexes. If there is only one index vector given
697 | it is assumed to be column index and row index is set to scalar 0.
698 |
699 | If matrix x is, for example,
700 |
701 | 1 2
702 | 3 4
703 |
704 | you get the first row by
705 |
706 | x[0, 0 1]
707 |
708 | or by
709 |
710 | x(0 1)
711 |
712 = A new temporary VARIABLE, whose size equals to
713 | number of row indexes times number of column indexes.
714 |
715 & var_temp_new(), var_delete_temp()
716 ^=====================================================================*/
717 {
718 VARIABLE *res, /* result ... */
719 *par = NEXT(ptr); /* pointer to list of VARIABLES */
720 /* containig indexes */
721
722 static double defind = 0.0;
723 #pragma omp threadprivate (defind)
724 double *ind1 = &defind, *ind2;
725
726 int i, j, k, /* loop indexes */
727 rows, cols, /* no. of rows and columns in the matrix */
728 /* to be indexed. */
729 size1 = 1, size2,
730 ind;
731
732 rows = NROW(ptr); cols = NCOL(ptr);
733
734 /*
735 * check if scalar ....
736 */
737 if (rows == 1 && cols == 1)
738 {
739 if (*MATR(par) != 0) error("Index out of bounds.\n");
740 if (NEXT(par) != NULL)
741 if (*MATR(NEXT(par)) != 0) error("Index out of bounds.\n");
742 res = var_temp_new(TYPE(ptr),1,1);
743 *MATR(res) = *MATR(ptr);
744 return res;
745 }
746
747 /*
748 The matrix will be indexed by two column vectors.
749 If there is just one assume it's column index and
750 make rowindex 0.
751 */
752 if (NEXT(par) == NULL)
753 {
754 if (NROW(par) == rows && NCOL(par) == cols)
755 {
756 int logical = TRUE,
757 onecount=0;
758
759 double *dtmp;
760
761 dtmp = MATR(par);
762 for(i = 0; i < NROW(par)*NCOL(par); i++)
763 if (dtmp[i] == 0)
764 {
765 }
766 else if (dtmp[i] == 1)
767 {
768 onecount++;
769 }
770 else
771 {
772 logical = FALSE;
773 break;
774 }
775
776 if (logical)
777 {
778 if (onecount == 0) return NULL;
779
780 res = var_temp_new(TYPE(ptr),1,onecount);
781 for(i=0,k=0; i < rows; i++)
782 for(j=0; j < cols; j++)
783 if (M(par,i,j) == 1)
784 {
785 memcpy(&M(res,0,k++),&M(ptr,i,j),sizeof(double));
786 }
787 return res;
788 }
789 }
790
791 ind2 = MATR(par); size2 = NCOL(par);
792 cols *= rows; rows = 1;
793 }
794 else
795 {
796 ind1 = MATR(par); size1 = NCOL(par);
797 size2 = NCOL(NEXT(par));
798 ind2 = MATR(NEXT(par));
799 }
800
801 /*
802 Space for result
803 */
804 res = var_temp_new(TYPE(ptr), size1, size2);
805
806 /*
807 Extract the values (try making sense out of that
808 if you feel like it).
809 */
810 for(i = 0; i < size1; i++)
811 {
812 ind = (int)ind1[i];
813 for(j = 0; j < size2; j++)
814 if (ind < rows && (int)ind2[j] < cols)
815 memcpy(&M(res,i,j),&M(ptr,ind,(int)ind2[j]),sizeof(double));
816 else
817 error("Index out of bounds.\n");
818 }
819
820 return res;
821 }
822
com_source(ptr)823 VARIABLE *com_source(ptr) VARIABLE *ptr;
824 /*======================================================================
825 ? Redirect input stream to a file, whose name is given.
826 |
827 @ FILE *math_in
828 & ALLOCMEM, FREEMEM, fopen(), fclose(), error()
829 ^=====================================================================*/
830 {
831 char *name; /* Hold converted string (file name) */
832
833 FILE *save_in = math_in; /* Save previous input stream until */
834 /* we are done with the new file. */
835
836 /*
837 convert the file name from ptr.
838 */
839 name = var_to_string(ptr);
840
841 /*
842 Execute the file.
843 */
844 if ((math_in = fopen(name,"r")) != NULL)
845 {
846 /* PrintOut("Executing commands from file, %s...\n", name); */
847 doread();
848 fclose(math_in);
849 }
850 else
851 {
852 PrintOut( "Source: Can't open file, %s.\n",name );
853 }
854
855 math_in = save_in;
856 FREEMEM(name);
857
858 return (VARIABLE *)NULL;
859 }
860
861
com_apply(ptr)862 VARIABLE *com_apply(ptr) VARIABLE *ptr;
863 /*======================================================================
864 ? Executes given string.
865 |
866 & ALLOCMEM, FREEMEM, doit()
867 ^=====================================================================*/
868 {
869 VARIABLE *res; /* result pointer */
870
871 char *p, *q; /* holds the string to be executed, after */
872 /* conversion from structure VARIABLE * */
873
874 int i, j; /* just loop indexes */
875
876
877 /*
878 Allocate space for the string...
879 */
880 p = q = ALLOCMEM(NROW(ptr) * NCOL(ptr) + 1);
881
882 /*
883 ... convert it ...
884 */
885 for(i = 0; i < NROW(ptr); i++)
886 for(j = 0; j < NCOL(ptr); j++)
887 *p++ = (char)M(ptr,i,j);
888
889 *p = '\0';
890
891 /*
892 ... and try executing it.
893 */
894 res = doit( q );
895
896 FREEMEM(q);
897
898 return res;
899 }
900
mem_free(void * mem)901 void mem_free(void *mem)
902 /*======================================================================
903 ? Free memory given by argument, and unlink it from alloction list.
904 | Currently FREEMEM(ptr) is defined to be mem_free(ptr).
905 |
906 & free()
907 ~ mem_alloc(), mem_free_all()
908 ^=====================================================================*/
909 {
910 ALLOC_LIST *lst;
911
912 #ifdef DEBUG
913 tot--; fprintf(fplog,"free addr: %d total: %d\n", ALLOC_LST(mem), tot);
914 fflush( fplog );
915 #endif
916 /*
917 if the list is empty return
918 */
919 if ( (lst = (ALLOC_LIST *)ALLOC_HEAD) == (ALLOC_LIST *)NULL )
920 {
921 #if 1
922 /* ????? */
923 free( ALLOC_LST(mem) );
924 #else
925 fprintf( stderr, "SHOULD THIS HAPPEN ????\n" );
926 #endif
927 return;
928 }
929
930 /*
931 * it's not the header, look if it's in list at all
932 */
933 if (ALLOC_PTR(lst) != mem)
934 {
935
936 for(; NEXT(lst); lst = NEXT(lst))
937 {
938 if (ALLOC_PTR(NEXT(lst)) == mem) break;
939 }
940
941 /*
942 * item was not found from the list. free ptr and return.
943 */
944 if (NEXT(lst) == (ALLOC_LIST *)NULL)
945 {
946 free(ALLOC_LST(mem));
947 return;
948 }
949
950 /*
951 * unlink
952 */
953 NEXT(lst) = NEXT(NEXT(lst));
954 }
955
956 /*
957 * item was the header, unlink it
958 */
959 else
960 ALLOC_HEAD = NEXT(ALLOC_HEAD);
961
962 /*
963 * and at last return memory back to system
964 */
965 free(ALLOC_LST(mem));
966
967 return;
968 }
969
mem_free_all()970 void mem_free_all()
971 /*======================================================================
972 ? Free all memory allocated since last entry of doread.
973 | (actually free all memory from list ALLOCATIONS).
974 |
975 ~ mem_alloc(), mem_free(), doread(), error()
976 ^=====================================================================*/
977 {
978 ALLOC_LIST *lst, *lstn;
979
980 for(lst = (ALLOC_LIST *)ALLOC_HEAD; lst;)
981 {
982 #ifdef DEBUG
983 tot--; fprintf(fplog,"freeall addr: %d total: %d\n", lst, tot);
984 fflush( fplog );
985 #endif
986 lstn = NEXT(lst);
987 free( (char *)lst );
988 lst = lstn;
989 }
990
991 ALLOC_HEAD = (LIST *)NULL; /* security */
992
993 return;
994 }
995
mem_alloc(size)996 void *mem_alloc(size) size_t size;
997 /*======================================================================
998 ? Allocate memory and link it to memory allocation list.
999 |
1000 ~ calloc(), free(), error()
1001 ^=====================================================================*/
1002 {
1003 ALLOC_LIST *lst;
1004
1005 /*
1006 * try allocating memory
1007 */
1008 if ((lst = (ALLOC_LIST *)calloc(size+sizeof(ALLOC_LIST), 1)) != NULL)
1009 {
1010 NEXT(lst) = (ALLOC_LIST *)ALLOC_HEAD; ALLOC_HEAD = (LIST *)lst;
1011 }
1012 else
1013 error("Can't alloc mem.\n");
1014
1015 #ifdef DEBUG
1016 tot++; fprintf(fplog,"alloc addr: %d size: %d total: %d\n",
1017 lst, size, tot);
1018 fflush( fplog );
1019 #endif
1020 return ALLOC_PTR(lst);
1021 }
1022