/[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 369 - (show annotations) (download) (as text)
Fri Mar 10 09:14:29 2006 UTC (18 years, 3 months ago) by johnpye
File MIME type: text/x-csrc
File size: 16917 byte(s)
Debugging output for loading external packages.
Export error_reporter to windows DLL (needs testing).
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
181 /* copy file name into array */
182 for(t=name;*t!='\0';){
183 path_var[length++] = *(t++);
184 }
185 path_var[length]='\0';
186
187 ERROR_REPORTER_HERE(ASC_PROG_NOTE,"Searching for for '%s' at '%s'\n",name, path_var);
188
189 if ((f= fopen(path_var,"r"))!=NULL){
190 result = path_var;
191 fclose(f);
192 return result;
193 }
194 }
195 while(isspace(*path)) path++;
196 }
197 return NULL;
198 }
199 #endif /* DYNAMIC_PACKAGES */
200 /*
201 END of DYNAMIC_PACKAGES-specific code
202 ------------------------------------------*/
203
204 int LoadArchiveLibrary(CONST char *name, CONST char *initfunc)
205 {
206 #ifdef NO_PACKAGES
207 /** avoid compiler warnings on params: */
208 (void) name; (void) initfunc;
209
210 ERROR_REPORTER_HERE(ASC_PROG_ERROR,"LoadArchiveLibrary disabled: NO_PACKAGES");
211 return 1;
212
213 #elif defined(DYNAMIC_PACKAGES)
214
215 int result;
216 char *default_path = ".";
217 char *env = PATHENVIRONMENTVAR;
218 char *full_file_name = NULL;
219 extern int Asc_DynamicLoad(CONST char *,CONST char *);
220
221 full_file_name = SearchArchiveLibraryPath(name,default_path,env);
222 if (!full_file_name) {
223 ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"The named library '%s' was not found in the search path",name);
224 return 1;
225 }
226 result = Asc_DynamicLoad(full_file_name,initfunc);
227 if (result) {
228 return 1;
229 }
230 ERROR_REPORTER_DEBUG("Successfully ran '%s' from dynamic package '%s'\n",initfunc,name);
231 return 0;
232
233 #elif defined(STATIC_PACKAGES)
234
235 /* avoid compiler warnings on params: */
236 (void) name; (void) initfunc;
237
238 ERROR_REPORTER_HERE(ASC_PROG_NOTE,"LoadArchiveLibrary disabled: STATIC_PACKAGES, no need to load dynamically.\n");
239 return 0;
240
241 #else /* unknown flags */
242
243 # error "Invalid package linking flags"
244 (void) name; (void) initfunc;
245 return 1;
246
247 #endif
248 }
249
250 /*---------------------------------------------
251 STATIC_PACKAGES code only...
252
253 Declare the functions which we are expected to be able to call.
254 */
255 #ifndef NO_PACKAGES
256 # ifdef STATIC_PACKAGES
257
258 /* kvalues.c */
259 extern int kvalues_preslv(struct Slv_Interp *,struct Instance *, struct gl_list_t *);
260 extern int kvalues_fex(struct Slv_Interp *, int, int, double *, double *, double *);
261
262 /* bisect.c */
263 extern int do_set_values_eval(struct Slv_Interp *,struct Instance *, struct gl_list_t *);
264 extern int do_bisection_eval(struct Slv_Interp *,struct Instance *,struct gl_list_t *);
265
266 /* sensitivity.c */
267 extern int do_sensitivity_eval(struct Slv_Interp *,struct Instance *, struct gl_list_t *);
268
269 # endif
270 #endif
271
272 #ifdef STATIC_PACKAGES
273 /**
274 Load all statically-linked packages
275
276 @return 0 on success, >0 if any CreateUserFunction calls failed.
277 */
278 static
279 int StaticPackages_Init(void)
280 {
281 int result = 0;
282
283 char sensitivity_help[] =
284 "This function does sensitivity analysis dy/dx. It requires 4 args:\n"
285 " 1. name: name of a reference instance or SELF.\n"
286 " 2. x: x, where x is an array of > solver_var.\n"
287 " 3. y: where y is an array of > solver_var.\n"
288 " 4. dy/dx: which dy_dx[1..n_y][1..n_x].";
289
290 result = CreateUserFunction("do_solve",
291 (ExtEvalFunc *)NULL,
292 (ExtEvalFunc **)do_solve_eval,
293 (ExtEvalFunc **)NULL,
294 (ExtEvalFunc **)NULL,
295 2,0,NULL);
296 result += CreateUserFunction("do_finite_difference",
297 (ExtEvalFunc *)NULL,
298 (ExtEvalFunc **)do_finite_diff_eval,
299 (ExtEvalFunc **)NULL,
300 (ExtEvalFunc **)NULL,
301 4,0,NULL);
302 result += CreateUserFunction("do_sensitivity",
303 (ExtEvalFunc *)NULL,
304 (ExtEvalFunc **)do_sensitivity_eval,
305 (ExtEvalFunc **)NULL,
306 (ExtEvalFunc **)NULL,
307 4,0,sensitivity_help);
308 result += CreateUserFunction("do_sensitivity_all",
309 (ExtEvalFunc *)NULL,
310 (ExtEvalFunc **)do_sensitivity_eval_all,
311 (ExtEvalFunc **)NULL,
312 (ExtEvalFunc **)NULL,
313 4,0,"See do_sensitivity for details");
314
315 return result;
316 }
317 #endif
318
319 /**
320 This is a general purpose function that will load whatever user
321 functions are required according to the compile-time settings.
322
323 If NO_PACKAGES, nothing will be loaded. If DYNAMIC_PACKAGES, then
324 just the builtin packages will be loaded. If STATIC_PACKAGES then
325 builtin plus those called in 'StaticPackages_Init' will be loaded.
326 */
327 void AddUserFunctions(void)
328 {
329 #ifdef NO_PACKAGES
330 # ifdef __GNUC__
331 # warning "EXTERNAL PACKAGES ARE BEING DISABLED"
332 # endif
333 ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"AddUserFunctions disabled at compile-time.");
334 #else
335
336 /* Builtins are always statically linked */
337 if (Builtins_Init()) {
338 ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in Builtins_Init: Some user functions not created");
339 }
340
341 # ifdef DYNAMIC_PACKAGES
342 /* do nothing */
343
344 # elif defined(STATIC_PACKAGES)
345 # ifdef __GNUC__
346 # warning "STATIC PACKAGES"
347 # endif
348
349 /*The following need to be reimplemented but are basically useful as is. */
350 if (StaticPackages_Init()) {
351 ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in StaticPackages_Init(): Some user functions not created");
352 }
353
354 # endif
355 #endif
356 }
357
358 /*---------------------------------------
359 TESTING FUNCTIONS
360
361 The following functions may be called someone desirous of testing
362 an external relation provided as a package. They are here
363 for convenience, and should be really in a separate file.
364 */
365
366 /**
367 What's this do? -- JP
368 */
369 static void LoadInputVector(struct gl_list_t *arglist,
370 double *inputs,
371 unsigned ninputs,
372 unsigned long n_input_args)
373 {
374 struct Instance *inst;
375 struct gl_list_t *input_list;
376 unsigned long c,len;
377
378 input_list = LinearizeArgList(arglist,1,n_input_args);
379
380 if(!input_list)return;
381
382 len = gl_length(input_list);
383
384 if(len!=ninputs)return; /* somehow we had inconsistent data */
385
386 for (c=1;c<=len;c++) {
387 inst = (struct Instance *)gl_fetch(input_list,c);
388 inputs[c-1] = RealAtomValue(inst);
389 }
390 gl_destroy(input_list);
391 }
392
393 /**
394 What's a black box, and what's a glass box? -- JP
395 */
396 int CallBlackBox(struct Instance *inst,
397 CONST struct relation *rel)
398 {
399 struct Instance *data;
400
401 struct Slv_Interp slv_interp;
402 struct ExternalFunc *efunc;
403 struct ExtCallNode *ext;
404 struct gl_list_t *arglist;
405 unsigned long n_input_args, n_output_args;
406 int nok = 0;
407
408 unsigned long ninputs, noutputs;
409 double *inputs = NULL, *outputs = NULL;
410 double *jacobian = NULL;
411
412 /* All these desperately need a typedef in a header someplace */
413 /* now typedefs in solver/extfunc.h - 1/22/2006 - jds
414 int (*init_func) (struct Slv_Interp *,
415 struct Instance *,
416 struct gl_list_t *);
417
418 int (*eval_func)(struct Slv_Interp *,
419 int, // n_inputs
420 int, // n_outputs
421 double *, // inputs
422 double * , // outputs
423 double * ); // jacobian
424
425 int (*deriv_func)(struct Slv_Interp *,
426 int, // n_inputs
427 int , // n_outputs
428 double *, // inputs
429 double * , // outputs
430 double * ); // jacobian
431 */
432 ExtBBoxInitFunc *init_func;
433 ExtBBoxFunc *eval_func;
434 ExtBBoxFunc *deriv_func;
435
436 /*------------------------------
437 After this point everything should be ok.
438 <-- says who? when? -- JP
439 */
440
441 /* Visual C doesn't like this before the func ptr defs. */
442 UNUSED_PARAMETER(inst);
443
444 ext = BlackBoxExtCall(rel);
445 arglist = ExternalCallArgList(ext);
446 data = ExternalCallDataInstance(ext);
447 efunc = ExternalCallExtFunc(ext);
448 init_func = GetInitFunc(efunc);
449 eval_func = GetValueFunc(efunc);
450 deriv_func = GetDerivFunc(efunc);
451
452 if (init_func && eval_func) {
453
454 /* set up the interpreter. */
455 Init_Slv_Interp(&slv_interp);
456 slv_interp.check_args = (unsigned)1;
457 slv_interp.first_call = (unsigned)1;
458 slv_interp.last_call = (unsigned)0;
459 slv_interp.nodestamp = ExternalCallNodeStamp(ext);
460 n_input_args = NumberInputArgs(efunc);
461 n_output_args = NumberOutputArgs(efunc);
462 ninputs = CountNumberOfArgs(arglist,1,n_input_args);
463 noutputs = CountNumberOfArgs(arglist,n_input_args + 1,
464 n_input_args+n_output_args);
465
466 /* Create the work vectors. Load the input vector from the instance tree. */
467 inputs = (double *)asccalloc(ninputs,sizeof(double));
468 outputs = (double *)asccalloc(ninputs,sizeof(double));
469 jacobian = (double *)asccalloc(ninputs*noutputs,sizeof(double));
470 LoadInputVector(arglist,inputs,ninputs,n_input_args);
471
472 /*
473 * Call the init function.
474 */
475 nok = (*init_func)(&slv_interp,data,arglist);
476 if (nok) goto error;
477 /*
478 * Call the evaluation function.
479 */
480 nok = (*eval_func)(&slv_interp,ninputs,noutputs,
481 inputs,outputs,jacobian);
482 if (nok) goto error;
483 /*
484 * Call the derivative routine.
485 */
486 if (deriv_func) {
487 nok = (*deriv_func)(&slv_interp,ninputs,noutputs,
488 inputs,outputs,jacobian);
489 if (nok) goto error;
490 }
491 /*
492 * Call the init function to shut down
493 */
494 slv_interp.first_call = (unsigned)0;
495 slv_interp.last_call = (unsigned)1;
496 nok = (*init_func)(&slv_interp,data,arglist);
497 if (nok) goto error;
498 }
499 else{
500 FPRINTF(ASCERR,"External function not loaded\n");
501 return 1;
502 }
503
504 error:
505 if (inputs) ascfree((char *)inputs);
506 if (outputs) ascfree((char *)outputs);
507 if (jacobian) ascfree((char *)outputs);
508 if (nok)
509 return 1;
510 else
511 return 0;
512 }
513
514 /**
515 When glassbox are registered, they must register a pointer
516 to their function jump table. In other words, they must
517 register a pointer to an 'array of pointers to functions'.
518 This typedef just makes life a little cleaner.
519
520 <-- what typedef?? -- JP
521 */
522 int CallGlassBox(struct Instance *relinst, CONST struct relation *rel)
523 {
524 CONST struct gl_list_t *incidence;
525 struct Instance *var;
526 struct ExternalFunc *efunc;
527 int index;
528 long i;
529 double *f, *x, *g;
530 int m,mode,result;
531 int n;
532
533 ExtEvalFunc **evaltable, *eval_func;
534 ExtEvalFunc **derivtable, *deriv_func;
535
536 (void) relinst;
537 incidence = RelationVarList(rel);
538 if (!incidence) {
539 FPRINTF(ASCERR,"Incidence list is empty -- nothing to evaluate\n");
540 return 0;
541 }
542 index = GlassBoxRelIndex(rel);
543 efunc = GlassBoxExtFunc(rel);
544 evaltable = GetValueJumpTable(efunc);
545 eval_func = evaltable[index];
546 derivtable = GetDerivJumpTable(efunc);
547 deriv_func = derivtable[index];
548
549 m = 0; /* FIX not sure what this should be !!! */
550 n = gl_length(incidence);
551 f = (double *)asccalloc((1 + 2*n),sizeof(double));
552 x = &f[1];
553 g = &f[n+1];
554
555 for (i=0;i<n;i++) {
556 var = (struct Instance *)gl_fetch(incidence,i+1);
557 x[i] = RealAtomValue(var);
558 }
559 result = (*eval_func)(&mode,&m,&n,x,NULL,f,g);
560 result += (*deriv_func)(&mode,&m,&n,x,NULL,f,g);
561
562 ascfree((char *)f);
563 return result;
564 }
565
566 /**
567 No idea what this does. It's referenced in 'interface.c' only, so it
568 appears to be defunct -- JP
569 */
570 int CallExternalProcs(struct Instance *inst)
571 {
572 CONST struct relation *rel;
573 enum Expr_enum reltype;
574
575 if (inst==NULL){
576 FPRINTF(ASCERR,"Instance does not exist for callprocs\n");
577 return 1;
578 }
579 if (InstanceKind(inst)!=REL_INST){
580 FPRINTF(ASCERR,"Instance is not a relation\n");
581 return 1;
582 }
583 rel = GetInstanceRelation(inst,&reltype);
584 if (!rel) {
585 FPRINTF(ASCERR,"Relation structure is NULL\n");
586 return 1;
587 }
588 switch (reltype) {
589 case e_blackbox:
590 return CallBlackBox(inst,rel);
591 case e_glassbox:
592 return CallGlassBox(inst,rel);
593 default:
594 FPRINTF(ASCERR,"Invalid relation type in CallExternalProc\n");
595 return 1;
596 }
597 }

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