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

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