/[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 743 - (show annotations) (download) (as text)
Thu Jul 6 14:22:26 2006 UTC (14 years, 4 months ago) by johnpye
File MIME type: text/x-csrc
File size: 17777 byte(s)
Few small changes to fix for Linux after the recent MSVC++ oriented changes.
1 /* ASCEND modelling environment
2 Copyright (C) 1990, 1993, 1994 Thomas Guthrie Epperly, Kirk Abbott.
3 Copyright (C) 2006 Carnegie Mellon University
4
5 This program is free software; you can redistribute it and/or modify
6 it under the terms of the GNU General Public License as published by
7 the Free Software Foundation; either version 2, or (at your option)
8 any later version.
9
10 This program is distributed in the hope that it will be useful,
11 but WITHOUT ANY WARRANTY; without even the implied warranty of
12 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
13 GNU General Public License for more details.
14
15 You should have received a copy of the GNU General Public License
16 along with this program; if not, write to the Free Software
17 Foundation, Inc., 59 Temple Place - Suite 330,
18 Boston, MA 02111-1307, USA.
19 *//**
20 @file
21 Code to support dynamic and static loading of user packages.
22
23 The default state is to have packages. As such it takes an explicit
24 definition of NO_PACKAGES, if packages are not to be handled.
25 An explicit definition of STATIC_PACKAGES or DYNAMIC_PACKAGES is also
26 required.
27 *//*
28 by Kirk Abbott
29 Created: July 4, 1994
30 Last in CVS: 1.14 ballan 1998/03/06 15:47:14
31 */
32
33 #if !defined(DYNAMIC_PACKAGES) && !defined(STATIC_PACKAGES) && !defined(NO_PACKAGES)
34 # error "Package linking option not set!"
35 #endif
36
37 #include <math.h>
38 #include <ctype.h> /* was compiler/actype.h */
39
40 #ifdef _MSC_VER
41 # include <sys/stat.h>
42 #endif
43
44 #include <utilities/ascConfig.h>
45 #include <utilities/config.h> /* NEW */
46
47 #ifndef ASC_DEFAULTPATH
48 # error "Where is ASC_DEFAULTPATH???"
49 #endif
50
51 #include <general/ospath.h>
52
53 #include "compiler.h"
54 #include <utilities/ascMalloc.h>
55 #include <utilities/ascEnvVar.h>
56 #include <utilities/ascDynaLoad.h>
57 #include <general/list.h>
58 #include "symtab.h"
59 #include "fractions.h"
60 #include "dimen.h"
61 #include "functype.h"
62 #include "expr_types.h"
63 #include "extcall.h"
64 #include "mathinst.h"
65 #include "instance_enum.h"
66 #include "instquery.h"
67 #include "atomvalue.h"
68 #include "find.h"
69 #include "relation_type.h"
70 #include "relation.h"
71 #include "safe.h"
72 #include "relation_util.h"
73 #include "extfunc.h"
74 #include <packages/sensitivity.h>
75 #include <packages/ascFreeAllVars.h>
76 #include "module.h"
77 #include "packages.h"
78
79 #ifdef _MSC_VER
80 # ifndef _stat
81 # error "Where is STAT?"
82 # endif
83 #endif
84
85 /*
86 Initialise the slv data structures used when calling external fns
87 */
88 void Init_Slv_Interp(struct Slv_Interp *slv_interp)
89 {
90 if (slv_interp){
91 slv_interp->nodestamp = 0;
92 slv_interp->status = calc_all_ok;
93 slv_interp->user_data = NULL;
94 slv_interp->task = bb_none;
95 /*
96 slv_interp->first_call = (unsigned)0; // gone away
97 slv_interp->last_call = (unsigned)0; // gone away
98 slv_interp->check_args = (unsigned)0; // gone away
99 slv_interp->recalculate = (unsigned)0; // gone away
100 slv_interp->func_eval = (unsigned)0; // gone away
101 slv_interp->deriv_eval = (unsigned)0; // gone away
102 slv_interp->single_step = (unsigned)0; // gone away
103 */
104 }
105 }
106
107 /*---------------------------------------------
108 BUILT-IN PACKAGES...
109 */
110
111 /**
112 Load builtin packages, unless NO_PACKAGES.
113
114 @return 0 if success, 1 if failure.
115 */
116 static
117 int Builtins_Init(void)
118 {
119 int result = 0;
120
121 #ifdef NO_PACKAGES
122 ERROR_REPORTER_HERE(ASC_USER_WARNING,"Builtins_Init: DISABLED at compile-time");
123 #else
124 ERROR_REPORTER_DEBUG("Builtins_Init: Loading function asc_free_all_variables\n");
125 result = CreateUserFunctionMethod("asc_free_all_variables",
126 Asc_FreeAllVars,
127 1,
128 "Unset 'fixed' flag of all items of type 'solver_var'");
129 #endif
130 return result;
131 }
132
133 /*---------------------------------------------
134 DYNAMIC_PACKAGES code only...
135 */
136 # ifdef DYNAMIC_PACKAGES
137 static char path_var[PATH_MAX];
138
139 /**
140 A little structure to help with searching for libraries
141
142 @see test_librarysearch
143 */
144 struct LibrarySearch{
145 struct FilePath *partialpath;
146 char fullpath[PATH_MAX];
147 };
148
149 FilePathTestFn test_librarysearch;
150
151 /**
152 A 'test' function for passing to the ospath_searchpath_iterate function.
153 This test function will return a match when a library having the required
154 name is present in the fully resolved path.
155 */
156 int test_librarysearch(struct FilePath *path, void *userdata){
157 /* user data = the relative path, plus a place
158 to store the full path when found */
159 FILE *f;
160 struct LibrarySearch *ls;
161 struct FilePath *fp;
162
163 ls = (struct LibrarySearch *)userdata;
164 fp = ospath_concat(path,ls->partialpath);
165 if(fp==NULL){
166 char *tmp;
167 tmp = ospath_str(path);
168 CONSOLE_DEBUG("Unable to concatenate '%s'...",tmp);
169 ospath_free_str(tmp);
170 tmp = ospath_str(ls->partialpath);
171 CONSOLE_DEBUG("... and '%s'...",tmp);
172 ospath_free_str(tmp);
173 return 0;
174 }
175
176 ospath_strncpy(fp,ls->fullpath,PATH_MAX);
177 /* CONSOLE_DEBUG("SEARCHING FOR %s",ls->fullpath); */
178
179 f = ospath_fopen(fp,"r");
180 if(f==NULL){
181 ospath_free(fp);
182 return 0;
183 }
184 fclose(f);
185
186 /* ERROR_REPORTER_HERE(ASC_PROG_NOTE,"FOUND! %s\n",ls->fullpath); */
187 ospath_free(fp);
188 return 1;
189 }
190
191 /**
192 Search the archive library path for a file matching the given
193 (platform specific, with extension?) library filename.
194
195 @param name Name of library being searched for
196 @param envv Name of environment var containing the ASCEND search path
197 @param dpath Default search path for the case where the env var is not defined
198
199 @return a pointer to a string space holding the full path
200 name of the file to be opened. The returned pointer may be NULL
201
202 If the returned pointer is not NULL, then it points to space that must be
203 freed when no longer needed.
204 */
205 static
206 char *SearchArchiveLibraryPath(CONST char *name, char *dpath, char *envv){
207 struct FilePath *fp1, *fp2, *fp3; /* relative path */
208 char *s1;
209 char buffer[PATH_MAX];
210
211 struct LibrarySearch ls;
212 struct FilePath **sp;
213 extern char path_var[PATH_MAX];
214 char *path;
215 ospath_stat_t buf;
216 FILE *f;
217
218 fp1 = ospath_new_noclean(name);
219 if(fp1==NULL){
220 ERROR_REPORTER_HERE(ASC_USER_ERROR,"Invalid partial path '%s'",name);
221 ospath_free(fp1);
222 return NULL;
223 }
224
225 s1 = ospath_getfilestem(fp1);
226 if(s1==NULL){
227 /* not a file, so fail... */
228 return NULL;
229 }
230
231 fp2 = ospath_getdir(fp1);
232 if(fp2==NULL){
233 ERROR_REPORTER_HERE(ASC_PROG_ERR,"unable to retrieve file dir");
234 return NULL;
235 }
236
237 CONSOLE_DEBUG("FILESTEM = '%s'",s1);
238
239 #if defined(ASC_SHLIBSUFFIX) && defined(ASC_SHLIBPREFIX)
240 /*
241 this is the preferred operation: SCons reports what the local system
242 uses as its shared library file extension.
243 */
244 snprintf(buffer,PATH_MAX,"%s%s%s",ASC_SHLIBPREFIX,s1,ASC_SHLIBSUFFIX);
245 #else
246 /*
247 if we don't have ASC_SHLIB-SUFFIX and -PREFIX then we can do some
248 system-specific stuff here, but it's not as general.
249 */
250 # ifdef __WIN32__
251 snprintf(buffer,PATH_MAX,"%s.dll",s1);
252 # elif defined(linux)
253 snprintf(buffer,PATH_MAX,"lib%s.so",s1); /* changed from .o to .so -- JP */
254 # elif defined(sun) || defined(solaris)
255 snprintf(buffer,PATH_MAX,"%s.so.1.0",s1);
256 # elif defined(__hpux)
257 snprintf(buffer,PATH_MAX,"%s.sl",s1);
258 # elif defined(_SGI_SOURCE)
259 snprintf(buffer,PATH_MAX,"%s.so",s1);
260 # else
261 # error "Unknown system type (please define ASC_SHLIBSUFFIX and ASC_SHLIBPREFIX)"
262 # endif
263 #endif
264
265 fp3 = ospath_new(buffer);
266 ospath_free(fp1);
267 fp1 = ospath_concat(fp2,fp3);
268 ospath_free(fp2);
269 ospath_free(fp3);
270 ospath_free_str(s1);
271
272 /* attempt to open "name" directly */
273 if(0==ospath_stat(fp1,&buf) && NULL!=(f = ospath_fopen(fp1,"r")) ){
274 char *tmp;
275 tmp = ospath_str(fp1);
276 CONSOLE_DEBUG("Library '%s' opened directly, without path search",tmp);
277 ospath_free_str(tmp);
278 fp2 = ospath_getabs(fp1);
279 ospath_strncpy(fp2,path_var,PATH_MAX);
280 ospath_free(fp2);
281 fclose(f);
282 }else{
283
284 ls.partialpath = fp1;
285
286 path=Asc_GetEnv(envv);
287 if(path==NULL){
288 CONSOLE_DEBUG("ENV VAR NOT FOUND, FALLING BACK TO DEFAULT SEARCH PATH = '%s'",dpath);
289 path=ASC_DEFAULTPATH;
290 }
291
292 sp = ospath_searchpath_new(path);
293
294 if(NULL==ospath_searchpath_iterate(sp,&test_librarysearch,&ls)){
295 ospath_free(fp1);
296 ospath_searchpath_free(sp);
297 return NULL;
298 }
299
300 strncpy(path_var,ls.fullpath,PATH_MAX);
301 ospath_searchpath_free(sp);
302 }
303
304 ospath_free(fp1);
305 return path_var;
306 }
307
308 #endif /* DYNAMIC_PACKAGES */
309 /*
310 END of DYNAMIC_PACKAGES-specific code
311 ------------------------------------------*/
312
313 int LoadArchiveLibrary(CONST char *partialname, CONST char *initfunc){
314
315 #ifdef DYNAMIC_PACKAGES
316 char *file;
317 char auto_initfunc[PATH_MAX];
318 char *stem;
319 struct FilePath *fp1;
320 int result;
321
322 CONSOLE_DEBUG("Searching for external library '%s'",partialname);
323
324 file = SearchArchiveLibraryPath(partialname, ASC_DEFAULTPATH, PATHENVIRONMENTVAR);
325 if(file==NULL){
326 ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"External library '%s' not found.",partialname);
327 return 1;
328 }
329
330 fp1 = ospath_new_from_posix(partialname);
331 stem = ospath_getfilestem(fp1);
332 if(stem==NULL){
333 ERROR_REPORTER_NOLINE(ASC_PROG_ERROR,"What is the stem of named library '%s'???",partialname);
334 free(stem);
335 ospath_free(fp1);
336 return 1;
337 }
338
339 if(initfunc==NULL){
340 strncpy(auto_initfunc,stem,PATH_MAX);
341 strncat(auto_initfunc,"_register",PATH_MAX-strlen(auto_initfunc));
342 result = Asc_DynamicLoad(file,auto_initfunc);
343 }else{
344 result = Asc_DynamicLoad(file,initfunc);
345 }
346
347 if(result){
348 CONSOLE_DEBUG("FAILED TO LOAD LIBRARY '%s' (error %d)",partialname,result);
349 result = 1;
350 }else{
351 if(initfunc==NULL){
352 CONSOLE_DEBUG("Successfully ran '%s' from dynamic package '%s'",auto_initfunc,file);
353 }else{
354 CONSOLE_DEBUG("Successfully ran '%s' from dynamic package '%s'",initfunc,file);
355 }
356 }
357
358 free(stem);
359 ospath_free(fp1);
360 return result;
361
362 #else
363
364 DISUSED_PARAMETER(name); DISUSED_PARAMETER(initfunc);
365
366 # if defined(STATIC_PACKAGES)
367 ERROR_REPORTER_HERE(ASC_PROG_NOTE,"LoadArchiveLibrary disabled: STATIC_PACKAGES, no need to load dynamically.\n");
368 return 0;
369 # elif defined(NO_PACKAGES)
370 ERROR_REPORTER_HERE(ASC_PROG_ERROR,"LoadArchiveLibrary disabled: NO_PACKAGES");
371 return 1;
372 # else
373 # error "Invalid package linking flags"
374 # endif
375
376 #endif
377 }
378
379 /*---------------------------------------------
380 STATIC_PACKAGES code only...
381
382 Declare the functions which we are expected to be able to call.
383 */
384 #ifndef NO_PACKAGES
385 # ifdef STATIC_PACKAGES
386
387 #include <packages/kvalues.h>
388 #include <packages/bisect.h>
389 #include <packages/sensitivity.h>
390
391 # endif
392 #endif
393
394 #ifdef STATIC_PACKAGES
395 /**
396 Load all statically-linked packages
397
398 @return 0 on success, >0 if any CreateUserFunction calls failed.
399 */
400 static int StaticPackages_Init(void){
401 int result = 0;
402
403 result += sensitivity_register();
404 result += kvalues_register();
405
406 return result;
407 }
408 #endif
409
410 /**
411 This is a general purpose function that will load whatever user
412 functions are required according to the compile-time settings.
413
414 If NO_PACKAGES, nothing will be loaded. If DYNAMIC_PACKAGES, then
415 just the builtin packages will be loaded. If STATIC_PACKAGES then
416 builtin plus those called in 'StaticPackages_Init' will be loaded.
417 */
418 void AddUserFunctions(void)
419 {
420 #ifdef NO_PACKAGES
421 # ifdef __GNUC__
422 # warning "EXTERNAL PACKAGES ARE BEING DISABLED"
423 # endif
424 ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"AddUserFunctions disabled at compile-time.");
425 #else
426
427 /* Builtins are always statically linked */
428 if (Builtins_Init()) {
429 ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in Builtins_Init: Some user functions not created");
430 }
431
432 # ifdef DYNAMIC_PACKAGES
433 /* do nothing */
434
435 # elif defined(STATIC_PACKAGES)
436 # ifdef __GNUC__
437 # warning "STATIC PACKAGES"
438 # endif
439
440 /*The following need to be reimplemented but are basically useful as is. */
441 if (StaticPackages_Init()) {
442 ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in StaticPackages_Init(): Some user functions not created");
443 }
444
445 # endif
446 #endif
447 }
448
449 /*---------------------------------------
450 TESTING FUNCTIONS
451
452 The following functions may be called someone desirous of testing
453 an external relation provided as a package. They are here
454 for convenience, and should be really in a separate file.
455 */
456
457 /**
458 Get the real values of each struct Instance pointed to in the gl_list
459 'arglist' and put it into the 'inputs' array of doubles.
460
461 For example, use this to evaluate the input arguments for a Black Box relation.
462 */
463 static void LoadInputVector(struct gl_list_t *arglist,
464 double *inputs,
465 unsigned ninputs,
466 unsigned long n_input_args
467 ){
468 struct Instance *inst;
469 struct gl_list_t *input_list;
470 unsigned long c,len;
471
472 input_list = LinearizeArgList(arglist,1,n_input_args);
473
474 if(!input_list)return;
475
476 len = gl_length(input_list);
477
478 if(len!=ninputs)return; /* somehow we had inconsistent data */
479
480 for (c=1;c<=len;c++) {
481 inst = (struct Instance *)gl_fetch(input_list,c);
482 inputs[c-1] = RealAtomValue(inst);
483 }
484 gl_destroy(input_list);
485 }
486
487 /**
488 What's a black box, and what's a glass box? -- JP
489 See Abbott thesis. - baa
490 This function is, of course, a mess.
491
492 This seems to be duplicated over in rel.c as ExtRel_Evaluate_RHS.
493 */
494 int CallBlackBox(struct Instance *inst,
495 CONST struct relation *rel)
496 {
497 struct Instance *data;
498
499 struct Slv_Interp slv_interp;
500 struct ExternalFunc *efunc;
501 struct ExtCallNode *ext;
502 struct gl_list_t *arglist;
503 unsigned long n_input_args, n_output_args;
504 int nok = 0;
505
506 unsigned long ninputs, noutputs;
507 double *inputs = NULL, *outputs = NULL;
508 double *jacobian = NULL;
509
510 ExtBBoxInitFunc *init_func;
511 ExtBBoxInitFunc *final_func;
512 ExtBBoxFunc *eval_func;
513 ExtBBoxFunc *deriv_func;
514
515 UNUSED_PARAMETER(inst);
516
517 ext = BlackBoxExtCall(rel);
518 arglist = ExternalCallArgList(ext);
519 data = ExternalCallDataInstance(ext);
520 efunc = ExternalCallExtFunc(ext);
521 init_func = GetInitFunc(efunc);
522 final_func = GetFinalFunc(efunc);
523 eval_func = GetValueFunc(efunc);
524 deriv_func = GetDerivFunc(efunc);
525
526 if (init_func && eval_func) {
527
528 /* set up the interpreter. */
529 Init_Slv_Interp(&slv_interp);
530 /*
531 slv_interp.check_args = (unsigned)1;
532 slv_interp.first_call = (unsigned)1;
533 slv_interp.last_call = (unsigned)0;
534 */
535 slv_interp.nodestamp = ExternalCallNodeStamp(ext);
536 n_input_args = NumberInputArgs(efunc);
537 n_output_args = NumberOutputArgs(efunc);
538 ninputs = CountNumberOfArgs(arglist,1,n_input_args);
539 noutputs = CountNumberOfArgs(arglist,n_input_args + 1,
540 n_input_args+n_output_args);
541
542 /* Create the work vectors. Load the input vector from the instance tree. */
543 inputs = ASC_NEW_ARRAY_CLEAR(double,ninputs);
544 outputs = ASC_NEW_ARRAY_CLEAR(double,ninputs);
545 jacobian = ASC_NEW_ARRAY_CLEAR(double,ninputs*noutputs);
546 LoadInputVector(arglist,inputs,ninputs,n_input_args);
547
548 /*
549 * Call the init function.
550 */
551 slv_interp.task = bb_first_call;
552 nok = (*init_func)(&slv_interp,data,arglist);
553 if (nok) goto error;
554 /*
555 * Call the evaluation function.
556 */
557 slv_interp.task = bb_func_eval;
558 nok = (*eval_func)(&slv_interp,ninputs,noutputs,
559 inputs,outputs,jacobian);
560 if (nok) goto error;
561 /*
562 * Call the derivative routine.
563 */
564 if (deriv_func) {
565 slv_interp.task = bb_deriv_eval;
566 nok = (*deriv_func)(&slv_interp,ninputs,noutputs,
567 inputs,outputs,jacobian);
568 if (nok) goto error;
569 }
570 /*
571 * Call the init function to shut down
572 */
573 if (final_func) {
574 /*
575 slv_interp.first_call = (unsigned)0;
576 slv_interp.last_call = (unsigned)1;
577 */
578 slv_interp.task = bb_last_call;
579 nok = (*final_func)(&slv_interp,data,arglist);
580 if (nok) goto error;
581 }
582 }
583 else{
584 FPRINTF(ASCERR,"External function not loaded\n");
585 return 1;
586 }
587
588 error:
589 if (inputs) ascfree((char *)inputs);
590 if (outputs) ascfree((char *)outputs);
591 if (jacobian) ascfree((char *)outputs);
592 if (nok)
593 return 1;
594 else
595 return 0;
596 }
597
598 /**
599 When glassbox are registered, they must register a pointer
600 to their function jump table. In other words, they must
601 register a pointer to an 'array of pointers to functions'.
602 This typedef just makes life a little cleaner.
603
604 <-- what typedef?? -- JP
605 */
606 int CallGlassBox(struct Instance *relinst, CONST struct relation *rel)
607 {
608 CONST struct gl_list_t *incidence;
609 struct Instance *var;
610 struct ExternalFunc *efunc;
611 int index;
612 long i;
613 double *f, *x, *g;
614 int m,mode,result;
615 int n;
616
617 ExtEvalFunc **evaltable, *eval_func;
618 ExtEvalFunc **derivtable, *deriv_func;
619
620 (void) relinst;
621 incidence = RelationVarList(rel);
622 if (!incidence) {
623 FPRINTF(ASCERR,"Incidence list is empty -- nothing to evaluate\n");
624 return 0;
625 }
626 index = GlassBoxRelIndex(rel);
627 efunc = GlassBoxExtFunc(rel);
628 evaltable = GetValueJumpTable(efunc);
629 eval_func = evaltable[index];
630 derivtable = GetDerivJumpTable(efunc);
631 deriv_func = derivtable[index];
632
633 m = 0; /* FIX not sure what this should be !!! */
634 n = gl_length(incidence);
635 f = ASC_NEW_ARRAY_CLEAR(double,1 + 2*n);
636 x = &f[1];
637 g = &f[n+1];
638
639 for (i=0;i<n;i++) {
640 var = (struct Instance *)gl_fetch(incidence,i+1);
641 x[i] = RealAtomValue(var);
642 }
643 result = (*eval_func)(&mode,&m,&n,x,NULL,f,g);
644 result += (*deriv_func)(&mode,&m,&n,x,NULL,f,g);
645
646 ascfree((char *)f);
647 return result;
648 }
649
650 /**
651 No idea what this does. It's referenced in 'interface.c' only, so it
652 appears to be defunct -- JP
653 */
654 int CallExternalProcs(struct Instance *inst)
655 {
656 CONST struct relation *rel;
657 enum Expr_enum reltype;
658
659 if (inst==NULL){
660 FPRINTF(ASCERR,"Instance does not exist for callprocs\n");
661 return 1;
662 }
663 if (InstanceKind(inst)!=REL_INST){
664 FPRINTF(ASCERR,"Instance is not a relation\n");
665 return 1;
666 }
667 rel = GetInstanceRelation(inst,&reltype);
668 if (!rel) {
669 FPRINTF(ASCERR,"Relation structure is NULL\n");
670 return 1;
671 }
672 switch (reltype) {
673 case e_blackbox:
674 return CallBlackBox(inst,rel);
675 case e_glassbox:
676 return CallGlassBox(inst,rel);
677 default:
678 FPRINTF(ASCERR,"Invalid relation type in CallExternalProc\n");
679 return 1;
680 }
681 }

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