/[ascend]/trunk/base/generic/compiler/packages.c
ViewVC logotype

Contents of /trunk/base/generic/compiler/packages.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 101 - (show annotations) (download) (as text)
Sat Dec 10 04:22:07 2005 UTC (15 years, 4 months ago) by jds
File MIME type: text/x-csrc
File size: 16922 byte(s)
A little more progress killing compiler warnings.
1 /*
2 * User Packages
3 * by Kirk Abbott
4 * Created: July 4, 1994
5 * Version: $Revision: 1.14 $
6 * Version control file: $RCSfile: packages.c,v $
7 * Date last modified: $Date: 1998/03/06 15:47:14 $
8 * Last modified by: $Author: ballan $
9 *
10 * This file is part of the Ascend Language Interpreter.
11 *
12 * Copyright (C) 1990, 1993, 1994 Thomas Guthrie Epperly, Kirk Abbott.
13 *
14 * The Ascend Language Interpreter is free software; you can redistribute
15 * it and/or modify it under the terms of the GNU General Public License as
16 * published by the Free Software Foundation; either version 2 of the
17 * License, or (at your option) any later version.
18 *
19 * The Ascend Language Interpreter is distributed in hope that it will be
20 * useful, but WITHOUT ANY WARRANTY; without even the implied warranty of
21 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
22 * General Public License for more details.
23 *
24 * You should have received a copy of the GNU General Public License
25 * along with the program; if not, write to the Free Software Foundation,
26 * Inc., 675 Mass Ave, Cambridge, MA 02139 USA. Check the file named
27 * COPYING.
28 *
29 */
30
31 /**
32 Code to support dynamic and static loading of user packages.
33
34 The default state is to have packages. As such it takes an explicit
35 definition of NO_PACKAGES, if packages are not to be handled.
36 An explicit definition of STATIC_PACKAGES or DYNAMIC_PACKAGES is also
37 required.
38 */
39
40 #include <math.h>
41 #include <ctype.h> /* was compiler/actype.h */
42 #include "utilities/ascConfig.h"
43 #include "compiler/compiler.h"
44 #include "utilities/ascMalloc.h"
45 #include "general/list.h"
46 #include "compiler/symtab.h"
47 #include "compiler/fractions.h"
48 #include "compiler/dimen.h"
49 #include "compiler/functype.h"
50 #include "compiler/types.h"
51 #include "compiler/extfunc.h"
52 #include "compiler/extcall.h"
53 #include "compiler/mathinst.h"
54 #include "compiler/instance_enum.h"
55 #include "compiler/instquery.h"
56 #include "compiler/atomvalue.h"
57 #include "compiler/find.h"
58 #include "compiler/relation_type.h"
59 #include "compiler/relation.h"
60 #include "compiler/safe.h"
61 #include "compiler/relation_util.h"
62 #include "packages/sensitivity.h"
63 #include "packages/ascFreeAllVars.h"
64 #include "compiler/module.h"
65 #include "compiler/packages.h"
66
67 /*
68 Initialise the slv data structures used when calling external fns
69 */
70 void Init_Slv_Interp(struct Slv_Interp *slv_interp)
71 {
72 if (slv_interp){
73 slv_interp->nodestamp = 0;
74 slv_interp->status = calc_all_ok;
75 slv_interp->user_data = NULL;
76 slv_interp->first_call = (unsigned)0;
77 slv_interp->last_call = (unsigned)0;
78 slv_interp->check_args = (unsigned)0;
79 slv_interp->recalculate = (unsigned)0;
80 slv_interp->func_eval = (unsigned)0;
81 slv_interp->deriv_eval = (unsigned)0;
82 slv_interp->single_step = (unsigned)0;
83 }
84 }
85
86 /*
87 @deprecated, @see packages.h
88 */
89 symchar *MakeArchiveLibraryName(CONST char *prefix)
90 {
91 char *buffer;
92 int len;
93 symchar *result;
94
95 len = strlen(prefix);
96 buffer = (char *)ascmalloc(len+40);
97
98 #if defined(sun) || defined(solaris) || defined(__osf__)
99 sprintf(buffer,"%s.so.1.0",prefix);
100 #elif defined(__hpux)
101 sprintf(buffer,"%s.sl",prefix);
102 #elif defined(_SGI_SOURCE)
103 sprintf(buffer,"%s.so",prefix);
104 #elif defined(linux) || defined(ultrix)
105 sprintf(buffer,"lib%s.so",prefix); /* changed from .o to .so -- JP */
106 #else
107 sprintf(buffer,"%s.so.1.0",prefix);
108 #endif
109
110 result = AddSymbol(buffer); /* the main symbol table */
111 ascfree(buffer);
112 return result; /* owns the string */
113 }
114
115 /*---------------------------------------------
116 BUILT-IN PACKAGES...
117 */
118
119 /**
120 Load builtin packages, unless NO_PACKAGES.
121
122 @return 0 if success, 1 if failure.
123 */
124 static
125 int Builtins_Init(void)
126 {
127 int result = 0;
128
129 #ifdef NO_PACKAGES
130 error_reporter(ASC_USER_WARNING,__FILE__,__LINE,"Builtins_Init: DISABLED at compile-time");
131 #else
132 ERROR_REPORTER_DEBUG("Builtins_Init: Loading function asc_free_all_variables\n");
133 result = CreateUserFunction("asc_free_all_variables"
134 ,(ExtEvalFunc *)NULL
135 ,(ExtEvalFunc **)Asc_FreeAllVars
136 ,(ExtEvalFunc **)NULL
137 ,(ExtEvalFunc **)NULL
138 ,1, 0, "Unset 'fixed' flag of all items of type 'solver_var'");
139 #endif
140 return result;
141 }
142
143 /*---------------------------------------------
144 DYNAMIC_PACKAGES code only...
145 */
146 # ifdef DYNAMIC_PACKAGES
147 static char path_var[PATH_MAX];
148
149 /**
150 Search the archive library path for a file matching the given
151 (platform specific, with extension?) library filename.
152
153 @return a pointer to a string space holding the full path
154 name of the file to be opened. The returned pointer may be NULL
155
156 @TODO won't work correctly on windows
157 @deprecated { see packages.h }
158 */
159 static
160 char *SearchArchiveLibraryPath(CONST char *name, char *dpath, char *envv)
161 {
162 register char *path,*result;
163 register CONST char *t;
164 register unsigned length;
165 register FILE *f;
166 /* error_reporter(ASC_PROG_NOTE,__FILE__,__LINE__,"Env var for user packages is '%s'\n",envv); */
167 error_reporter(ASC_PROG_NOTE,__FILE__,__LINE__,"Search path for user packages is '%s'\n",getenv(envv));
168 if ((path=getenv(envv))==NULL)
169 path=dpath;
170 while(isspace(*path)) path++;
171 while(*path!='\0'){
172 if (*path==':') path++;
173 else{
174 length = 0;
175 /* copy next directory into array */
176 while((*path!=':')&&(*path!='\0')&&(!isspace(*path)))
177 path_var[length++] = *(path++);
178 if (path_var[length-1]!='/')
179 path_var[length++]='/';
180 /* copy file name into array */
181 for(t=name;*t!='\0';)
182 path_var[length++] = *(t++);
183 path_var[length]='\0';
184 /* error_reporter(ASC_PROG_NOTE,__FILE__,__LINE__,"Searching for for '%s' in dir '%s'\n",name, path_var); */
185 if ((f= fopen(path_var,"r"))!=NULL){
186 result = path_var;
187 fclose(f);
188 return result;
189 }
190 }
191 while(isspace(*path)) path++;
192 }
193 return NULL;
194 }
195 #endif /* DYNAMIC_PACKAGES */
196 /*
197 END of DYNAMIC_PACKAGES-specific code
198 ------------------------------------------*/
199
200 int LoadArchiveLibrary(CONST char *name, CONST char *initfunc)
201 {
202 #ifdef NO_PACKAGES
203 /** avoid compiler warnings on params: */
204 (void) name; (void) initfunc;
205
206 error_reporter(ASC_PROG_ERROR,__FILE__,__LINE__,"LoadArchiveLibrary disabled: NO_PACKAGES");
207 return 1;
208
209 #elif defined(DYNAMIC_PACKAGES)
210
211 int result;
212 char *default_path = ".";
213 char *env = PATHENVIRONMENTVAR;
214 char *full_file_name = NULL;
215 extern int DynamicLoad(CONST char *,CONST char *);
216
217 full_file_name = SearchArchiveLibraryPath(name,default_path,env);
218 if (!full_file_name) {
219 error_reporter(ASC_USER_ERROR,NULL,0,"The named library '%s' was not found in the search path",name);
220 return 1;
221 }
222 result = DynamicLoad(full_file_name,initfunc);
223 if (result) {
224 return 1;
225 }
226 ERROR_REPORTER_DEBUG("Successfully ran '%s' from dynamic package '%s'\n",initfunc,name);
227 return 0;
228
229 #elif defined(STATIC_PACKAGES)
230
231 /* avoid compiler warnings on params: */
232 (void) name; (void) initfunc;
233
234 error_reporter(ASC_PROG_NOTE,__FILE__,__LINE__,"LoadArchiveLibrary disabled: STATIC_PACKAGES, no need to load dynamically.");
235 return 0;
236
237 #else /* unknown flags */
238
239 # error "Invalid package linking flags"
240 (void) name; (void) initfunc;
241 return 1;
242
243 #endif
244 }
245
246 /*---------------------------------------------
247 STATIC_PACKAGES code only...
248
249 Declare the functions which we are expected to be able to call.
250 */
251 #ifndef NO_PACKAGES
252 # ifdef STATIC_PACKAGES
253
254 /* kvalues.c */
255 extern int kvalues_preslv(struct Slv_Interp *,struct Instance *, struct gl_list_t *);
256 extern int kvalues_fex(struct Slv_Interp *, int, int, double *, double *, double *);
257
258 /* bisect.c */
259 extern int do_set_values_eval(struct Slv_Interp *,struct Instance *, struct gl_list_t *);
260 extern int do_bisection_eval(struct Slv_Interp *,struct Instance *,struct gl_list_t *);
261
262 /* sensitivity.c */
263 extern int do_sensitivity_eval(struct Slv_Interp *,struct Instance *, struct gl_list_t *);
264
265 # endif
266 #endif
267
268 #ifdef STATIC_PACKAGES
269 /**
270 Load all statically-linked packages
271
272 @return 0 on success, >0 if any CreateUserFunction calls failed.
273 */
274 static
275 int StaticPackages_Init(void)
276 {
277 int result = 0;
278
279 char sensitivity_help[] =
280 "This function does sensitivity analysis dy/dx. It requires 4 args.\n"
281 "The first arg is the name of a reference instance or SELF.\n"
282 "The second arg is x, where x is an array of > solver_var\n."
283 "The third arg y, where y is an array of > solver_var\n. "
284 "The fourth arg is dy/dx which dy_dx[1..n_y][1..n_x].\n";
285
286 result = CreateUserFunction("do_solve",
287 (ExtEvalFunc *)NULL,
288 (ExtEvalFunc **)do_solve_eval,
289 (ExtEvalFunc **)NULL,
290 (ExtEvalFunc **)NULL,
291 2,0,NULL);
292 result += CreateUserFunction("do_finite_difference",
293 (ExtEvalFunc *)NULL,
294 (ExtEvalFunc **)do_finite_diff_eval,
295 (ExtEvalFunc **)NULL,
296 (ExtEvalFunc **)NULL,
297 4,0,NULL);
298 result += CreateUserFunction("do_sensitivity",
299 (ExtEvalFunc *)NULL,
300 (ExtEvalFunc **)do_sensitivity_eval,
301 (ExtEvalFunc **)NULL,
302 (ExtEvalFunc **)NULL,
303 4,0,sensitivity_help);
304 result += CreateUserFunction("do_sensitivity_all",
305 (ExtEvalFunc *)NULL,
306 (ExtEvalFunc **)do_sensitivity_eval_all,
307 (ExtEvalFunc **)NULL,
308 (ExtEvalFunc **)NULL,
309 4,0,"See do_sensitivity for details");
310
311 return result;
312 }
313 #endif
314
315 /**
316 This is a general purpose function that will load whatever user
317 functions are required according to the compile-time settings.
318
319 If NO_PACKAGES, nothing will be loaded. If DYNAMIC_PACKAGES, then
320 just the builtin packages will be loaded. If STATIC_PACKAGES then
321 builtin plus those called in 'StaticPackages_Init' will be loaded.
322 */
323 void AddUserFunctions(void)
324 {
325 #ifdef NO_PACKAGES
326 # ifdef __GNUC__
327 # warning "EXTERNAL PACKAGES ARE BEING DISABLED"
328 # endif
329 error_reporter(ASC_PROG_NOTE,NULL,0,"AddUserFunctions disabled at compile-time.");
330 #else
331
332 /* Builtins are always statically linked */
333 if (Builtins_Init()) {
334 error_reporter(ASC_PROG_WARNING,NULL,0,"Problem in Builtins_Init: Some user functions not created");
335 }
336
337 # ifdef DYNAMIC_PACKAGES
338 /* do nothing */
339
340 # elif defined(STATIC_PACKAGES)
341 # ifdef __GNUC__
342 # warning "STATIC PACKAGES"
343 # endif
344
345 /*The following need to be reimplemented but are basically useful as is. */
346 if (StaticPackages_Init()) {
347 error_reporter(ASC_PROG_WARNING,NULL,0,"Problem in StaticPackages_Init(): Some user functions not created");
348 }
349
350 # endif
351 #endif
352 }
353
354 /*---------------------------------------
355 TESTING FUNCTIONS
356
357 The following functions may be called someone desirous of testing
358 an external relation provided as a package. They are here
359 for convenience, and should be really in a separate file.
360 */
361
362 /**
363 What's this do? -- JP
364 */
365 static void LoadInputVector(struct gl_list_t *arglist,
366 double *inputs,
367 unsigned ninputs,
368 unsigned long n_input_args)
369 {
370 struct Instance *inst;
371 struct gl_list_t *input_list;
372 unsigned long c,len;
373
374 input_list = LinearizeArgList(arglist,1,n_input_args);
375
376 if(!input_list)return;
377
378 len = gl_length(input_list);
379
380 if(len!=ninputs)return; /* somehow we had inconsistent data */
381
382 for (c=1;c<=len;c++) {
383 inst = (struct Instance *)gl_fetch(input_list,c);
384 inputs[c-1] = RealAtomValue(inst);
385 }
386 gl_destroy(input_list);
387 }
388
389 /**
390 What's a black box, and what's a glass box? -- JP
391 */
392 int CallBlackBox(struct Instance *inst,
393 CONST struct relation *rel)
394 {
395 struct Instance *data;
396
397 struct Slv_Interp slv_interp;
398 struct ExternalFunc *efunc;
399 struct ExtCallNode *ext;
400 struct gl_list_t *arglist;
401 unsigned long n_input_args, n_output_args;
402 int nok = 0;
403
404 unsigned long ninputs, noutputs;
405 double *inputs = NULL, *outputs = NULL;
406 double *jacobian = NULL;
407
408 /* All these desperately need a typedef in a header someplace */
409 int (*init_func) (struct Slv_Interp *,
410 struct Instance *,
411 struct gl_list_t *);
412
413 int (*eval_func)(struct Slv_Interp *,
414 int /* n_inputs */,
415 int /* n_outputs */,
416 double * /* inputs */,
417 double * /* outputs */,
418 double * /* jacobian */);
419
420 int (*deriv_func)(struct Slv_Interp *,
421 int /* n_inputs */,
422 int /* n_outputs */,
423 double * /* inputs */,
424 double * /* outputs */,
425 double * /* jacobian */);
426
427 /*------------------------------
428 After this point everything should be ok.
429 <-- says who? when? -- JP
430 */
431
432 /* Visual C doesn't like this before the func ptr defs. */
433 UNUSED_PARAMETER(inst);
434
435 ext = BlackBoxExtCall(rel);
436 arglist = ExternalCallArgList(ext);
437 data = ExternalCallDataInstance(ext);
438 efunc = ExternalCallExtFunc(ext);
439 init_func = GetInitFunc(efunc);
440 eval_func = GetValueFunc(efunc);
441 deriv_func = GetDerivFunc(efunc);
442
443 if (init_func && eval_func) {
444
445 /* set up the interpreter. */
446 Init_Slv_Interp(&slv_interp);
447 slv_interp.check_args = (unsigned)1;
448 slv_interp.first_call = (unsigned)1;
449 slv_interp.last_call = (unsigned)0;
450 slv_interp.nodestamp = ExternalCallNodeStamp(ext);
451 n_input_args = NumberInputArgs(efunc);
452 n_output_args = NumberOutputArgs(efunc);
453 ninputs = CountNumberOfArgs(arglist,1,n_input_args);
454 noutputs = CountNumberOfArgs(arglist,n_input_args + 1,
455 n_input_args+n_output_args);
456
457 /* Create the work vectors. Load the input vector from the instance tree. */
458 inputs = (double *)asccalloc(ninputs,sizeof(double));
459 outputs = (double *)asccalloc(ninputs,sizeof(double));
460 jacobian = (double *)asccalloc(ninputs*noutputs,sizeof(double));
461 LoadInputVector(arglist,inputs,ninputs,n_input_args);
462
463 /*
464 * Call the init function.
465 */
466 nok = (*init_func)(&slv_interp,data,arglist);
467 if (nok) goto error;
468 /*
469 * Call the evaluation function.
470 */
471 nok = (*eval_func)(&slv_interp,ninputs,noutputs,
472 inputs,outputs,jacobian);
473 if (nok) goto error;
474 /*
475 * Call the derivative routine.
476 */
477 if (deriv_func) {
478 nok = (*deriv_func)(&slv_interp,ninputs,noutputs,
479 inputs,outputs,jacobian);
480 if (nok) goto error;
481 }
482 /*
483 * Call the init function to shut down
484 */
485 slv_interp.first_call = (unsigned)0;
486 slv_interp.last_call = (unsigned)1;
487 nok = (*init_func)(&slv_interp,data,arglist);
488 if (nok) goto error;
489 }
490 else{
491 FPRINTF(ASCERR,"External function not loaded\n");
492 return 1;
493 }
494
495 error:
496 if (inputs) ascfree((char *)inputs);
497 if (outputs) ascfree((char *)outputs);
498 if (jacobian) ascfree((char *)outputs);
499 if (nok)
500 return 1;
501 else
502 return 0;
503 }
504
505 /**
506 When glassbox are registered, they must register a pointer
507 to their function jump table. In other words, they must
508 register a pointer to an 'array of pointers to functions'.
509 This typedef just makes life a little cleaner.
510
511 <-- what typedef?? -- JP
512 */
513 int CallGlassBox(struct Instance *relinst, CONST struct relation *rel)
514 {
515 CONST struct gl_list_t *incidence;
516 struct Instance *var;
517 struct ExternalFunc *efunc;
518 int index;
519 long i;
520 double *f, *x, *g;
521 int m,mode,result;
522 int n;
523
524 ExtEvalFunc **evaltable, *eval_func;
525 ExtEvalFunc **derivtable, *deriv_func;
526
527 (void) relinst;
528 incidence = RelationVarList(rel);
529 if (!incidence) {
530 FPRINTF(ASCERR,"Incidence list is empty -- nothing to evaluate\n");
531 return 0;
532 }
533 index = GlassBoxRelIndex(rel);
534 efunc = GlassBoxExtFunc(rel);
535 evaltable = GetValueJumpTable(efunc);
536 eval_func = evaltable[index];
537 derivtable = GetDerivJumpTable(efunc);
538 deriv_func = derivtable[index];
539
540 m = 0; /* FIX not sure what this should be !!! */
541 n = gl_length(incidence);
542 f = (double *)asccalloc((1 + 2*n),sizeof(double));
543 x = &f[1];
544 g = &f[n+1];
545
546 for (i=0;i<n;i++) {
547 var = (struct Instance *)gl_fetch(incidence,i+1);
548 x[i] = RealAtomValue(var);
549 }
550 result = (*eval_func)(&mode,&m,&n,x,NULL,f,g);
551 result += (*deriv_func)(&mode,&m,&n,x,NULL,f,g);
552
553 ascfree((char *)f);
554 return result;
555 }
556
557 /**
558 No idea what this does. It's referenced in 'interface.c' only, so it
559 appears to be defunct -- JP
560 */
561 int CallExternalProcs(struct Instance *inst)
562 {
563 CONST struct relation *rel;
564 enum Expr_enum reltype;
565
566 if (inst==NULL){
567 FPRINTF(ASCERR,"Instance does not exist for callprocs\n");
568 return 1;
569 }
570 if (InstanceKind(inst)!=REL_INST){
571 FPRINTF(ASCERR,"Instance is not a relation\n");
572 return 1;
573 }
574 rel = GetInstanceRelation(inst,&reltype);
575 if (!rel) {
576 FPRINTF(ASCERR,"Relation structure is NULL\n");
577 return 1;
578 }
579 switch (reltype) {
580 case e_blackbox:
581 return CallBlackBox(inst,rel);
582 case e_glassbox:
583 return CallGlassBox(inst,rel);
584 default:
585 FPRINTF(ASCERR,"Invalid relation type in CallExternalProc\n");
586 return 1;
587 }
588 }

john.pye@anu.edu.au
ViewVC Help
Powered by ViewVC 1.1.22