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

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