/[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 303 - (show annotations) (download) (as text)
Tue Feb 21 02:38:13 2006 UTC (18 years, 3 months ago) by johnpye
File MIME type: text/x-csrc
File size: 16920 byte(s)
Documentation, indentation and debugging-message changes.
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/extcall.h"
52 #include "compiler/mathinst.h"
53 #include "compiler/instance_enum.h"
54 #include "compiler/instquery.h"
55 #include "compiler/atomvalue.h"
56 #include "compiler/find.h"
57 #include "compiler/relation_type.h"
58 #include "compiler/relation.h"
59 #include "compiler/safe.h"
60 #include "compiler/relation_util.h"
61 #include "compiler/extfunc.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)
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)
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_HERE(ASC_USER_WARNING,"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_HERE(ASC_PROG_NOTE,"Env var for user packages is '%s'\n",envv); */
167 ERROR_REPORTER_HERE(ASC_PROG_NOTE,"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_HERE(ASC_PROG_NOTE,"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_HERE(ASC_PROG_ERROR,"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 Asc_DynamicLoad(CONST char *,CONST char *);
216
217 full_file_name = SearchArchiveLibraryPath(name,default_path,env);
218 if (!full_file_name) {
219 ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"The named library '%s' was not found in the search path",name);
220 return 1;
221 }
222 result = Asc_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_HERE(ASC_PROG_NOTE,"LoadArchiveLibrary disabled: STATIC_PACKAGES, no need to load dynamically.\n");
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 " 1. name: name of a reference instance or SELF.\n"
282 " 2. x: x, where x is an array of > solver_var.\n"
283 " 3. y: where y is an array of > solver_var.\n"
284 " 4. dy/dx: which dy_dx[1..n_y][1..n_x].";
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_NOLINE(ASC_PROG_NOTE,"AddUserFunctions disabled at compile-time.");
330 #else
331
332 /* Builtins are always statically linked */
333 if (Builtins_Init()) {
334 ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"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_NOLINE(ASC_PROG_WARNING,"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 /* now typedefs in solver/extfunc.h - 1/22/2006 - jds
410 int (*init_func) (struct Slv_Interp *,
411 struct Instance *,
412 struct gl_list_t *);
413
414 int (*eval_func)(struct Slv_Interp *,
415 int, // n_inputs
416 int, // n_outputs
417 double *, // inputs
418 double * , // outputs
419 double * ); // jacobian
420
421 int (*deriv_func)(struct Slv_Interp *,
422 int, // n_inputs
423 int , // n_outputs
424 double *, // inputs
425 double * , // outputs
426 double * ); // jacobian
427 */
428 ExtBBoxInitFunc *init_func;
429 ExtBBoxFunc *eval_func;
430 ExtBBoxFunc *deriv_func;
431
432 /*------------------------------
433 After this point everything should be ok.
434 <-- says who? when? -- JP
435 */
436
437 /* Visual C doesn't like this before the func ptr defs. */
438 UNUSED_PARAMETER(inst);
439
440 ext = BlackBoxExtCall(rel);
441 arglist = ExternalCallArgList(ext);
442 data = ExternalCallDataInstance(ext);
443 efunc = ExternalCallExtFunc(ext);
444 init_func = GetInitFunc(efunc);
445 eval_func = GetValueFunc(efunc);
446 deriv_func = GetDerivFunc(efunc);
447
448 if (init_func && eval_func) {
449
450 /* set up the interpreter. */
451 Init_Slv_Interp(&slv_interp);
452 slv_interp.check_args = (unsigned)1;
453 slv_interp.first_call = (unsigned)1;
454 slv_interp.last_call = (unsigned)0;
455 slv_interp.nodestamp = ExternalCallNodeStamp(ext);
456 n_input_args = NumberInputArgs(efunc);
457 n_output_args = NumberOutputArgs(efunc);
458 ninputs = CountNumberOfArgs(arglist,1,n_input_args);
459 noutputs = CountNumberOfArgs(arglist,n_input_args + 1,
460 n_input_args+n_output_args);
461
462 /* Create the work vectors. Load the input vector from the instance tree. */
463 inputs = (double *)asccalloc(ninputs,sizeof(double));
464 outputs = (double *)asccalloc(ninputs,sizeof(double));
465 jacobian = (double *)asccalloc(ninputs*noutputs,sizeof(double));
466 LoadInputVector(arglist,inputs,ninputs,n_input_args);
467
468 /*
469 * Call the init function.
470 */
471 nok = (*init_func)(&slv_interp,data,arglist);
472 if (nok) goto error;
473 /*
474 * Call the evaluation function.
475 */
476 nok = (*eval_func)(&slv_interp,ninputs,noutputs,
477 inputs,outputs,jacobian);
478 if (nok) goto error;
479 /*
480 * Call the derivative routine.
481 */
482 if (deriv_func) {
483 nok = (*deriv_func)(&slv_interp,ninputs,noutputs,
484 inputs,outputs,jacobian);
485 if (nok) goto error;
486 }
487 /*
488 * Call the init function to shut down
489 */
490 slv_interp.first_call = (unsigned)0;
491 slv_interp.last_call = (unsigned)1;
492 nok = (*init_func)(&slv_interp,data,arglist);
493 if (nok) goto error;
494 }
495 else{
496 FPRINTF(ASCERR,"External function not loaded\n");
497 return 1;
498 }
499
500 error:
501 if (inputs) ascfree((char *)inputs);
502 if (outputs) ascfree((char *)outputs);
503 if (jacobian) ascfree((char *)outputs);
504 if (nok)
505 return 1;
506 else
507 return 0;
508 }
509
510 /**
511 When glassbox are registered, they must register a pointer
512 to their function jump table. In other words, they must
513 register a pointer to an 'array of pointers to functions'.
514 This typedef just makes life a little cleaner.
515
516 <-- what typedef?? -- JP
517 */
518 int CallGlassBox(struct Instance *relinst, CONST struct relation *rel)
519 {
520 CONST struct gl_list_t *incidence;
521 struct Instance *var;
522 struct ExternalFunc *efunc;
523 int index;
524 long i;
525 double *f, *x, *g;
526 int m,mode,result;
527 int n;
528
529 ExtEvalFunc **evaltable, *eval_func;
530 ExtEvalFunc **derivtable, *deriv_func;
531
532 (void) relinst;
533 incidence = RelationVarList(rel);
534 if (!incidence) {
535 FPRINTF(ASCERR,"Incidence list is empty -- nothing to evaluate\n");
536 return 0;
537 }
538 index = GlassBoxRelIndex(rel);
539 efunc = GlassBoxExtFunc(rel);
540 evaltable = GetValueJumpTable(efunc);
541 eval_func = evaltable[index];
542 derivtable = GetDerivJumpTable(efunc);
543 deriv_func = derivtable[index];
544
545 m = 0; /* FIX not sure what this should be !!! */
546 n = gl_length(incidence);
547 f = (double *)asccalloc((1 + 2*n),sizeof(double));
548 x = &f[1];
549 g = &f[n+1];
550
551 for (i=0;i<n;i++) {
552 var = (struct Instance *)gl_fetch(incidence,i+1);
553 x[i] = RealAtomValue(var);
554 }
555 result = (*eval_func)(&mode,&m,&n,x,NULL,f,g);
556 result += (*deriv_func)(&mode,&m,&n,x,NULL,f,g);
557
558 ascfree((char *)f);
559 return result;
560 }
561
562 /**
563 No idea what this does. It's referenced in 'interface.c' only, so it
564 appears to be defunct -- JP
565 */
566 int CallExternalProcs(struct Instance *inst)
567 {
568 CONST struct relation *rel;
569 enum Expr_enum reltype;
570
571 if (inst==NULL){
572 FPRINTF(ASCERR,"Instance does not exist for callprocs\n");
573 return 1;
574 }
575 if (InstanceKind(inst)!=REL_INST){
576 FPRINTF(ASCERR,"Instance is not a relation\n");
577 return 1;
578 }
579 rel = GetInstanceRelation(inst,&reltype);
580 if (!rel) {
581 FPRINTF(ASCERR,"Relation structure is NULL\n");
582 return 1;
583 }
584 switch (reltype) {
585 case e_blackbox:
586 return CallBlackBox(inst,rel);
587 case e_glassbox:
588 return CallGlassBox(inst,rel);
589 default:
590 FPRINTF(ASCERR,"Invalid relation type in CallExternalProc\n");
591 return 1;
592 }
593 }

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