generic/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.
*//**
    @file
    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.
*//*
    by Kirk Abbott
    Created: July 4, 1994
    Last in 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 <utilities/config.h> /* NEW */

#ifndef ASC_DEFAULTPATH
# error "Where is ASC_DEFAULTPATH???"
#endif

#include <general/ospath.h>

#include "compiler.h"
#include <utilities/ascMalloc.h>
#include <utilities/ascEnvVar.h>
#include <utilities/ascDynaLoad.h>
#include <general/list.h>
#include "symtab.h"
#include "fractions.h"
#include "dimen.h"
#include "functype.h"
#include "expr_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->task = bb_none;
/*
    slv_interp->first_call = (unsigned)0; // gone away
    slv_interp->last_call = (unsigned)0; // gone away
    slv_interp->check_args = (unsigned)0; // gone away
    slv_interp->recalculate = (unsigned)0; // gone away
    slv_interp->func_eval = (unsigned)0; // gone away
    slv_interp->deriv_eval = (unsigned)0; // gone away
    slv_interp->single_step = (unsigned)0; // gone away
*/
  }
}

/*---------------------------------------------
  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("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;
}

int LoadArchiveLibrary(CONST char *partialname, CONST char *initfunc){

#ifdef DYNAMIC_PACKAGES
    char *file;
    char auto_initfunc[PATH_MAX];
    char *stem;
    struct FilePath *fp1;
    int result;

    CONSOLE_DEBUG("Searching for external library '%s'",partialname);

    file = SearchArchiveLibraryPath(partialname, ASC_DEFAULTPATH, PATHENVIRONMENTVAR);
    if(file==NULL){
        ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"External library '%s' not found.",partialname);
        return 1;
    }

    fp1 = ospath_new_from_posix(partialname);
    stem = ospath_getfilestem(fp1);
    if(stem==NULL){
        ERROR_REPORTER_NOLINE(ASC_PROG_ERROR,"What is the stem of named library '%s'???",partialname);
        free(stem);
        ospath_free(fp1);
        return 1;
    }

    if(initfunc==NULL){
        strncpy(auto_initfunc,stem,PATH_MAX);
        strncat(auto_initfunc,"_register",PATH_MAX-strlen(auto_initfunc));
        result = Asc_DynamicLoad(file,auto_initfunc);
    }else{
        result = Asc_DynamicLoad(file,initfunc);
    }

    if(result){
        CONSOLE_DEBUG("FAILED TO LOAD LIBRARY '%s' (error %d)",partialname,result);
        result = 1;
    }else{
        if(initfunc==NULL){
            CONSOLE_DEBUG("Successfully ran '%s' from dynamic package '%s'",auto_initfunc,file);
        }else{
            CONSOLE_DEBUG("Successfully ran '%s' from dynamic package '%s'",initfunc,file);
        }
    }

    free(stem);
    ospath_free(fp1);
    return result;

#else

    DISUSED_PARAMETER(name); DISUSED_PARAMETER(initfunc);

# if defined(STATIC_PACKAGES)
    ERROR_REPORTER_HERE(ASC_PROG_NOTE,"LoadArchiveLibrary disabled: STATIC_PACKAGES, no need to load dynamically.\n");
    return 0;
# elif defined(NO_PACKAGES)
    ERROR_REPORTER_HERE(ASC_PROG_ERROR,"LoadArchiveLibrary disabled: NO_PACKAGES");
    return 1;
# else
#  error "Invalid package linking flags"
# endif

#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;

  result += sensitivity_register();
  result += kvalues_register();

  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.
*/

/**
    Get the real values of each struct Instance pointed to in the gl_list
    'arglist' and put it into the 'inputs' array of doubles.

    For example, use this to evaluate the input arguments for a Black Box relation.
*/
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
    See Abbott thesis. - baa
    This function is, of course, a mess.

    This seems to be duplicated over in rel.c as ExtRel_Evaluate_RHS.
*/
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;

  ExtBBoxInitFunc *init_func;
  ExtBBoxInitFunc *final_func;
  ExtBBoxFunc *eval_func;
  ExtBBoxFunc *deriv_func;

  UNUSED_PARAMETER(inst);

  ext = BlackBoxExtCall(rel);
  arglist = ExternalCallArgList(ext);
  data = ExternalCallDataInstance(ext);
  efunc = ExternalCallExtFunc(ext);
  init_func = GetInitFunc(efunc);
  final_func = GetFinalFunc(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 = ASC_NEW_ARRAY_CLEAR(double,ninputs);
    outputs = ASC_NEW_ARRAY_CLEAR(double,ninputs);
    jacobian = ASC_NEW_ARRAY_CLEAR(double,ninputs*noutputs);
    LoadInputVector(arglist,inputs,ninputs,n_input_args);

    /*
     * Call the init function.
     */
    slv_interp.task = bb_first_call;
    nok = (*init_func)(&slv_interp,data,arglist);
    if (nok) goto error;
    /*
     * Call the evaluation function.
     */
    slv_interp.task = bb_func_eval;
    nok = (*eval_func)(&slv_interp,ninputs,noutputs,
               inputs,outputs,jacobian);
    if (nok) goto error;
    /*
     * Call the derivative routine.
     */
    if (deriv_func) {
      slv_interp.task = bb_deriv_eval;
      nok = (*deriv_func)(&slv_interp,ninputs,noutputs,
              inputs,outputs,jacobian);
      if (nok) goto error;
    }
    /*
     * Call the init function to shut down
     */
    if (final_func) {
/*
      slv_interp.first_call = (unsigned)0;
      slv_interp.last_call = (unsigned)1;
 */
      slv_interp.task = bb_last_call;
      nok = (*final_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 = ASC_NEW_ARRAY_CLEAR(double,1 + 2*n);
  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	/* 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("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	int LoadArchiveLibrary(CONST char partialname, CONST char initfunc){
124
125	#ifdef DYNAMIC_PACKAGES
126	char *file;
127	char auto_initfunc[PATH_MAX];
128	char *stem;
129	struct FilePath *fp1;
130	int result;
131
132	CONSOLE_DEBUG("Searching for external library '%s'",partialname);
133
134	file = SearchArchiveLibraryPath(partialname, ASC_DEFAULTPATH, PATHENVIRONMENTVAR);
135	if(file==NULL){
136	ERROR_REPORTER_NOLINE(ASC_USER_ERROR,"External library '%s' not found.",partialname);
137	return 1;
138	}
139
140	fp1 = ospath_new_from_posix(partialname);
141	stem = ospath_getfilestem(fp1);
142	if(stem==NULL){
143	ERROR_REPORTER_NOLINE(ASC_PROG_ERROR,"What is the stem of named library '%s'???",partialname);
144	free(stem);
145	ospath_free(fp1);
146	return 1;
147	}
148
149	if(initfunc==NULL){
150	strncpy(auto_initfunc,stem,PATH_MAX);
151	strncat(auto_initfunc,"_register",PATH_MAX-strlen(auto_initfunc));
152	result = Asc_DynamicLoad(file,auto_initfunc);
153	}else{
154	result = Asc_DynamicLoad(file,initfunc);
155	}
156
157	if(result){
158	CONSOLE_DEBUG("FAILED TO LOAD LIBRARY '%s' (error %d)",partialname,result);
159	result = 1;
160	}else{
161	if(initfunc==NULL){
162	CONSOLE_DEBUG("Successfully ran '%s' from dynamic package '%s'",auto_initfunc,file);
163	}else{
164	CONSOLE_DEBUG("Successfully ran '%s' from dynamic package '%s'",initfunc,file);
165	}
166	}
167
168	free(stem);
169	ospath_free(fp1);
170	return result;
171
172	#else
173
174	DISUSED_PARAMETER(name); DISUSED_PARAMETER(initfunc);
175
176	# if defined(STATIC_PACKAGES)
177	ERROR_REPORTER_HERE(ASC_PROG_NOTE,"LoadArchiveLibrary disabled: STATIC_PACKAGES, no need to load dynamically.\n");
178	return 0;
179	# elif defined(NO_PACKAGES)
180	ERROR_REPORTER_HERE(ASC_PROG_ERROR,"LoadArchiveLibrary disabled: NO_PACKAGES");
181	return 1;
182	# else
183	# error "Invalid package linking flags"
184	# endif
185
186	#endif
187	}
188
189	/*---------------------------------------------
190	STATIC_PACKAGES code only...
191
192	Declare the functions which we are expected to be able to call.
193	*/
194	#ifndef NO_PACKAGES
195	# ifdef STATIC_PACKAGES
196
197	#include <packages/kvalues.h>
198	#include <packages/bisect.h>
199	#include <packages/sensitivity.h>
200
201	# endif
202	#endif
203
204	#ifdef STATIC_PACKAGES
205	/**
206	Load all statically-linked packages
207
208	@return 0 on success, >0 if any CreateUserFunction calls failed.
209	*/
210	static int StaticPackages_Init(void){
211	int result = 0;
212
213	result += sensitivity_register();
214	result += kvalues_register();
215
216	return result;
217	}
218	#endif
219
220	/**
221	This is a general purpose function that will load whatever user
222	functions are required according to the compile-time settings.
223
224	If NO_PACKAGES, nothing will be loaded. If DYNAMIC_PACKAGES, then
225	just the builtin packages will be loaded. If STATIC_PACKAGES then
226	builtin plus those called in 'StaticPackages_Init' will be loaded.
227	*/
228	void AddUserFunctions(void)
229	{
230	#ifdef NO_PACKAGES
231	# ifdef __GNUC__
232	# warning "EXTERNAL PACKAGES ARE BEING DISABLED"
233	# endif
234	ERROR_REPORTER_NOLINE(ASC_PROG_NOTE,"AddUserFunctions disabled at compile-time.");
235	#else
236
237	/* Builtins are always statically linked */
238	if (Builtins_Init()) {
239	ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in Builtins_Init: Some user functions not created");
240	}
241
242	# ifdef DYNAMIC_PACKAGES
243	/* do nothing */
244
245	# elif defined(STATIC_PACKAGES)
246	# ifdef __GNUC__
247	# warning "STATIC PACKAGES"
248	# endif
249
250	/The following need to be reimplemented but are basically useful as is. /
251	if (StaticPackages_Init()) {
252	ERROR_REPORTER_NOLINE(ASC_PROG_WARNING,"Problem in StaticPackages_Init(): Some user functions not created");
253	}
254
255	# endif
256	#endif
257	}
258
259	/*---------------------------------------
260	TESTING FUNCTIONS
261
262	The following functions may be called someone desirous of testing
263	an external relation provided as a package. They are here
264	for convenience, and should be really in a separate file.
265	*/
266
267	/**
268	Get the real values of each struct Instance pointed to in the gl_list
269	'arglist' and put it into the 'inputs' array of doubles.
270
271	For example, use this to evaluate the input arguments for a Black Box relation.
272	*/
273	static void LoadInputVector(struct gl_list_t *arglist,
274	double *inputs,
275	unsigned ninputs,
276	unsigned long n_input_args
277	){
278	struct Instance *inst;
279	struct gl_list_t *input_list;
280	unsigned long c,len;
281
282	input_list = LinearizeArgList(arglist,1,n_input_args);
283
284	if(!input_list)return;
285
286	len = gl_length(input_list);
287
288	if(len!=ninputs)return; /* somehow we had inconsistent data */
289
290	for (c=1;c<=len;c++) {
291	inst = (struct Instance *)gl_fetch(input_list,c);
292	inputs[c-1] = RealAtomValue(inst);
293	}
294	gl_destroy(input_list);
295	}
296
297	/**
298	What's a black box, and what's a glass box? -- JP
299	See Abbott thesis. - baa
300	This function is, of course, a mess.
301
302	This seems to be duplicated over in rel.c as ExtRel_Evaluate_RHS.
303	*/
304	int CallBlackBox(struct Instance *inst,
305	CONST struct relation *rel)
306	{
307	struct Instance *data;
308
309	struct Slv_Interp slv_interp;
310	struct ExternalFunc *efunc;
311	struct ExtCallNode *ext;
312	struct gl_list_t *arglist;
313	unsigned long n_input_args, n_output_args;
314	int nok = 0;
315
316	unsigned long ninputs, noutputs;
317	double inputs = NULL, outputs = NULL;
318	double *jacobian = NULL;
319
320	ExtBBoxInitFunc *init_func;
321	ExtBBoxInitFunc *final_func;
322	ExtBBoxFunc *eval_func;
323	ExtBBoxFunc *deriv_func;
324
325	UNUSED_PARAMETER(inst);
326
327	ext = BlackBoxExtCall(rel);
328	arglist = ExternalCallArgList(ext);
329	data = ExternalCallDataInstance(ext);
330	efunc = ExternalCallExtFunc(ext);
331	init_func = GetInitFunc(efunc);
332	final_func = GetFinalFunc(efunc);
333	eval_func = GetValueFunc(efunc);
334	deriv_func = GetDerivFunc(efunc);
335
336	if (init_func && eval_func) {
337
338	/* set up the interpreter. */
339	Init_Slv_Interp(&slv_interp);
340	/*
341	slv_interp.check_args = (unsigned)1;
342	slv_interp.first_call = (unsigned)1;
343	slv_interp.last_call = (unsigned)0;
344	*/
345	slv_interp.nodestamp = ExternalCallNodeStamp(ext);
346	n_input_args = NumberInputArgs(efunc);
347	n_output_args = NumberOutputArgs(efunc);
348	ninputs = CountNumberOfArgs(arglist,1,n_input_args);
349	noutputs = CountNumberOfArgs(arglist,n_input_args + 1,
350	n_input_args+n_output_args);
351
352	/* Create the work vectors. Load the input vector from the instance tree. */
353	inputs = ASC_NEW_ARRAY_CLEAR(double,ninputs);
354	outputs = ASC_NEW_ARRAY_CLEAR(double,ninputs);
355	jacobian = ASC_NEW_ARRAY_CLEAR(double,ninputs*noutputs);
356	LoadInputVector(arglist,inputs,ninputs,n_input_args);
357
358	/*
359	* Call the init function.
360	*/
361	slv_interp.task = bb_first_call;
362	nok = (*init_func)(&slv_interp,data,arglist);
363	if (nok) goto error;
364	/*
365	* Call the evaluation function.
366	*/
367	slv_interp.task = bb_func_eval;
368	nok = (*eval_func)(&slv_interp,ninputs,noutputs,
369	inputs,outputs,jacobian);
370	if (nok) goto error;
371	/*
372	* Call the derivative routine.
373	*/
374	if (deriv_func) {
375	slv_interp.task = bb_deriv_eval;
376	nok = (*deriv_func)(&slv_interp,ninputs,noutputs,
377	inputs,outputs,jacobian);
378	if (nok) goto error;
379	}
380	/*
381	* Call the init function to shut down
382	*/
383	if (final_func) {
384	/*
385	slv_interp.first_call = (unsigned)0;
386	slv_interp.last_call = (unsigned)1;
387	*/
388	slv_interp.task = bb_last_call;
389	nok = (*final_func)(&slv_interp,data,arglist);
390	if (nok) goto error;
391	}
392	}
393	else{
394	FPRINTF(ASCERR,"External function not loaded\n");
395	return 1;
396	}
397
398	error:
399	if (inputs) ascfree((char *)inputs);
400	if (outputs) ascfree((char *)outputs);
401	if (jacobian) ascfree((char *)outputs);
402	if (nok)
403	return 1;
404	else
405	return 0;
406	}
407
408	/**
409	When glassbox are registered, they must register a pointer
410	to their function jump table. In other words, they must
411	register a pointer to an 'array of pointers to functions'.
412	This typedef just makes life a little cleaner.
413
414	<-- what typedef?? -- JP
415	*/
416	int CallGlassBox(struct Instance relinst, CONST struct relation rel)
417	{
418	CONST struct gl_list_t *incidence;
419	struct Instance *var;
420	struct ExternalFunc *efunc;
421	int index;
422	long i;
423	double f, x, *g;
424	int m,mode,result;
425	int n;
426
427	ExtEvalFunc *evaltable, eval_func;
428	ExtEvalFunc *derivtable, deriv_func;
429
430	(void) relinst;
431	incidence = RelationVarList(rel);
432	if (!incidence) {
433	FPRINTF(ASCERR,"Incidence list is empty -- nothing to evaluate\n");
434	return 0;
435	}
436	index = GlassBoxRelIndex(rel);
437	efunc = GlassBoxExtFunc(rel);
438	evaltable = GetValueJumpTable(efunc);
439	eval_func = evaltable[index];
440	derivtable = GetDerivJumpTable(efunc);
441	deriv_func = derivtable[index];
442
443	m = 0; /* FIX not sure what this should be !!! */
444	n = gl_length(incidence);
445	f = ASC_NEW_ARRAY_CLEAR(double,1 + 2*n);
446	x = &f[1];
447	g = &f[n+1];
448
449	for (i=0;i<n;i++) {
450	var = (struct Instance *)gl_fetch(incidence,i+1);
451	x[i] = RealAtomValue(var);
452	}
453	result = (*eval_func)(&mode,&m,&n,x,NULL,f,g);
454	result += (*deriv_func)(&mode,&m,&n,x,NULL,f,g);
455
456	ascfree((char *)f);
457	return result;
458	}
459
460	/**
461	No idea what this does. It's referenced in 'interface.c' only, so it
462	appears to be defunct -- JP
463	*/
464	int CallExternalProcs(struct Instance *inst)
465	{
466	CONST struct relation *rel;
467	enum Expr_enum reltype;
468
469	if (inst==NULL){
470	FPRINTF(ASCERR,"Instance does not exist for callprocs\n");
471	return 1;
472	}
473	if (InstanceKind(inst)!=REL_INST){
474	FPRINTF(ASCERR,"Instance is not a relation\n");
475	return 1;
476	}
477	rel = GetInstanceRelation(inst,&reltype);
478	if (!rel) {
479	FPRINTF(ASCERR,"Relation structure is NULL\n");
480	return 1;
481	}
482	switch (reltype) {
483	case e_blackbox:
484	return CallBlackBox(inst,rel);
485	case e_glassbox:
486	return CallGlassBox(inst,rel);
487	default:
488	FPRINTF(ASCERR,"Invalid relation type in CallExternalProc\n");
489	return 1;
490	}
491	}