void exec() throw( general_error )
{
double I = as_double("I");
double T = as_double("T");
util::matrix_t<double> data = as_matrix("input");
util::matrix_t<double> par = as_matrix("param");
if ( data.ncols() != DATACOLS )
throw general_error( util::format("input matrix must have 6 columns (Irr, Tc, Pmp, Vmp, Voc, Isc), but is %d x %d",
(int)data.nrows(), (int)data.ncols() ) );
if ( par.ncols() != PARCOLS )
throw general_error( util::format("parameter matrix must have 5 columns (Il, Io, Rs, Rsh, a), but is %d x %d",
(int)par.nrows(), (int)par.ncols() ) );
if ( par.nrows() != data.nrows() || data.nrows() < 3 )
throw general_error( "input and parameter matrices must have same number of rows, and at least 3" );
bool quiet = false;
if ( is_assigned( "quiet" ) )
quiet = true;
assign( "a", var_data((ssc_number_t) interpolate( data, par, I, T, A, quiet ) ) );
assign("Il", var_data((ssc_number_t)interpolate(data, par, I, T, IL, quiet)));
assign("Io", var_data((ssc_number_t)interpolate(data, par, I, T, IO, quiet)));
assign("Rs", var_data((ssc_number_t)interpolate(data, par, I, T, RS, quiet)));
assign("Rsh", var_data((ssc_number_t)interpolate(data, par, I, T, RSH, quiet)));
}
/* Allocates memory */
void factor_vm::memory_signal_handler_impl() {
if (code->safepoint_p(signal_fault_addr)) {
safepoint.handle_safepoint(this, signal_fault_pc);
}
else {
vm_error_type type = ctx->address_to_error(signal_fault_addr);
cell number = from_unsigned_cell(signal_fault_addr);
general_error(type, number, false_object);
}
if (!signal_resumable) {
/* In theory we should only get here if the callstack overflowed during a
safepoint */
general_error(ERROR_CALLSTACK_OVERFLOW, false_object, false_object);
}
}
void memory_protection_error(cell addr, stack_frame *native_stack)
{
if(in_page(addr, ds_bot, 0, -1))
general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
else if(in_page(addr, ds_bot, ds_size, 0))
general_error(ERROR_DS_OVERFLOW,F,F,native_stack);
else if(in_page(addr, rs_bot, 0, -1))
general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
else if(in_page(addr, rs_bot, rs_size, 0))
general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
else if(in_page(addr, nursery.end, 0, 0))
critical_error("allot_object() missed GC check",0);
else
general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
}
static void handle_globl(char *s)
{
char *name;
symbol *sym;
for (;;) {
if (!(name = parse_identifier(&s))) {
syntax_error(10); /* identifier expected */
return;
}
sym = new_import(name);
myfree(name);
if (sym->flags & EXPORT)
general_error(62,sym->name,get_bind_name(sym)); /* binding already set */
sym->flags |= EXPORT;
s = skip(s);
if (*s == ',')
s = skip(s+1);
else
break;
}
eol(s);
}
FILE *locate_file(char *filename,char *mode)
{
char pathbuf[MAXPATHLEN];
struct include_path *ipath;
FILE *f;
if (*filename=='.' || *filename=='/' || *filename=='\\' ||
strchr(filename,':')!=NULL) {
/* file name is absolute, then don't use any include paths */
if (f = fopen(filename,mode))
return f;
}
else {
/* locate file name in all known include paths */
for (ipath=first_incpath; ipath; ipath=ipath->next) {
if (strlen(ipath->path) + strlen(filename) + 1 <= MAXPATHLEN) {
strcpy(pathbuf,ipath->path);
strcat(pathbuf,filename);
if (f = fopen(pathbuf,mode))
return f;
}
}
}
general_error(12,filename);
return NULL;
}
static taddr dooffset(int rel,expr *tree,section *sec,taddr pc,rlist **relocs,int roffset,int size,taddr mask)
{
taddr val;
if(!eval_expr(tree,&val,sec,pc)){
taddr addend=val;
symbol *base;
if(find_base(tree,&base,sec,pc)!=BASE_OK){
general_error(38);
return val;
}
if(rel==REL_PC){
val-=pc;
addend+=roffset/8;
}
if(rel!=REL_PC||!LOCREF(base)||base->sec!=sec){
add_nreloc_masked(relocs,base,addend,rel,size,roffset,mask);
return 0;
}
}
#if 0
if(val<-(1<<(size-1))||val>((1<<(size-1))-1))
cpu_error(1,size);
#endif
return val&mask;
}
base_element_block* element_block_func_base::clone_block(const base_element_block& block)
{
switch (get_block_type(block))
{
case element_type_numeric:
return numeric_element_block::clone_block(block);
case element_type_string:
return string_element_block::clone_block(block);
case element_type_short:
return short_element_block::clone_block(block);
case element_type_ushort:
return ushort_element_block::clone_block(block);
case element_type_int:
return int_element_block::clone_block(block);
case element_type_uint:
return uint_element_block::clone_block(block);
case element_type_long:
return long_element_block::clone_block(block);
case element_type_ulong:
return ulong_element_block::clone_block(block);
case element_type_boolean:
return boolean_element_block::clone_block(block);
case element_type_char:
return char_element_block::clone_block(block);
case element_type_uchar:
return uchar_element_block::clone_block(block);
default:
throw general_error("clone_block: failed to clone a block of unknown type.");
}
}
static void handle_section(char *s)
{
char *name,*attr,*new,*p;
uint32_t mem=0;
section *sec;
if(!(name=parse_name(&s))){
syntax_error(20); /* section name */
return;
}
if(*s==','){
s=skip(s+1);
if(*s!='\"')
general_error(6,'\"'); /* quote expected */
if(attr=parse_name(&s)){
if(*s==','){
p=s=skip(s+1);
if(*s=='@'||*s=='%'){
/* ELF section type "progbits" or "nobits" */
s++;
if(new=parse_identifier(&s)){
if(!strcmp(new,"nobits")){
myfree(new);
if(strchr(attr,'u')==NULL){
new=mymalloc(strlen(attr)+2);
sprintf(new,"u%s",attr);
myfree(attr);
attr=new;
}
}else{
if(strcmp(new,"progbits"))
syntax_error(14); /* invalid sectiont type ignored */
myfree(new);
}
}
base_element_block* element_block_func_base::create_new_block(element_t type, size_t init_size)
{
switch (type)
{
case element_type_numeric:
return numeric_element_block::create_block(init_size);
case element_type_string:
return string_element_block::create_block(init_size);
case element_type_short:
return short_element_block::create_block(init_size);
case element_type_ushort:
return ushort_element_block::create_block(init_size);
case element_type_int:
return int_element_block::create_block(init_size);
case element_type_uint:
return uint_element_block::create_block(init_size);
case element_type_long:
return long_element_block::create_block(init_size);
case element_type_ulong:
return ulong_element_block::create_block(init_size);
case element_type_boolean:
return boolean_element_block::create_block(init_size);
case element_type_char:
return char_element_block::create_block(init_size);
case element_type_uchar:
return uchar_element_block::create_block(init_size);
default:
throw general_error("create_new_block: failed to create a new block of unknown type.");
}
}
void *calloc_(size_t n, size_t size, char *file, int line)
{
errno = 0;
void *tmp = calloc(n, size);
if (!tmp)
general_error(file, line, "calloc fail");
return tmp;
}
cell factor_vm::retainstack_to_array(context* ctx) {
cell array = stack_to_array(ctx->retainstack_seg->start, ctx->retainstack);
if (array == false_object) {
general_error(ERROR_RETAINSTACK_UNDERFLOW, false_object, false_object);
return false_object;
} else
return array;
}
void *realloc_(void *ptr, size_t size,char *file, int line)
{
errno = 0;
void *tmp = realloc(ptr, size);
if (!tmp)
general_error(file, line, "realloc fail");
return tmp;
}
static void undef_syms(void)
{
symbol *sym;
for(sym=first_symbol; sym; sym=sym->next) {
if (sym->type==IMPORT&&!(sym->flags&(EXPORT|COMMON|WEAK)))
general_error(22,sym->name);
}
}
void ffi_dlclose(F_DLL *dll)
{
if(dlclose(dll->dll))
{
general_error(ERROR_FFI,tag_object(
from_char_string(dlerror())),F,NULL);
}
dll->dll = NULL;
}
inline cell factor_vm::unbox_array_size() {
cell obj = ctx->pop();
fixnum n = to_fixnum_strict(obj);
if (n >= 0 && n < (fixnum)array_size_max) {
return n;
}
general_error(ERROR_ARRAY_SIZE, obj, tag_fixnum(array_size_max));
return 0; /* can't happen */
}
void factor_vm::move_file(const vm_char* path1, const vm_char* path2) {
int ret = 0;
do {
ret = rename((path1), (path2));
} while (ret < 0 && errno == EINTR);
if (ret < 0)
general_error(ERROR_IO, tag_fixnum(errno), false_object);
}
static taddr comma_constexpr(char **s)
{
*s = skip(*s);
if (**s == ',') {
*s = skip(*s + 1);
return parse_constexpr(s);
}
general_error(6,','); /* comma expected */
return 0;
}
void io_error(void)
{
#ifndef WINCE
if(errno == EINTR)
return;
#endif
CELL error = tag_object(from_char_string(strerror(errno)));
general_error(ERROR_IO,error,F,NULL);
}
/* Allocates memory */
cell factor_vm::stack_to_array(cell bottom, cell top, vm_error_type error) {
fixnum depth = (fixnum)(top - bottom + sizeof(cell));
if (depth < 0) {
general_error(error, false_object, false_object);
}
array* a = allot_uninitialized_array<array>(depth / sizeof(cell));
memcpy(a + 1, (void*)bottom, depth);
return tag<array>(a);
}
static void
cmd_undo(void)
{
if (is_force_mode) {
if (revert() != 0)
general_error();
reset_engine(current_position());
debug_engine_set_player_to_move(turn());
}
}
void factor_vm::memory_signal_handler_impl()
{
memory_protection_error(signal_fault_pc, signal_fault_addr);
if (!signal_resumable)
{
/* In theory we should only get here if the callstack overflowed during a
safepoint */
general_error(ERROR_CALLSTACK_OVERFLOW,false_object,false_object);
}
}
/* References to undefined symbols are patched up to call this function on
image load. It finds the symbol and library, and throws an error. */
void factor_vm::undefined_symbol()
{
void *frame = ctx->callstack_top;
void *return_address = frame_return_address(frame);
code_block *compiled = code->code_block_for_address((cell)return_address);
find_symbol_at_address_visitor visitor(this, (cell)return_address);
compiled->each_instruction_operand(visitor);
if (!to_boolean(visitor.symbol))
critical_error("Can't find RT_DLSYM at return address", (cell)return_address);
else
general_error(ERROR_UNDEFINED_SYMBOL,visitor.symbol,visitor.library);
}
static void dontwarn(struct err_out *err,int errnum,int first,int max)
{
int n = errnum-first;
if (n>=0 && n<max) {
if (err[n].flags & WARNING) {
err[n].flags |= DONTWARN;
return;
}
}
general_error(33,errnum);
}
static int do_cond(char **s)
{
expr *condexp = parse_expr_tmplab(s);
taddr val;
if (!eval_expr(condexp,&val,NULL,0)) {
general_error(30); /* expression must be constant */
val = 0;
}
free_expr(condexp);
return val != 0;
}
/* References to undefined symbols are patched up to call this function on
image load. It finds the symbol and library, and throws an error. */
void factor_vm::undefined_symbol()
{
stack_frame *frame = innermost_stack_frame(ctx->callstack_bottom,
ctx->callstack_top);
code_block *compiled = frame_code(frame);
cell return_address = (cell)FRAME_RETURN_ADDRESS(frame, this);
find_symbol_at_address_visitor visitor(this, return_address);
compiled->each_instruction_operand(visitor);
if (!to_boolean(visitor.symbol))
critical_error("Can't find RT_DLSYM at return address", return_address);
else
general_error(ERROR_UNDEFINED_SYMBOL,visitor.symbol,visitor.library);
}
int check_symbol(char *name)
/* issue an error when symbol is already defined in the current source */
{
symbol *sym;
if (sym = find_symbol(name)) {
if (sym->type != IMPORT) {
general_error(67,name); /* repeatedly defined symbol */
return 1;
}
}
return 0;
}
void memory_protection_error(CELL addr, F_STACK_FRAME *native_stack)
{
if(in_page(addr, ds_bot, 0, -1))
general_error(ERROR_DS_UNDERFLOW,F,F,native_stack);
else if(in_page(addr, ds_bot, ds_size, 0))
general_error(ERROR_DS_OVERFLOW,F,F,native_stack);
else if(in_page(addr, rs_bot, 0, -1))
general_error(ERROR_RS_UNDERFLOW,F,F,native_stack);
else if(in_page(addr, rs_bot, rs_size, 0))
general_error(ERROR_RS_OVERFLOW,F,F,native_stack);
else if(in_page(addr, nursery.end, 0, 0))
critical_error("allot_object() missed GC check",0);
else if(in_page(addr, gc_locals_region->start, 0, -1))
critical_error("gc locals underflow",0);
else if(in_page(addr, gc_locals_region->end, 0, 0))
critical_error("gc locals overflow",0);
else if(in_page(addr, extra_roots_region->start, 0, -1))
critical_error("extra roots underflow",0);
else if(in_page(addr, extra_roots_region->end, 0, 0))
critical_error("extra roots overflow",0);
else
general_error(ERROR_MEMORY,allot_cell(addr),F,native_stack);
}
static void
cmd_redo(void)
{
mtx_lock(&game_mutex);
if (is_force_mode) {
if (forward() != 0)
general_error();
reset_engine(current_position());
debug_engine_set_player_to_move(turn());
}
mtx_unlock(&game_mutex);
}
static void resolve_section(section *sec)
{
atom *p;
int done,pass=0;
taddr size;
do {
done=1;
if (++pass>=MAXPASSES) {
general_error(7,sec->name);
break;
}
if(DEBUG)
printf("resolve_section(%s) pass %d\n",sec->name,pass);
sec->pc=sec->org;
for(p=sec->first; p; p=p->next) {
sec->pc=(sec->pc+p->align-1)/p->align*p->align;
cur_src=p->src;
cur_src->line=p->line;
#ifdef HAVE_CPU_OPTS
if(p->type==OPTS) {
cpu_opts(p->content.opts);
}
else
#endif
if(p->type==LABEL) {
symbol *label=p->content.label;
if(label->type!=LABSYM)
ierror(0);
if(label->pc!=sec->pc) {
if(DEBUG)
printf("changing label %s from %lu to %lu\n",label->name,
(unsigned long)label->pc,(unsigned long)sec->pc);
done=0;
label->pc=sec->pc;
}
}
size=atom_size(p,sec,sec->pc);
#ifdef CHECK_ATOMSIZE
if(size!=p->lastsize) {
if(DEBUG)
printf("changed size of atom type %d at %lu from %ld to %ld\n",
p->type,(unsigned long)sec->pc,(long)p->lastsize,(long)size);
done=0;
p->lastsize=size;
}
#endif
sec->pc+=size;
}
} while(errors==0&&!done);
}
/* switches current section to the section with the specified name */
void switch_section(char *name,char *attr)
{
section *p;
if(unnamed_sections)
name=emptystr;
p=find_section(name,attr);
if(!p)
general_error(2,name);
else
current_section=p;
#ifdef HAVE_CPU_OPTS
cpu_opts_init(p); /* set initial cpu opts before the first atom */
#endif
}