/[ascend]/trunk/base/generic/compiler/packages.c
ViewVC logotype

Annotation of /trunk/base/generic/compiler/packages.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 369 - (hide annotations) (download) (as text)
Fri Mar 10 09:14:29 2006 UTC (18 years, 4 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 jds 101 /*
2 aw0a 1 * 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 johnpye 62 /**
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 aw0a 1 #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 jds 216 #include "compiler/extfunc.h"
62 aw0a 1 #include "packages/sensitivity.h"
63     #include "packages/ascFreeAllVars.h"
64     #include "compiler/module.h"
65     #include "compiler/packages.h"
66    
67 johnpye 62 /*
68     Initialise the slv data structures used when calling external fns
69     */
70 aw0a 1 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 johnpye 62 /*
87     @deprecated, @see packages.h
88     */
89 aw0a 1 symchar *MakeArchiveLibraryName(CONST char *prefix)
90     {
91     char *buffer;
92     int len;
93     symchar *result;
94    
95     len = strlen(prefix);
96 johnpye 62 buffer = (char *)ascmalloc(len+40);
97    
98 johnpye 158 #if defined(sun) || defined(solaris)
99 aw0a 1 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 johnpye 158 #elif defined(linux)
105 johnpye 62 sprintf(buffer,"lib%s.so",prefix); /* changed from .o to .so -- JP */
106 aw0a 1 #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 johnpye 62 /*---------------------------------------------
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 johnpye 190 ERROR_REPORTER_HERE(ASC_USER_WARNING,"Builtins_Init: DISABLED at compile-time");
131 johnpye 62 #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 aw0a 1 static char path_var[PATH_MAX];
148 johnpye 62
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 aw0a 1 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 johnpye 190 /* 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 aw0a 1 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 johnpye 62 path_var[length++] = *(path++);
178     if (path_var[length-1]!='/')
179     path_var[length++]='/';
180 johnpye 369
181 aw0a 1 /* copy file name into array */
182 johnpye 369 for(t=name;*t!='\0';){
183 aw0a 1 path_var[length++] = *(t++);
184 johnpye 369 }
185 aw0a 1 path_var[length]='\0';
186 johnpye 369
187     ERROR_REPORTER_HERE(ASC_PROG_NOTE,"Searching for for '%s' at '%s'\n",name, path_var);
188    
189 aw0a 1 if ((f= fopen(path_var,"r"))!=NULL){
190 johnpye 369 result = path_var;
191 johnpye 62 fclose(f);
192     return result;
193 aw0a 1 }
194     }
195     while(isspace(*path)) path++;
196     }
197     return NULL;
198     }
199 johnpye 62 #endif /* DYNAMIC_PACKAGES */
200     /*
201     END of DYNAMIC_PACKAGES-specific code
202     ------------------------------------------*/
203 aw0a 1
204     int LoadArchiveLibrary(CONST char *name, CONST char *initfunc)
205     {
206 johnpye 62 #ifdef NO_PACKAGES
207     /** avoid compiler warnings on params: */
208     (void) name; (void) initfunc;
209 aw0a 1
210 johnpye 190 ERROR_REPORTER_HERE(ASC_PROG_ERROR,"LoadArchiveLibrary disabled: NO_PACKAGES");
211 johnpye 62 return 1;
212    
213     #elif defined(DYNAMIC_PACKAGES)
214    
215 aw0a 1 int result;
216     char *default_path = ".";
217     char *env = PATHENVIRONMENTVAR;
218     char *full_file_name = NULL;
219 jds 129 extern int Asc_DynamicLoad(CONST char *,CONST char *);
220 aw0a 1
221     full_file_name = SearchArchiveLibraryPath(name,default_path,env);
222     if (!full_file_name) {
223 johnpye 190 ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"The named library '%s' was not found in the search path",name);
224 aw0a 1 return 1;
225     }
226 jds 129 result = Asc_DynamicLoad(full_file_name,initfunc);
227 aw0a 1 if (result) {
228     return 1;
229     }
230 johnpye 62 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 aw0a 1 (void) name; (void) initfunc;
237 johnpye 62
238 johnpye 303 ERROR_REPORTER_HERE(ASC_PROG_NOTE,"LoadArchiveLibrary disabled: STATIC_PACKAGES, no need to load dynamically.\n");
239 aw0a 1 return 0;
240 johnpye 62
241     #else /* unknown flags */
242    
243     # error "Invalid package linking flags"
244     (void) name; (void) initfunc;
245 aw0a 1 return 1;
246 johnpye 62
247 aw0a 1 #endif
248     }
249    
250 johnpye 62 /*---------------------------------------------
251     STATIC_PACKAGES code only...
252 aw0a 1
253 johnpye 62 Declare the functions which we are expected to be able to call.
254     */
255     #ifndef NO_PACKAGES
256     # ifdef STATIC_PACKAGES
257    
258 aw0a 1 /* kvalues.c */
259 johnpye 62 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 aw0a 1
262     /* bisect.c */
263 johnpye 62 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 aw0a 1
266     /* sensitivity.c */
267 johnpye 62 extern int do_sensitivity_eval(struct Slv_Interp *,struct Instance *, struct gl_list_t *);
268 aw0a 1
269 johnpye 62 # endif
270 aw0a 1 #endif
271    
272 johnpye 62 #ifdef STATIC_PACKAGES
273     /**
274     Load all statically-linked packages
275 aw0a 1
276 johnpye 62 @return 0 on success, >0 if any CreateUserFunction calls failed.
277     */
278 aw0a 1 static
279 johnpye 62 int StaticPackages_Init(void)
280 aw0a 1 {
281     int result = 0;
282 jds 54
283 aw0a 1 char sensitivity_help[] =
284 johnpye 194 "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 aw0a 1
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 johnpye 62
315 aw0a 1 return result;
316     }
317 johnpye 62 #endif
318 aw0a 1
319 johnpye 62 /**
320     This is a general purpose function that will load whatever user
321     functions are required according to the compile-time settings.
322 johnpye 190
323 johnpye 62 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 aw0a 1 void AddUserFunctions(void)
328     {
329 johnpye 62 #ifdef NO_PACKAGES
330     # ifdef __GNUC__
331     # warning "EXTERNAL PACKAGES ARE BEING DISABLED"
332     # endif
333 johnpye 190 ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"AddUserFunctions disabled at compile-time.");
334 johnpye 62 #else
335 aw0a 1
336 johnpye 62 /* Builtins are always statically linked */
337     if (Builtins_Init()) {
338 johnpye 190 ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in Builtins_Init: Some user functions not created");
339 johnpye 62 }
340 aw0a 1
341 johnpye 62 # ifdef DYNAMIC_PACKAGES
342     /* do nothing */
343 aw0a 1
344 johnpye 62 # elif defined(STATIC_PACKAGES)
345     # ifdef __GNUC__
346 johnpye 89 # warning "STATIC PACKAGES"
347     # endif
348 aw0a 1
349 johnpye 62 /*The following need to be reimplemented but are basically useful as is. */
350     if (StaticPackages_Init()) {
351 johnpye 190 ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in StaticPackages_Init(): Some user functions not created");
352 aw0a 1 }
353    
354 johnpye 62 # endif
355 aw0a 1 #endif
356     }
357    
358 johnpye 62 /*---------------------------------------
359     TESTING FUNCTIONS
360 aw0a 1
361 johnpye 62 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 aw0a 1 static void LoadInputVector(struct gl_list_t *arglist,
370     double *inputs,
371 johnpye 62 unsigned ninputs,
372 aw0a 1 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 johnpye 62
380     if(!input_list)return;
381    
382 aw0a 1 len = gl_length(input_list);
383 johnpye 62
384     if(len!=ninputs)return; /* somehow we had inconsistent data */
385    
386 aw0a 1 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 johnpye 62 /**
394     What's a black box, and what's a glass box? -- JP
395     */
396 aw0a 1 int CallBlackBox(struct Instance *inst,
397     CONST struct relation *rel)
398     {
399     struct Instance *data;
400 johnpye 62
401 aw0a 1 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 johnpye 62 /* All these desperately need a typedef in a header someplace */
413 jds 216 /* now typedefs in solver/extfunc.h - 1/22/2006 - jds
414 aw0a 1 int (*init_func) (struct Slv_Interp *,
415     struct Instance *,
416 jds 54 struct gl_list_t *);
417 aw0a 1
418     int (*eval_func)(struct Slv_Interp *,
419 jds 216 int, // n_inputs
420 johnpye 369 int, // n_outputs
421     double *, // inputs
422     double * , // outputs
423     double * ); // jacobian
424 aw0a 1
425     int (*deriv_func)(struct Slv_Interp *,
426 jds 216 int, // n_inputs
427 johnpye 369 int , // n_outputs
428     double *, // inputs
429     double * , // outputs
430     double * ); // jacobian
431 jds 216 */
432     ExtBBoxInitFunc *init_func;
433     ExtBBoxFunc *eval_func;
434     ExtBBoxFunc *deriv_func;
435 aw0a 1
436 johnpye 62 /*------------------------------
437     After this point everything should be ok.
438     <-- says who? when? -- JP
439     */
440 aw0a 1
441 johnpye 62 /* Visual C doesn't like this before the func ptr defs. */
442 johnpye 190 UNUSED_PARAMETER(inst);
443 jds 54
444 aw0a 1 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 johnpye 62
454     /* set up the interpreter. */
455 aw0a 1 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 johnpye 62 /* Create the work vectors. Load the input vector from the instance tree. */
467 aw0a 1 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 johnpye 62 /**
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 aw0a 1
520 johnpye 62 <-- what typedef?? -- JP
521     */
522 aw0a 1 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 johnpye 89 long i;
529 aw0a 1 double *f, *x, *g;
530 johnpye 62 int m,mode,result;
531 johnpye 89 int n;
532 aw0a 1
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 johnpye 62 n = gl_length(incidence);
551 aw0a 1 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 johnpye 62 /**
567     No idea what this does. It's referenced in 'interface.c' only, so it
568     appears to be defunct -- JP
569     */
570 aw0a 1 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