ascend/compiler/packages.c

/*  ASCEND modelling environment
    Copyright (C) 1990, 1993, 1994 Thomas Guthrie Epperly, Kirk Abbott.
    Copyright (C) 2006 Carnegie Mellon University

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2, or (at your option)
    any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place - Suite 330,
    Boston, MA 02111-1307, USA.
*//**
    Code to support dynamic and static loading of user packages.

    The default state is to have packages. As such it takes an explicit
    definition of NO_PACKAGES, if packages are not to be handled.
    An explicit definition of STATIC_PACKAGES or DYNAMIC_PACKAGES is also
    required.
*//*
    User Packages
    by Kirk Abbott
    Created: July 4, 1994
    Last rev in old CVS: 1.14 ballan 1998/03/06 15:47:14
*/

#if !defined(DYNAMIC_PACKAGES) && !defined(STATIC_PACKAGES) && !defined(NO_PACKAGES)
# error "Package linking option not set!"
#endif

#include <math.h>
#include <ctype.h>  /* was compiler/actype.h */
#include <utilities/ascConfig.h>
#include "compiler.h"
#include <utilities/ascMalloc.h>
#include <general/list.h>
#include "symtab.h"
#include "fractions.h"
#include "dimen.h"
#include "functype.h"
#include "types.h"
#include "extcall.h"
#include "mathinst.h"
#include "instance_enum.h"
#include "instquery.h"
#include "atomvalue.h"
#include "find.h"
#include "relation_type.h"
#include "relation.h"
#include "safe.h"
#include "relation_util.h"
#include "extfunc.h"
#include <packages/sensitivity.h>
#include <packages/ascFreeAllVars.h>
#include "module.h"
#include "packages.h"

/*
    Initialise the slv data structures used when calling external fns
*/
void Init_Slv_Interp(struct Slv_Interp *slv_interp)
{
  if (slv_interp){
    slv_interp->nodestamp = 0;
    slv_interp->status = calc_all_ok;
    slv_interp->user_data = NULL;
    slv_interp->first_call = (unsigned)0;
    slv_interp->last_call = (unsigned)0;
    slv_interp->check_args = (unsigned)0;
    slv_interp->recalculate = (unsigned)0;
    slv_interp->func_eval = (unsigned)0;
    slv_interp->deriv_eval = (unsigned)0;
    slv_interp->single_step = (unsigned)0;
  }
}

/*
    @deprecated, @see packages.h
*/
symchar *MakeArchiveLibraryName(CONST char *prefix){
    char *buffer;
    int len;
    symchar *result;

    len = strlen(prefix);
    buffer = (char *)ascmalloc(len+40);

#if defined(ASC_SHLIBSUFFIX) && defined(ASC_SHLIBPREFIX)
    sprintf(buffer,"%s%s%s",ASC_SHLIBPREFIX,prefix,ASC_SHLIBSUFFIX);
#else
# ifdef __WIN32__
    sprintf(buffer,"%s.dll",prefix);
# elif defined(linux)
    sprintf(buffer,"lib%s.so",prefix); /* changed from .o to .so -- JP */
# elif defined(sun) || defined(solaris)
    sprintf(buffer,"%s.so.1.0",prefix);
# elif defined(__hpux)
    sprintf(buffer,"%s.sl",prefix);
# elif defined(_SGI_SOURCE)
    sprintf(buffer,"%s.so",prefix);
# else
#   error "Please #define ASC_SHLIBSUFFIX and ASC_SHLIBPREFIX or pass as compiler flags to packages.c"
# endif
#endif

    result = AddSymbol(buffer); /* the main symbol table */
    ascfree(buffer);
    return result;              /* owns the string */
}

/*---------------------------------------------
  BUILT-IN PACKAGES...
*/

/**
    Load builtin packages, unless NO_PACKAGES.

    @return 0 if success, 1 if failure.
*/
static
int Builtins_Init(void)
{
  int result = 0;

#ifdef NO_PACKAGES
  ERROR_REPORTER_HERE(ASC_USER_WARNING,"Builtins_Init: DISABLED at compile-time");
#else
  ERROR_REPORTER_DEBUG("Builtins_Init: Loading function asc_free_all_variables\n");
  result = CreateUserFunctionMethod("asc_free_all_variables",
            Asc_FreeAllVars,
            1,
         "Unset 'fixed' flag of all items of type 'solver_var'");
#endif
  return result;
}

/*---------------------------------------------
  DYNAMIC_PACKAGES code only...
*/
# ifdef DYNAMIC_PACKAGES
static char path_var[PATH_MAX];

/**
    Search the archive library path for a file matching the given
    (platform specific, with extension?) library filename.

    @return a pointer to a string space holding the full path
    name of the file to be opened. The returned pointer may be NULL

    @TODO won't work correctly on windows
    @deprecated { see packages.h }
*/
static
char *SearchArchiveLibraryPath(CONST char *name, char *dpath, char *envv)
{
  register char *path,*result;
  register CONST char *t;
  register unsigned length;
  register FILE *f;
  /* ERROR_REPORTER_HERE(ASC_PROG_NOTE,"Env var for user packages is '%s'\n",envv); */
  /* ERROR_REPORTER_HERE(ASC_PROG_NOTE,"Search path for user packages is '%s'\n",getenv(envv)); */
  if ((path=getenv(envv))==NULL)
    path=dpath;
  while(isspace(*path)) path++;
  while(*path!='\0'){
    if (*path==':') path++;
    else{
      length = 0;
      /* copy next directory into array */
      while((*path!=':')&&(*path!='\0')&&(!isspace(*path)))
        path_var[length++] = *(path++);
      if (path_var[length-1]!='/')
        path_var[length++]='/';

      /* copy file name into array */
      for(t=name;*t!='\0';){
        path_var[length++] = *(t++);
      }
      path_var[length]='\0';

      /* ERROR_REPORTER_HERE(ASC_PROG_NOTE,"Searching for for '%s' at '%s'\n",name, path_var); */

      if ((f= fopen(path_var,"r"))!=NULL){
        result = path_var;
        fclose(f);
        return result;
      }
    }
    while(isspace(*path)) path++;
  }
  return NULL;
}
#endif /* DYNAMIC_PACKAGES */
/*
  END of DYNAMIC_PACKAGES-specific code
  ------------------------------------------*/

int LoadArchiveLibrary(CONST char *name, CONST char *initfunc)
{
#ifdef NO_PACKAGES
  /** avoid compiler warnings on params: */
  (void) name; (void) initfunc;

  ERROR_REPORTER_HERE(ASC_PROG_ERROR,"LoadArchiveLibrary disabled: NO_PACKAGES");
  return 1;

#elif defined(DYNAMIC_PACKAGES)

  symchar *name_with_extn;

  int result;
  char *default_path = ".";
  char *env = PATHENVIRONMENTVAR;
  char *full_file_name = NULL;
  extern int Asc_DynamicLoad(CONST char *,CONST char *);

  char initfunc_generated_name[255];

  name_with_extn = MakeArchiveLibraryName(name);

  full_file_name = SearchArchiveLibraryPath(SCP(name_with_extn),default_path,env);
  if (!full_file_name) {
    ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"The named library '%s' was not found in the search path.",name_with_extn);
    return 1;
  }

  if(initfunc==NULL){
    CONSOLE_DEBUG("GENERATING NAME OF INITFUNC");
    CONSOLE_DEBUG("NAME STEM = %s",name);
    sprintf(initfunc_generated_name,"%s",name);
    strcat(initfunc_generated_name,"_register");
    CONSOLE_DEBUG("GENERATED NAME = %s",initfunc_generated_name);
    result = Asc_DynamicLoad(full_file_name,initfunc_generated_name);
  }else{
    result = Asc_DynamicLoad(full_file_name,initfunc);
  }

  if (result) {
    return 1;
  }
  if(initfunc==NULL){
    ERROR_REPORTER_DEBUG("Successfully ran '%s' from dynamic package '%s'\n",initfunc_generated_name,name);
  }else{
    ERROR_REPORTER_DEBUG("Successfully ran '%s' from dynamic package '%s'\n",initfunc,name);
  }
  return 0;

#elif defined(STATIC_PACKAGES)

  /* avoid compiler warnings on params: */
  (void) name; (void) initfunc;

  ERROR_REPORTER_HERE(ASC_PROG_NOTE,"LoadArchiveLibrary disabled: STATIC_PACKAGES, no need to load dynamically.\n");
  return 0;

#else /* unknown flags */

# error "Invalid package linking flags"
  (void) name; (void) initfunc;
  return 1;

#endif
}

/*---------------------------------------------
  STATIC_PACKAGES code only...

  Declare the functions which we are expected to be able to call.
*/
#ifndef NO_PACKAGES
# ifdef STATIC_PACKAGES

#include <packages/kvalues.h>
#include <packages/bisect.h>
#include <packages/sensitivity.h>

# endif
#endif

#ifdef STATIC_PACKAGES
/**
    Load all statically-linked packages

    @return 0 on success, >0 if any CreateUserFunction calls failed.
*/
static
int StaticPackages_Init(void)
{
  int result = 0;

  char sensitivity_help[] =
    "This function does sensitivity analysis dy/dx. It requires 4 args:\n"
    "  1. name: name of a reference instance or SELF.\n"
    "  2. x: x, where x is an array of > solver_var.\n"
    "  3. y: where y is an array of > solver_var.\n"
    "  4. dy/dx: which dy_dx[1..n_y][1..n_x].";

  result = CreateUserFunctionMethod("do_solve",
                  do_solve_eval,
                  2,NULL); /* was 2,0,null */
  result += CreateUserFunctionMethod("do_finite_difference",
                   do_finite_diff_eval,
                   4,NULL); /* 4,0,null */
  result += CreateUserFunctionMethod("do_sensitivity",
                   do_sensitivity_eval,
                   4,sensitivity_help);
  result += CreateUserFunctionMethod("do_sensitivity_all",
                   do_sensitivity_eval_all,
                   4,"See do_sensitivity_eval for details");

  result += KValues_Init();

  return result;
}
#endif

/**
    This is a general purpose function that will load whatever user
    functions are required according to the compile-time settings.

    If NO_PACKAGES, nothing will be loaded. If DYNAMIC_PACKAGES, then
    just the builtin packages will be loaded. If STATIC_PACKAGES then
    builtin plus those called in 'StaticPackages_Init' will be loaded.
*/
void AddUserFunctions(void)
{
#ifdef NO_PACKAGES
# ifdef __GNUC__
#  warning "EXTERNAL PACKAGES ARE BEING DISABLED"
# endif
  ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"AddUserFunctions disabled at compile-time.");
#else

  /* Builtins are always statically linked */
  if (Builtins_Init()) {
      ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in Builtins_Init: Some user functions not created");
  }

# ifdef DYNAMIC_PACKAGES
  /* do nothing */

# elif defined(STATIC_PACKAGES)
#  ifdef __GNUC__
#   warning "STATIC PACKAGES"
#  endif

  /*The following need to be reimplemented but are basically useful as is. */
  if (StaticPackages_Init()) {
      ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in StaticPackages_Init(): Some user functions not created");
  }

# endif
#endif
}

/*---------------------------------------
    TESTING FUNCTIONS

    The following functions may be called someone desirous of testing
    an external relation provided as a package. They are here
    for convenience, and should be really in a separate file.
*/

/**
    What's this do? -- JP
*/
static void LoadInputVector(struct gl_list_t *arglist,
                double *inputs,
                unsigned ninputs,
                unsigned long n_input_args)
{
  struct Instance *inst;
  struct gl_list_t *input_list;
  unsigned long c,len;

  input_list = LinearizeArgList(arglist,1,n_input_args);

  if(!input_list)return;

  len = gl_length(input_list);

  if(len!=ninputs)return; /* somehow we had inconsistent data */

  for (c=1;c<=len;c++) {
    inst = (struct Instance *)gl_fetch(input_list,c);
    inputs[c-1] = RealAtomValue(inst);
  }
  gl_destroy(input_list);
}

/**
    What's a black box, and what's a glass box? -- JP
*/
int CallBlackBox(struct Instance *inst,
         CONST struct relation *rel)
{
  struct Instance *data;

  struct Slv_Interp slv_interp;
  struct ExternalFunc *efunc;
  struct ExtCallNode *ext;
  struct gl_list_t *arglist;
  unsigned long n_input_args, n_output_args;
  int nok = 0;

  unsigned long ninputs, noutputs;
  double *inputs = NULL, *outputs = NULL;
  double *jacobian = NULL;

  /* All these desperately need a typedef in a header someplace */
/*  now typedefs in solver/extfunc.h - 1/22/2006 - jds
  int (*init_func) (struct Slv_Interp *,
                    struct Instance *,
                    struct gl_list_t *);

  int (*eval_func)(struct Slv_Interp *,
                   int,         // n_inputs
                   int,         // n_outputs
                   double *,    // inputs
                   double * ,   // outputs
                   double * );  // jacobian

  int (*deriv_func)(struct Slv_Interp *,
                   int,         // n_inputs
                   int ,        // n_outputs
                   double *,    // inputs
                   double * ,   // outputs
                   double * );  // jacobian
*/
  ExtBBoxInitFunc *init_func;
  ExtBBoxFunc *eval_func;
  ExtBBoxFunc *deriv_func;

/*------------------------------
    After this point everything should be ok.
    <-- says who? when? -- JP
*/

  /* Visual C doesn't like this before the func ptr defs. */
  UNUSED_PARAMETER(inst);

  ext = BlackBoxExtCall(rel);
  arglist = ExternalCallArgList(ext);
  data = ExternalCallDataInstance(ext);
  efunc = ExternalCallExtFunc(ext);
  init_func = GetInitFunc(efunc);
  eval_func = GetValueFunc(efunc);
  deriv_func = GetDerivFunc(efunc);

  if (init_func && eval_func) {

    /* set up the interpreter. */
    Init_Slv_Interp(&slv_interp);
    slv_interp.check_args = (unsigned)1;
    slv_interp.first_call = (unsigned)1;
    slv_interp.last_call = (unsigned)0;
    slv_interp.nodestamp = ExternalCallNodeStamp(ext);
    n_input_args = NumberInputArgs(efunc);
    n_output_args = NumberOutputArgs(efunc);
    ninputs = CountNumberOfArgs(arglist,1,n_input_args);
    noutputs = CountNumberOfArgs(arglist,n_input_args + 1,
                 n_input_args+n_output_args);

    /* Create the work vectors. Load the input vector from the instance tree. */
    inputs = (double *)asccalloc(ninputs,sizeof(double));
    outputs = (double *)asccalloc(ninputs,sizeof(double));
    jacobian = (double *)asccalloc(ninputs*noutputs,sizeof(double));
    LoadInputVector(arglist,inputs,ninputs,n_input_args);

    /*
     * Call the init function.
     */
    nok = (*init_func)(&slv_interp,data,arglist);
    if (nok) goto error;
    /*
     * Call the evaluation function.
     */
    nok = (*eval_func)(&slv_interp,ninputs,noutputs,
               inputs,outputs,jacobian);
    if (nok) goto error;
    /*
     * Call the derivative routine.
     */
    if (deriv_func) {
      nok = (*deriv_func)(&slv_interp,ninputs,noutputs,
              inputs,outputs,jacobian);
      if (nok) goto error;
    }
    /*
     * Call the init function to shut down
     */
    slv_interp.first_call = (unsigned)0;
    slv_interp.last_call = (unsigned)1;
    nok = (*init_func)(&slv_interp,data,arglist);
    if (nok) goto error;
  }
  else{
    FPRINTF(ASCERR,"External function not loaded\n");
    return 1;
  }

 error:
  if (inputs) ascfree((char *)inputs);
  if (outputs) ascfree((char *)outputs);
  if (jacobian) ascfree((char *)outputs);
  if (nok)
    return 1;
  else
    return 0;
}

/**
    When glassbox are registered, they must register a pointer
    to their function jump table. In other words, they must
    register a pointer to an 'array of pointers to functions'.
    This typedef just makes life a little cleaner.

    <-- what typedef?? -- JP
*/
int CallGlassBox(struct Instance *relinst, CONST struct relation *rel)
{
  CONST struct gl_list_t *incidence;
  struct Instance *var;
  struct ExternalFunc *efunc;
  int index;
  long i;
  double *f, *x, *g;
  int m,mode,result;
  int n;

  ExtEvalFunc **evaltable, *eval_func;
  ExtEvalFunc **derivtable, *deriv_func;

  (void) relinst;
  incidence = RelationVarList(rel);
  if (!incidence) {
    FPRINTF(ASCERR,"Incidence list is empty -- nothing to evaluate\n");
    return 0;
  }
  index = GlassBoxRelIndex(rel);
  efunc = GlassBoxExtFunc(rel);
  evaltable = GetValueJumpTable(efunc);
  eval_func = evaltable[index];
  derivtable = GetDerivJumpTable(efunc);
  deriv_func = derivtable[index];

  m = 0;              /* FIX not sure what this should be !!! */
  n = gl_length(incidence);
  f = (double *)asccalloc((1 + 2*n),sizeof(double));
  x = &f[1];
  g = &f[n+1];

  for (i=0;i<n;i++) {
    var = (struct Instance *)gl_fetch(incidence,i+1);
    x[i] = RealAtomValue(var);
  }
  result = (*eval_func)(&mode,&m,&n,x,NULL,f,g);
  result += (*deriv_func)(&mode,&m,&n,x,NULL,f,g);

  ascfree((char *)f);
  return result;
}

/**
    No idea what this does. It's referenced in 'interface.c' only, so it
    appears to be defunct -- JP
*/
int CallExternalProcs(struct Instance *inst)
{
  CONST struct relation *rel;
  enum Expr_enum reltype;

  if (inst==NULL){
    FPRINTF(ASCERR,"Instance does not exist for callprocs\n");
    return 1;
  }
  if (InstanceKind(inst)!=REL_INST){
    FPRINTF(ASCERR,"Instance is not a relation\n");
    return 1;
  }
  rel = GetInstanceRelation(inst,&reltype);
  if (!rel) {
    FPRINTF(ASCERR,"Relation structure is NULL\n");
    return 1;
  }
  switch (reltype) {
  case e_blackbox:
    return CallBlackBox(inst,rel);
  case e_glassbox:
    return CallGlassBox(inst,rel);
  default:
    FPRINTF(ASCERR,"Invalid relation type in CallExternalProc\n");
    return 1;
  }
}
1	johnpye	529	/* ASCEND modelling environment
2			Copyright (C) 1990, 1993, 1994 Thomas Guthrie Epperly, Kirk Abbott.
3			Copyright (C) 2006 Carnegie Mellon University
4	aw0a	1
5	johnpye	529	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	johnpye	62	Code to support dynamic and static loading of user packages.
21
22			The default state is to have packages. As such it takes an explicit
23			definition of NO_PACKAGES, if packages are not to be handled.
24			An explicit definition of STATIC_PACKAGES or DYNAMIC_PACKAGES is also
25			required.
26	johnpye	529	//
27			User Packages
28			by Kirk Abbott
29			Created: July 4, 1994
30			Last rev in old CVS: 1.14 ballan 1998/03/06 15:47:14
31	johnpye	62	*/
32	johnpye	529
33	johnpye	427	#if !defined(DYNAMIC_PACKAGES) && !defined(STATIC_PACKAGES) && !defined(NO_PACKAGES)
34			# error "Package linking option not set!"
35	johnpye	381	#endif
36
37	aw0a	1	#include <math.h>
38			#include <ctype.h> /* was compiler/actype.h */
39	johnpye	399	#include <utilities/ascConfig.h>
40			#include "compiler.h"
41			#include <utilities/ascMalloc.h>
42			#include <general/list.h>
43			#include "symtab.h"
44			#include "fractions.h"
45			#include "dimen.h"
46			#include "functype.h"
47			#include "types.h"
48			#include "extcall.h"
49			#include "mathinst.h"
50			#include "instance_enum.h"
51			#include "instquery.h"
52			#include "atomvalue.h"
53			#include "find.h"
54			#include "relation_type.h"
55			#include "relation.h"
56			#include "safe.h"
57			#include "relation_util.h"
58			#include "extfunc.h"
59			#include <packages/sensitivity.h>
60			#include <packages/ascFreeAllVars.h>
61			#include "module.h"
62			#include "packages.h"
63	aw0a	1
64	johnpye	62	/*
65			Initialise the slv data structures used when calling external fns
66			*/
67	aw0a	1	void Init_Slv_Interp(struct Slv_Interp *slv_interp)
68			{
69			if (slv_interp){
70			slv_interp->nodestamp = 0;
71			slv_interp->status = calc_all_ok;
72			slv_interp->user_data = NULL;
73			slv_interp->first_call = (unsigned)0;
74			slv_interp->last_call = (unsigned)0;
75			slv_interp->check_args = (unsigned)0;
76			slv_interp->recalculate = (unsigned)0;
77			slv_interp->func_eval = (unsigned)0;
78			slv_interp->deriv_eval = (unsigned)0;
79			slv_interp->single_step = (unsigned)0;
80			}
81			}
82
83	johnpye	62	/*
84			@deprecated, @see packages.h
85			*/
86	johnpye	508	symchar MakeArchiveLibraryName(CONST char prefix){
87			char *buffer;
88			int len;
89			symchar *result;
90	aw0a	1
91	johnpye	508	len = strlen(prefix);
92			buffer = (char *)ascmalloc(len+40);
93	johnpye	62
94	johnpye	508	#if defined(ASC_SHLIBSUFFIX) && defined(ASC_SHLIBPREFIX)
95	johnpye	529	sprintf(buffer,"%s%s%s",ASC_SHLIBPREFIX,prefix,ASC_SHLIBSUFFIX);
96	aw0a	1	#else
97	johnpye	508	# ifdef __WIN32__
98			sprintf(buffer,"%s.dll",prefix);
99			# elif defined(linux)
100	wangym	512	sprintf(buffer,"lib%s.so",prefix); /* changed from .o to .so -- JP */
101	johnpye	508	# elif defined(sun) \|\| defined(solaris)
102			sprintf(buffer,"%s.so.1.0",prefix);
103			# elif defined(__hpux)
104			sprintf(buffer,"%s.sl",prefix);
105			# elif defined(_SGI_SOURCE)
106			sprintf(buffer,"%s.so",prefix);
107			# else
108	wangym	512	# error "Please #define ASC_SHLIBSUFFIX and ASC_SHLIBPREFIX or pass as compiler flags to packages.c"
109	johnpye	508	# endif
110	aw0a	1	#endif
111
112	johnpye	508	result = AddSymbol(buffer); /* the main symbol table */
113			ascfree(buffer);
114			return result; /* owns the string */
115	aw0a	1	}
116
117	johnpye	62	/*---------------------------------------------
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	johnpye	190	ERROR_REPORTER_HERE(ASC_USER_WARNING,"Builtins_Init: DISABLED at compile-time");
133	johnpye	62	#else
134			ERROR_REPORTER_DEBUG("Builtins_Init: Loading function asc_free_all_variables\n");
135	ben.allan	467	result = CreateUserFunctionMethod("asc_free_all_variables",
136			Asc_FreeAllVars,
137			1,
138			"Unset 'fixed' flag of all items of type 'solver_var'");
139	johnpye	62	#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	johnpye	371	/* 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	johnpye	371	/* ERROR_REPORTER_HERE(ASC_PROG_NOTE,"Searching for for '%s' at '%s'\n",name, path_var); */
188	johnpye	369
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	johnpye	380	symchar *name_with_extn;
216
217	aw0a	1	int result;
218			char *default_path = ".";
219			char *env = PATHENVIRONMENTVAR;
220			char *full_file_name = NULL;
221	jds	129	extern int Asc_DynamicLoad(CONST char ,CONST char );
222	aw0a	1
223	johnpye	380	char initfunc_generated_name[255];
224
225	wangym	394	name_with_extn = MakeArchiveLibraryName(name);
226
227	ben.allan	407	full_file_name = SearchArchiveLibraryPath(SCP(name_with_extn),default_path,env);
228	aw0a	1	if (!full_file_name) {
229	johnpye	529	ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"The named library '%s' was not found in the search path.",name_with_extn);
230	aw0a	1	return 1;
231			}
232	johnpye	380
233			if(initfunc==NULL){
234			CONSOLE_DEBUG("GENERATING NAME OF INITFUNC");
235			CONSOLE_DEBUG("NAME STEM = %s",name);
236	johnpye	381	sprintf(initfunc_generated_name,"%s",name);
237	johnpye	380	strcat(initfunc_generated_name,"_register");
238	johnpye	381	CONSOLE_DEBUG("GENERATED NAME = %s",initfunc_generated_name);
239	johnpye	380	result = Asc_DynamicLoad(full_file_name,initfunc_generated_name);
240			}else{
241			result = Asc_DynamicLoad(full_file_name,initfunc);
242			}
243
244	aw0a	1	if (result) {
245			return 1;
246			}
247	johnpye	381	if(initfunc==NULL){
248			ERROR_REPORTER_DEBUG("Successfully ran '%s' from dynamic package '%s'\n",initfunc_generated_name,name);
249			}else{
250			ERROR_REPORTER_DEBUG("Successfully ran '%s' from dynamic package '%s'\n",initfunc,name);
251			}
252	johnpye	62	return 0;
253
254			#elif defined(STATIC_PACKAGES)
255
256			/* avoid compiler warnings on params: */
257	aw0a	1	(void) name; (void) initfunc;
258	johnpye	62
259	johnpye	303	ERROR_REPORTER_HERE(ASC_PROG_NOTE,"LoadArchiveLibrary disabled: STATIC_PACKAGES, no need to load dynamically.\n");
260	aw0a	1	return 0;
261	johnpye	62
262			#else /* unknown flags */
263
264			# error "Invalid package linking flags"
265			(void) name; (void) initfunc;
266	aw0a	1	return 1;
267	johnpye	62
268	aw0a	1	#endif
269			}
270
271	johnpye	62	/*---------------------------------------------
272			STATIC_PACKAGES code only...
273	aw0a	1
274	johnpye	62	Declare the functions which we are expected to be able to call.
275			*/
276			#ifndef NO_PACKAGES
277			# ifdef STATIC_PACKAGES
278
279	ben.allan	467	#include <packages/kvalues.h>
280			#include <packages/bisect.h>
281			#include <packages/sensitivity.h>
282	aw0a	1
283	johnpye	62	# endif
284	aw0a	1	#endif
285
286	johnpye	62	#ifdef STATIC_PACKAGES
287			/**
288			Load all statically-linked packages
289	aw0a	1
290	johnpye	62	@return 0 on success, >0 if any CreateUserFunction calls failed.
291			*/
292	aw0a	1	static
293	johnpye	62	int StaticPackages_Init(void)
294	aw0a	1	{
295			int result = 0;
296	jds	54
297	aw0a	1	char sensitivity_help[] =
298	johnpye	194	"This function does sensitivity analysis dy/dx. It requires 4 args:\n"
299			" 1. name: name of a reference instance or SELF.\n"
300			" 2. x: x, where x is an array of > solver_var.\n"
301			" 3. y: where y is an array of > solver_var.\n"
302			" 4. dy/dx: which dy_dx[1..n_y][1..n_x].";
303	aw0a	1
304	ben.allan	467	result = CreateUserFunctionMethod("do_solve",
305			do_solve_eval,
306			2,NULL); /* was 2,0,null */
307			result += CreateUserFunctionMethod("do_finite_difference",
308			do_finite_diff_eval,
309			4,NULL); /* 4,0,null */
310			result += CreateUserFunctionMethod("do_sensitivity",
311			do_sensitivity_eval,
312			4,sensitivity_help);
313			result += CreateUserFunctionMethod("do_sensitivity_all",
314			do_sensitivity_eval_all,
315			4,"See do_sensitivity_eval for details");
316	johnpye	62
317	ben.allan	467	result += KValues_Init();
318
319	aw0a	1	return result;
320			}
321	johnpye	62	#endif
322	aw0a	1
323	johnpye	62	/**
324			This is a general purpose function that will load whatever user
325			functions are required according to the compile-time settings.
326	johnpye	190
327	johnpye	62	If NO_PACKAGES, nothing will be loaded. If DYNAMIC_PACKAGES, then
328			just the builtin packages will be loaded. If STATIC_PACKAGES then
329			builtin plus those called in 'StaticPackages_Init' will be loaded.
330			*/
331	aw0a	1	void AddUserFunctions(void)
332			{
333	johnpye	62	#ifdef NO_PACKAGES
334			# ifdef __GNUC__
335			# warning "EXTERNAL PACKAGES ARE BEING DISABLED"
336			# endif
337	johnpye	190	ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"AddUserFunctions disabled at compile-time.");
338	johnpye	62	#else
339	aw0a	1
340	johnpye	62	/* Builtins are always statically linked */
341			if (Builtins_Init()) {
342	johnpye	190	ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in Builtins_Init: Some user functions not created");
343	johnpye	62	}
344	aw0a	1
345	johnpye	62	# ifdef DYNAMIC_PACKAGES
346			/* do nothing */
347	aw0a	1
348	johnpye	62	# elif defined(STATIC_PACKAGES)
349			# ifdef __GNUC__
350	johnpye	89	# warning "STATIC PACKAGES"
351			# endif
352	aw0a	1
353	johnpye	62	/The following need to be reimplemented but are basically useful as is. /
354			if (StaticPackages_Init()) {
355	johnpye	190	ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in StaticPackages_Init(): Some user functions not created");
356	aw0a	1	}
357
358	johnpye	62	# endif
359	aw0a	1	#endif
360			}
361
362	johnpye	62	/*---------------------------------------
363			TESTING FUNCTIONS
364	aw0a	1
365	johnpye	62	The following functions may be called someone desirous of testing
366			an external relation provided as a package. They are here
367			for convenience, and should be really in a separate file.
368			*/
369
370			/**
371			What's this do? -- JP
372			*/
373	aw0a	1	static void LoadInputVector(struct gl_list_t *arglist,
374			double *inputs,
375	johnpye	62	unsigned ninputs,
376	aw0a	1	unsigned long n_input_args)
377			{
378			struct Instance *inst;
379			struct gl_list_t *input_list;
380			unsigned long c,len;
381
382			input_list = LinearizeArgList(arglist,1,n_input_args);
383	johnpye	62
384			if(!input_list)return;
385
386	aw0a	1	len = gl_length(input_list);
387	johnpye	62
388			if(len!=ninputs)return; /* somehow we had inconsistent data */
389
390	aw0a	1	for (c=1;c<=len;c++) {
391			inst = (struct Instance *)gl_fetch(input_list,c);
392			inputs[c-1] = RealAtomValue(inst);
393			}
394			gl_destroy(input_list);
395			}
396
397	johnpye	62	/**
398			What's a black box, and what's a glass box? -- JP
399			*/
400	aw0a	1	int CallBlackBox(struct Instance *inst,
401			CONST struct relation *rel)
402			{
403			struct Instance *data;
404	johnpye	62
405	aw0a	1	struct Slv_Interp slv_interp;
406			struct ExternalFunc *efunc;
407			struct ExtCallNode *ext;
408			struct gl_list_t *arglist;
409			unsigned long n_input_args, n_output_args;
410			int nok = 0;
411
412			unsigned long ninputs, noutputs;
413			double inputs = NULL, outputs = NULL;
414			double *jacobian = NULL;
415
416	johnpye	62	/* All these desperately need a typedef in a header someplace */
417	jds	216	/* now typedefs in solver/extfunc.h - 1/22/2006 - jds
418	aw0a	1	int (init_func) (struct Slv_Interp ,
419			struct Instance *,
420	jds	54	struct gl_list_t *);
421	aw0a	1
422			int (eval_func)(struct Slv_Interp ,
423	jds	216	int, // n_inputs
424	johnpye	369	int, // n_outputs
425			double *, // inputs
426			double * , // outputs
427			double * ); // jacobian
428	aw0a	1
429			int (deriv_func)(struct Slv_Interp ,
430	jds	216	int, // n_inputs
431	johnpye	369	int , // n_outputs
432			double *, // inputs
433			double * , // outputs
434			double * ); // jacobian
435	jds	216	*/
436			ExtBBoxInitFunc *init_func;
437			ExtBBoxFunc *eval_func;
438			ExtBBoxFunc *deriv_func;
439	aw0a	1
440	johnpye	62	/*------------------------------
441			After this point everything should be ok.
442			<-- says who? when? -- JP
443			*/
444	aw0a	1
445	johnpye	62	/* Visual C doesn't like this before the func ptr defs. */
446	johnpye	190	UNUSED_PARAMETER(inst);
447	jds	54
448	aw0a	1	ext = BlackBoxExtCall(rel);
449			arglist = ExternalCallArgList(ext);
450			data = ExternalCallDataInstance(ext);
451			efunc = ExternalCallExtFunc(ext);
452			init_func = GetInitFunc(efunc);
453			eval_func = GetValueFunc(efunc);
454			deriv_func = GetDerivFunc(efunc);
455
456			if (init_func && eval_func) {
457	johnpye	62
458			/* set up the interpreter. */
459	aw0a	1	Init_Slv_Interp(&slv_interp);
460			slv_interp.check_args = (unsigned)1;
461			slv_interp.first_call = (unsigned)1;
462			slv_interp.last_call = (unsigned)0;
463			slv_interp.nodestamp = ExternalCallNodeStamp(ext);
464			n_input_args = NumberInputArgs(efunc);
465			n_output_args = NumberOutputArgs(efunc);
466			ninputs = CountNumberOfArgs(arglist,1,n_input_args);
467			noutputs = CountNumberOfArgs(arglist,n_input_args + 1,
468			n_input_args+n_output_args);
469
470	johnpye	62	/* Create the work vectors. Load the input vector from the instance tree. */
471	aw0a	1	inputs = (double *)asccalloc(ninputs,sizeof(double));
472			outputs = (double *)asccalloc(ninputs,sizeof(double));
473			jacobian = (double )asccalloc(ninputsnoutputs,sizeof(double));
474			LoadInputVector(arglist,inputs,ninputs,n_input_args);
475
476			/*
477			* Call the init function.
478			*/
479			nok = (*init_func)(&slv_interp,data,arglist);
480			if (nok) goto error;
481			/*
482			* Call the evaluation function.
483			*/
484			nok = (*eval_func)(&slv_interp,ninputs,noutputs,
485			inputs,outputs,jacobian);
486			if (nok) goto error;
487			/*
488			* Call the derivative routine.
489			*/
490			if (deriv_func) {
491			nok = (*deriv_func)(&slv_interp,ninputs,noutputs,
492			inputs,outputs,jacobian);
493			if (nok) goto error;
494			}
495			/*
496			* Call the init function to shut down
497			*/
498			slv_interp.first_call = (unsigned)0;
499			slv_interp.last_call = (unsigned)1;
500			nok = (*init_func)(&slv_interp,data,arglist);
501			if (nok) goto error;
502			}
503			else{
504			FPRINTF(ASCERR,"External function not loaded\n");
505			return 1;
506			}
507
508			error:
509			if (inputs) ascfree((char *)inputs);
510			if (outputs) ascfree((char *)outputs);
511			if (jacobian) ascfree((char *)outputs);
512			if (nok)
513			return 1;
514			else
515			return 0;
516			}
517
518	johnpye	62	/**
519			When glassbox are registered, they must register a pointer
520			to their function jump table. In other words, they must
521			register a pointer to an 'array of pointers to functions'.
522			This typedef just makes life a little cleaner.
523	aw0a	1
524	johnpye	62	<-- what typedef?? -- JP
525			*/
526	aw0a	1	int CallGlassBox(struct Instance relinst, CONST struct relation rel)
527			{
528			CONST struct gl_list_t *incidence;
529			struct Instance *var;
530			struct ExternalFunc *efunc;
531			int index;
532	johnpye	89	long i;
533	aw0a	1	double f, x, *g;
534	johnpye	62	int m,mode,result;
535	johnpye	89	int n;
536	aw0a	1
537			ExtEvalFunc *evaltable, eval_func;
538			ExtEvalFunc *derivtable, deriv_func;
539
540			(void) relinst;
541			incidence = RelationVarList(rel);
542			if (!incidence) {
543			FPRINTF(ASCERR,"Incidence list is empty -- nothing to evaluate\n");
544			return 0;
545			}
546			index = GlassBoxRelIndex(rel);
547			efunc = GlassBoxExtFunc(rel);
548			evaltable = GetValueJumpTable(efunc);
549			eval_func = evaltable[index];
550			derivtable = GetDerivJumpTable(efunc);
551			deriv_func = derivtable[index];
552
553			m = 0; /* FIX not sure what this should be !!! */
554	johnpye	62	n = gl_length(incidence);
555	aw0a	1	f = (double )asccalloc((1 + 2n),sizeof(double));
556			x = &f[1];
557			g = &f[n+1];
558
559			for (i=0;i<n;i++) {
560			var = (struct Instance *)gl_fetch(incidence,i+1);
561			x[i] = RealAtomValue(var);
562			}
563			result = (*eval_func)(&mode,&m,&n,x,NULL,f,g);
564			result += (*deriv_func)(&mode,&m,&n,x,NULL,f,g);
565
566			ascfree((char *)f);
567			return result;
568			}
569
570	johnpye	62	/**
571			No idea what this does. It's referenced in 'interface.c' only, so it
572			appears to be defunct -- JP
573			*/
574	aw0a	1	int CallExternalProcs(struct Instance *inst)
575			{
576			CONST struct relation *rel;
577			enum Expr_enum reltype;
578
579			if (inst==NULL){
580			FPRINTF(ASCERR,"Instance does not exist for callprocs\n");
581			return 1;
582			}
583			if (InstanceKind(inst)!=REL_INST){
584			FPRINTF(ASCERR,"Instance is not a relation\n");
585			return 1;
586			}
587			rel = GetInstanceRelation(inst,&reltype);
588			if (!rel) {
589			FPRINTF(ASCERR,"Relation structure is NULL\n");
590			return 1;
591			}
592			switch (reltype) {
593			case e_blackbox:
594			return CallBlackBox(inst,rel);
595			case e_glassbox:
596			return CallGlassBox(inst,rel);
597			default:
598			FPRINTF(ASCERR,"Invalid relation type in CallExternalProc\n");
599			return 1;
600			}
601			}