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