int outOfStack(void *stack, stack_overflow_action how) { GET_LD Stack s = stack; const char *msg = "unhandled stack overflow"; if ( LD->outofstack ) { Sdprintf("[Thread %d]: failed to recover from %s-overflow\n", PL_thread_self(), s->name); print_backtrace_named(msg); save_backtrace("crash"); print_backtrace_named("crash"); fatalError("Sorry, cannot continue"); return FALSE; /* NOTREACHED */ } save_backtrace(msg); LD->trim_stack_requested = TRUE; LD->exception.processing = TRUE; LD->outofstack = stack; switch(how) { case STACK_OVERFLOW_THROW: case STACK_OVERFLOW_RAISE: { fid_t fid; blockGC(0 PASS_LD); if ( (fid=PL_open_foreign_frame()) ) { PL_clearsig(SIG_GC); s->gced_size = 0; /* after handling, all is new */ if ( !PL_unify_term(LD->exception.tmp, PL_FUNCTOR, FUNCTOR_error2, PL_FUNCTOR, FUNCTOR_resource_error1, PL_ATOM, ATOM_stack, PL_CHARS, s->name) ) fatalError("Out of stack inside out-of-stack handler"); if ( how == STACK_OVERFLOW_THROW ) { PL_close_foreign_frame(fid); unblockGC(0 PASS_LD); PL_throw(LD->exception.tmp); warning("Out of %s stack while not in Prolog!?", s->name); assert(0); } else { PL_raise_exception(LD->exception.tmp); } PL_close_foreign_frame(fid); } unblockGC(0 PASS_LD); fail; } } assert(0); fail; }
/************************* * swi_list_length *************************/ int swi_list_length(term_t pl_list) { fid_t frame; predicate_t pr_length; term_t pl_args, pl_length; int length; frame = PL_open_foreign_frame(); pr_length = PL_predicate("length", 2, NULL); pl_args = PL_new_term_refs(2); pl_length = pl_args + 1; length = -1; if (!PL_unify(pl_args, pl_list) || !PL_call_predicate(NULL, PL_Q_NORMAL, pr_length, pl_args)) goto out; PL_get_integer(pl_length, &length); out: PL_discard_foreign_frame(frame); return length; }
static int put_write_options(term_t opts_in, write_options *options) { GET_LD term_t newlist = PL_new_term_ref(); term_t precopt = PL_new_term_ref(); fid_t fid = PL_open_foreign_frame(); term_t head = PL_new_term_ref(); term_t tail = PL_copy_term_ref(opts_in); term_t newhead = PL_new_term_ref(); term_t newtail = PL_copy_term_ref(newlist); int rc = TRUE; while(rc && PL_get_list(tail, head, tail)) { if ( !PL_is_functor(head, FUNCTOR_priority1) ) rc = ( PL_unify_list(newtail, newhead, newtail) && PL_unify(newhead, head) ); } if ( rc ) { rc = ( PL_unify_list(newtail, head, newtail) && PL_unify_functor(head, FUNCTOR_priority1) && PL_get_arg(1, head, precopt) && PL_unify_nil(newtail) ); } if ( rc ) { options->write_options = newlist; options->prec_opt = precopt; } PL_close_foreign_frame(fid); return rc; }
static void call_prolog_goal(prolog_goal *g) { fid_t fid; static predicate_t pred = NULL; int rc; if ( !pred ) pred = PL_predicate("call", 1, "user"); if ( (fid = PL_open_foreign_frame()) ) { term_t t = PL_new_term_ref(); term_t vars; rc = PL_recorded(g->goal, t); PL_erase(g->goal); g->goal = 0; g->state = G_RUNNING; if ( rc ) { qid_t qid; int flags = PL_Q_NORMAL; if ( g->acknowledge ) { flags |= PL_Q_CATCH_EXCEPTION; vars = PL_new_term_ref(); if ( !PL_get_arg(2, t, vars) || /* Goal-Vars */ !PL_get_arg(1, t, t) ) { PL_warning("ERROR: in_pce_thread: bad goal-vars term"); } } else { vars = 0; } if ( (qid = PL_open_query(g->module, flags, pred, t)) ) { rc = PL_next_solution(qid); if ( rc ) { g->state = G_TRUE; if ( vars ) g->result = PL_record(vars); } else { term_t ex; if ( g->acknowledge && (ex=PL_exception(qid)) ) { g->result = PL_record(ex); g->state = G_ERROR; } else { g->state = G_FALSE; } } PL_cut_query(qid); } else PL_warning("ERROR: pce: out of global stack"); } PL_discard_foreign_frame(fid); } else PL_warning("ERROR: pce: out of global stack"); }
static bool call_function(clingo_location_t loc, char const *name, clingo_symbol_t const *in, size_t ilen, void *closure, clingo_symbol_callback_t *cb, void *cb_closure) { (void)loc; (void)closure; static predicate_t pred = 0; fid_t fid = 0; qid_t qid = 0; term_t av; bool rc = true; if (!pred) { pred = PL_predicate("inject_values", 3, "clingo"); } if (!(fid = PL_open_foreign_frame())) { rc = false; clingo_set_error(clingo_error_runtime, "prolog error"); goto out; } av = PL_new_term_refs(3); PL_put_atom_chars(av + 0, name); if (!(rc = unify_list_from_span(av + 1, in, ilen))) { clingo_set_error(clingo_error_runtime, "prolog error"); goto out; } if ((qid = PL_open_query(NULL, PL_Q_PASS_EXCEPTION, pred, av))) { while (PL_next_solution(qid)) { clingo_symbol_t value; if (!(rc = get_value(av + 2, &value, FALSE))) { goto out; } if (!(rc = cb(&value, 1, cb_closure))) { goto out; } } if (PL_exception(0)) { rc = false; clingo_set_error(clingo_error_runtime, "prolog error"); goto out; } } out: if (qid) { PL_close_query(qid); } if (fid) { PL_close_foreign_frame(fid); } return rc; }
int query_loop(atom_t goal, int loop) { GET_LD int rc; int clear_stacks = (LD->query == NULL); do { fid_t fid; qid_t qid = 0; term_t except = 0; predicate_t p; if ( !resetProlog(clear_stacks) ) goto error; if ( !(fid = PL_open_foreign_frame()) ) goto error; p = PL_pred(PL_new_functor(goal, 0), MODULE_system); if ( (qid = PL_open_query(MODULE_system, PL_Q_NORMAL, p, 0)) ) { rc = PL_next_solution(qid); } else { error: except = exception_term; rc = FALSE; /* Won't get any better */ break; } if ( !rc && (except = PL_exception(qid)) ) { atom_t a; tracemode(FALSE, NULL); debugmode(DBG_OFF, NULL); setPrologFlagMask(PLFLAG_LASTCALL); if ( PL_get_atom(except, &a) && a == ATOM_aborted ) { #ifdef O_DEBUGGER callEventHook(PLEV_ABORT); #endif printMessage(ATOM_informational, PL_ATOM, ATOM_aborted); } } if ( qid ) PL_close_query(qid); if ( fid ) PL_discard_foreign_frame(fid); if ( !except ) break; } while(loop); return rc; }
void default_op_parser(EtalisExecNode* operatorNode,term_t t) { assert(operatorNode != NULL); PL_open_foreign_frame(); operatorNode->leftChild=(EtalisEventNode*)malloc(sizeof(EtalisEventNode)); operatorNode->rightChild=NULL; operatorNode->condition=NULL; operatorNode->window_size=0; term_t _left_event=t; atom_t _left_event_name; PL_get_name_arity(_left_event,&_left_event_name,&((operatorNode->leftChild)->event.arity)); strcpy(operatorNode->leftChild->event.name,PL_atom_chars(_left_event_name)); }
static bool clearSourceAdmin(SourceFile sf) { GET_LD int rc = FALSE; fid_t fid = PL_open_foreign_frame(); term_t name = PL_new_term_ref(); static predicate_t pred = NULL; if ( !pred ) pred = PL_predicate("$clear_source_admin", 1, "system"); PL_put_atom(name, sf->name); rc = PL_call_predicate(MODULE_system, PL_Q_NORMAL, pred, name); PL_discard_foreign_frame(fid); return rc; }
int query_loop(atom_t goal, int loop) { GET_LD int rc; int clear_stacks = (LD->query == NULL); do { fid_t fid; qid_t qid = 0; term_t except = 0; predicate_t p; if ( !resetProlog(clear_stacks) ) goto error; if ( !(fid = PL_open_foreign_frame()) ) goto error; p = PL_pred(PL_new_functor(goal, 0), MODULE_system); if ( (qid = PL_open_query(MODULE_system, PL_Q_NORMAL, p, 0)) ) { rc = PL_next_solution(qid); } else { error: except = exception_term; rc = -1; /* Won't get any better */ break; } if ( !rc && (except = PL_exception(qid)) ) { restore_after_exception(except); rc = -1; } if ( qid ) PL_close_query(qid); if ( fid ) PL_discard_foreign_frame(fid); if ( !except ) break; } while(loop); return rc; }
void initpyswipl() { char *plargs[3]; term_t swipl_load; fid_t swipl_fid; /**********************************************************/ /* Initialize the prolog kernel. */ /* The kernel is embedded (linked in) so I am setting the */ /* the startup path to be the current directory. Also, */ /* I'm sending the -q flag to supress the startup banner. */ /**********************************************************/ plargs[0]="./"; plargs[1]="-q"; plargs[2]="-nosignals"; PL_initialise(3,plargs); /**********************************************************/ /* Load the pyrun predicate. */ /* The pyrun.pl file has to be in the current working */ /* directory. */ /**********************************************************/ swipl_fid=PL_open_foreign_frame(); swipl_load=PL_new_term_ref(); /**********************************************************/ /* Changed by Nathan Denny July 18, 2001 */ /* No longer necessary to include pyrun.pl */ /**********************************************************/ /*PL_chars_to_term("consult('pyrun.pl')", swipl_load);*/ PL_chars_to_term("assert(pyrun(GoalString,BindingList):-(atom_codes(A,GoalString),atom_to_term(A,Goal,BindingList),call(Goal))).", swipl_load); PL_call(swipl_load,NULL); PL_discard_foreign_frame(swipl_fid); /**********************************************************/ /* Call the Python module initializer. */ /**********************************************************/ (void) Py_InitModule("pyswipl",pyswiplMethods); }
static char *prolog_iniciar(modulo_t *modulo, GHashTable *argumentos) { prolog_dato_t *prolog = (prolog_dato_t*)modulo->m_dato; char *av[10]; int ac = 0; av[ac++] = "prolog"; av[ac++] = "-g"; av[ac++] = "true"; av[ac++] = "-f"; av[ac++] = "none"; if(!PL_initialise(ac, av)) { PL_halt(-1); } prolog->m_fid = PL_open_foreign_frame(); g_hash_table_insert(modulo->m_tabla, PUERTO_SALIDA, 0); g_hash_table_insert(modulo->m_tabla, PUERTO_ORDEN, 0); g_hash_table_insert(modulo->m_tabla, PUERTO_PARAMETRO, 0); return "iniciado"; }
/************************* * libprolog_load_file *************************/ int libprolog_load_file(char *path, int extension) { char *loader = extension ? "load_foreign_library" : "consult"; predicate_t pr_loader; fid_t frame; qid_t qid; term_t pl_path; int success; /* * load the given file (native prolog or foreign library) * * Notes: * The prolog predicate consult/1 does not seem to fail or raise an * exception upon errors. It merely produces an error message and * tries to continue or gives up processing the input file. In either * case it succeeds (ie. the goal consult(path) is always proven in * the prolog sense). * * This default behaviour is not acceptable for us. As a library we * want to let our caller know whether loading was successful or not. * Otherwise it would be impossible to write even remotely reliable * applications using this library. * * To detect errors we have special prolog glue code that hooks into * SWI Prologs user:message_hook and lets us know about errors * (libprolog:mark_error) if loading is active (libprolog:loading). * Currently the glue code prints an error message but it would be * fairly easy to collect the errors here and let our caller print * them if needed. For the time being this glue code lives in policy.pl * but will eventually be separated out (to libprolog.pl ?). */ libprolog_clear_errors(); libprolog_load_start(); frame = PL_open_foreign_frame(); pr_loader = PL_predicate(loader, 1, NULL); pl_path = PL_new_term_ref(); PL_put_atom_chars(pl_path, path); qid = PL_open_query(NULL, NORMAL_QUERY_FLAGS, pr_loader, pl_path); success = PL_next_solution(qid); if (PL_exception(qid)) { #if 0 char **exception = collect_exception(qid, &exception); libprolog_dump_exception(exception); #endif success = FALSE; } PL_close_query(qid); PL_discard_foreign_frame(frame); libprolog_load_done(); if (libprolog_has_errors()) return FALSE; else return success; }
static foreign_t current_alarms(term_t time, term_t goal, term_t id, term_t status, term_t matching) { Event ev; term_t next = PL_new_term_ref(); term_t g = PL_new_term_ref(); term_t tail = PL_copy_term_ref(matching); term_t head = PL_new_term_ref(); term_t av = PL_new_term_refs(4); pthread_t self = pthread_self(); LOCK(); ev = TheSchedule()->first; for(; ev; ev = ev->next) { atom_t s; double at; fid_t fid; if ( !pthread_equal(self, ev->thread_id) ) continue; fid = PL_open_foreign_frame(); if ( ev->flags & EV_DONE ) s = ATOM_done; else if ( ev == TheSchedule()->scheduled ) s = ATOM_next; else s = ATOM_scheduled; if ( !PL_unify_atom(status, s) ) goto nomatch; PL_recorded(ev->goal, g); if ( !PL_unify_term(goal, PL_FUNCTOR, FUNCTOR_module2, PL_ATOM, PL_module_name(ev->module), PL_TERM, g) ) goto nomatch; at = (double)ev->at.tv_sec + (double)ev->at.tv_usec / 1000000.0; if ( !PL_unify_float(time, at) ) goto nomatch; if ( !unify_timer(id, ev) ) goto nomatch; PL_discard_foreign_frame(fid); if ( !PL_put_float(av+0, at) || /* time */ !PL_recorded(ev->goal, av+1) || /* goal */ !PL_put_variable(av+2) || /* id */ !unify_timer(av+2, ev) || !PL_put_atom(av+3, s) || /* status */ !PL_cons_functor_v(next, FUNCTOR_alarm4, av) ) { PL_close_foreign_frame(fid); UNLOCK(); return FALSE; } if ( PL_unify_list(tail, head, tail) && PL_unify(head, next) ) { continue; } else { PL_close_foreign_frame(fid); UNLOCK(); return FALSE; } nomatch: PL_discard_foreign_frame(fid); } UNLOCK(); return PL_unify_nil(tail); }
void parse_seq_op_ (EtalisExecNode* operatorNode,term_t t) { assert(operatorNode != NULL); fid_t fid = PL_open_foreign_frame(); /*get components of the operator*/ term_t _level_1 = PL_new_term_refs(2); term_t _left_event=_level_1; term_t _right_event=_level_1+1; atom_t _left_event_name,_right_event_name; int temp_arity,i=0; /* TODO check for embedded operators, if operator -> parse right function ; else get atomic events */ PL_get_arg(1,t,_left_event); PL_get_name_arity(_left_event,&_left_event_name,&temp_arity); char * tt = PL_atom_chars(_left_event_name); i=0; while(strcmp(CEP_LUT_[i].CEP_name,PL_atom_chars(_left_event_name)) != 0 && i<LUT_Size) i++; /* #CONT */ if(i != LUT_Size) /*The operator is found in the CEP_LUT_*/ /* create a temp event */ { EtalisEventNode* TempEvent = (EtalisEventNode*)calloc(1,sizeof(EtalisEventNode)); /* this temp event is the complex event of the embedded operation */ TempEvent->event.arity = 0; strcpy(TempEvent->event.name,"temp_"); /* TODO Temp Events */ /* Temp Events have no arguments */ TempEvent->parentNode = operatorNode; strcpy(TempEvent->parentNode->name,tt); TempEvent->is_temp = ETALIS_TRUE; operatorNode->leftChild = TempEvent; EtalisExecNode* NewNodeRule = (EtalisExecNode*)calloc(1,sizeof(EtalisExecNode)); /* binarization and allocation of the embedded operator */ TempEvent->childNode = NewNodeRule; NewNodeRule->parentEvent = TempEvent; TempEvent->trigger = _seq_win_cep_l; switch (CEP_LUT_[i].CEP_arity) { case 1: break; case 2: /* found embedded */ CEP_LUT_[i].parser_func(NewNodeRule,_left_event); break; default: printf("error compiling the rules\n"); } } else /* an atomic event has been found */ { operatorNode->leftChild = (EtalisEventNode*) calloc(1,sizeof(EtalisEventNode)); PL_get_name_arity(_left_event,&_left_event_name,(int *)&((operatorNode->leftChild)->event.arity)); strcpy(operatorNode->leftChild->event.name,PL_atom_chars(_left_event_name)); operatorNode->leftChild->childNode = NULL; operatorNode->leftChild->parentNode=operatorNode; operatorNode->leftChild->is_temp = ETALIS_FALSE; if (operatorNode->parentEvent->is_temp) strcat(operatorNode->parentEvent->event.name,operatorNode->leftChild->event.name); operatorNode->leftChild->trigger = _seq_win_cep_l; } PL_get_arg(2,t,_right_event); operatorNode->rightChild = (EtalisEventNode*) calloc(1,sizeof(EtalisEventNode)); PL_get_name_arity(_right_event,&_right_event_name,(int *)&(operatorNode->rightChild->event.arity)); strcpy(operatorNode->rightChild->event.name,PL_atom_chars(_right_event_name)); operatorNode->rightChild->childNode = NULL; operatorNode->rightChild->parentNode = operatorNode; operatorNode->rightChild->is_temp = ETALIS_FALSE; PL_discard_foreign_frame(fid); if (operatorNode->parentEvent->is_temp) { strcat(operatorNode->parentEvent->event.name,operatorNode->rightChild->event.name); operatorNode->rightChild->trigger = _seq_win_cep_l; } else /* event is latest event in the call list */ { operatorNode->rightChild->trigger = _seq_batch_r; } ; }
/* parse the time window constraints */ void parse_within_op_(EtalisExecNode* operatorNode,term_t t) { assert(operatorNode != NULL); fid_t fid = PL_open_foreign_frame(); EtalisEventNode* opt_t = (EtalisEventNode*)malloc(2*sizeof(EtalisEventNode)); /* memory alignement for L1 cache optimization */ operatorNode->leftChild=opt_t; memset(operatorNode->leftChild,0,sizeof(EtalisEventNode)); operatorNode->rightChild=opt_t+1; operatorNode->condition=NULL; /* get window size */ term_t winsize = PL_new_term_ref(); PL_get_arg(2,t,winsize); WINDOW_SIZE_T i; /*get window size*/ /* depending on the target processor, this might be an int, a double or a structure. */ /* defined in WINDOW_SIZE_T : e_time.h */ #if PROCESSOR_SUPPORTS_DOUBLE ==1 if (PL_term_type(winsize) == PL_FLOAT) PL_get_float(winsize,&i); else printf("ERROR: window Size must be a floating number ! \n"); #else /* we don't support double accuracy, fall back to int */ PL_get_integer(winsize, &i); #endif operatorNode->window_size=i; #ifdef DEBUG printf("--- WITHIN Block detected | Window size: %f\n",i); #endif /* term_t _level_1 = PL_new_term_refs(3); term_t _left_event=_level_1+1; term_t _right_event=_level_1+2; atom_t _left_event_name,_right_event_name; PL_get_arg(1,t,_level_1); PL_get_arg(1,_level_1,_left_event); PL_get_arg(2,_level_1,_right_event); PL_get_name_arity(_left_event,&_left_event_name,(int*)&((operatorNode->leftChild)->event.arity)); PL_get_name_arity(_right_event,&_right_event_name,(int*)&(operatorNode->rightChild->event.arity)); PL_discard_foreign_frame(fid); strcpy(operatorNode->leftChild->event.name,PL_atom_chars(_left_event_name)); strcpy(operatorNode->rightChild->event.name,PL_atom_chars(_right_event_name)); } */ }
int PL_error(const char *pred, int arity, const char *msg, PL_error_code id, ...) { GET_LD char msgbuf[50]; Definition caller; term_t except, formal, swi, msgterm=0; va_list args; int do_throw = FALSE; fid_t fid; int rc; if ( exception_term ) /* do not overrule older exception */ return FALSE; if ( environment_frame ) caller = environment_frame->predicate; else caller = NULL; if ( id == ERR_FILE_OPERATION && !truePrologFlag(PLFLAG_FILEERRORS) ) fail; if ( msg == MSG_ERRNO ) { if ( errno == EPLEXCEPTION ) return FALSE; msg = OsError(); } LD->exception.processing = TRUE; /* allow using spare stack */ if ( !(fid = PL_open_foreign_frame()) ) goto nomem; except = PL_new_term_ref(); formal = PL_new_term_ref(); swi = PL_new_term_ref(); /* build (ISO) formal part */ va_start(args, id); switch(id) { case ERR_INSTANTIATION: err_instantiation: rc = PL_unify_atom(formal, ATOM_instantiation_error); break; case ERR_UNINSTANTIATION: { int argn = va_arg(args, int); term_t bound = va_arg(args, term_t); if ( !msg && argn > 0 ) { Ssprintf(msgbuf, "%d-%s argument", argn, argn == 1 ? "st" : argn == 2 ? "nd" : "th"); msg = msgbuf; } rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_uninstantiation_error1, PL_TERM, bound); break; } case ERR_TYPE: /* ERR_INSTANTIATION if var(actual) */ { atom_t expected = va_arg(args, atom_t); term_t actual = va_arg(args, term_t); case_type_error: if ( expected == ATOM_callable ) rewrite_callable(&expected, actual); if ( PL_is_variable(actual) && expected != ATOM_variable ) goto err_instantiation; rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_type_error2, PL_ATOM, expected, PL_TERM, actual); break; case ERR_PTR_TYPE: /* atom_t, Word */ { Word ptr; expected = va_arg(args, atom_t); ptr = va_arg(args, Word); actual = PL_new_term_ref(); *valTermRef(actual) = *ptr; goto case_type_error; } } case ERR_CHARS_TYPE: /* ERR_INSTANTIATION if var(actual) */ { const char *expected = va_arg(args, const char*); term_t actual = va_arg(args, term_t); if ( PL_is_variable(actual) && !streq(expected, "variable") ) goto err_instantiation; rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_type_error2, PL_CHARS, expected, PL_TERM, actual); break; } case ERR_AR_TYPE: /* arithmetic type error */ { atom_t expected = va_arg(args, atom_t); Number num = va_arg(args, Number); term_t actual = PL_new_term_ref(); rc = (_PL_put_number(actual, num) && PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_type_error2, PL_ATOM, expected, PL_TERM, actual)); break; } case ERR_AR_DOMAIN: { atom_t domain = va_arg(args, atom_t); Number num = va_arg(args, Number); term_t actual = PL_new_term_ref(); rc = (_PL_put_number(actual, num) && PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_domain_error2, PL_ATOM, domain, PL_TERM, actual)); break; } case ERR_AR_UNDEF: { rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_evaluation_error1, PL_ATOM, ATOM_undefined); break; } case ERR_AR_OVERFLOW: { rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_evaluation_error1, PL_ATOM, ATOM_float_overflow); break; } case ERR_AR_UNDERFLOW: { rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_evaluation_error1, PL_ATOM, ATOM_float_underflow); break; } case ERR_DOMAIN: /* ERR_INSTANTIATION if var(arg) */ { atom_t domain = va_arg(args, atom_t); term_t arg = va_arg(args, term_t); if ( PL_is_variable(arg) ) goto err_instantiation; rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_domain_error2, PL_ATOM, domain, PL_TERM, arg); break; } case ERR_RANGE: /* domain_error(range(low,high), arg) */ { term_t low = va_arg(args, term_t); term_t high = va_arg(args, term_t); term_t arg = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_domain_error2, PL_FUNCTOR, FUNCTOR_range2, PL_TERM, low, PL_TERM, high, PL_TERM, arg); break; } case ERR_REPRESENTATION: { atom_t what = va_arg(args, atom_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_representation_error1, PL_ATOM, what); break; } { Definition def; /* shared variables */ Procedure proc; term_t pred; case ERR_MODIFY_STATIC_PROC: proc = va_arg(args, Procedure); def = proc->definition; goto modify_static; case ERR_MODIFY_STATIC_PREDICATE: def = va_arg(args, Definition); modify_static: rc = ((pred = PL_new_term_ref()) && unify_definition(MODULE_user, pred, def, 0, GP_NAMEARITY|GP_HIDESYSTEM) && PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_permission_error3, PL_ATOM, ATOM_modify, PL_ATOM, ATOM_static_procedure, PL_TERM, pred)); break; } case ERR_MODIFY_THREAD_LOCAL_PROC: { Procedure proc = va_arg(args, Procedure); term_t pred = PL_new_term_ref(); rc = (unify_definition(MODULE_user, pred, proc->definition, 0, GP_NAMEARITY|GP_HIDESYSTEM) && PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_permission_error3, PL_ATOM, ATOM_modify, PL_ATOM, ATOM_thread_local_procedure, PL_TERM, pred)); break; } case ERR_UNDEFINED_PROC: { Definition def = va_arg(args, Definition); Definition clr = va_arg(args, Definition); term_t pred = PL_new_term_ref(); if ( clr ) caller = clr; rc = (unify_definition(MODULE_user, pred, def, 0, GP_NAMEARITY) && PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_existence_error2, PL_ATOM, ATOM_procedure, PL_TERM, pred)); break; } case ERR_PERMISSION_PROC: { atom_t op = va_arg(args, atom_t); atom_t type = va_arg(args, atom_t); predicate_t pred = va_arg(args, predicate_t); term_t pi = PL_new_term_ref(); rc = ( PL_unify_predicate(pi, pred, GP_NAMEARITY|GP_HIDESYSTEM) && PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_permission_error3, PL_ATOM, op, PL_ATOM, type, PL_TERM, pi)); break; } case ERR_NOT_IMPLEMENTED_PROC: { const char *name = va_arg(args, const char *); int arity = va_arg(args, int); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_not_implemented2, PL_ATOM, ATOM_procedure, PL_FUNCTOR, FUNCTOR_divide2, PL_CHARS, name, PL_INT, arity); break; } case ERR_IMPORT_PROC: { predicate_t pred = va_arg(args, predicate_t); atom_t dest = va_arg(args, atom_t); atom_t old = va_arg(args, atom_t); term_t pi = PL_new_term_ref(); rc = ( PL_unify_predicate(pi, pred, GP_NAMEARITY) && PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_permission_error3, PL_FUNCTOR, FUNCTOR_import_into1, PL_ATOM, dest, PL_ATOM, ATOM_procedure, PL_TERM, pi)); if ( rc && old ) { rc = ( (msgterm = PL_new_term_ref()) && PL_unify_term(msgterm, PL_FUNCTOR_CHARS, "already_from", 1, PL_ATOM, old) ); } break; } case ERR_FAILED: { term_t goal = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_failure_error1, PL_TERM, goal); break; } case ERR_EVALUATION: { atom_t what = va_arg(args, atom_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_evaluation_error1, PL_ATOM, what); break; } case ERR_NOT_EVALUABLE: { functor_t f = va_arg(args, functor_t); term_t actual = PL_new_term_ref(); rc = (put_name_arity(actual, f) && PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_type_error2, PL_ATOM, ATOM_evaluable, PL_TERM, actual)); break; } case ERR_DIV_BY_ZERO: { rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_evaluation_error1, PL_ATOM, ATOM_zero_divisor); break; } case ERR_PERMISSION: { atom_t op = va_arg(args, atom_t); atom_t type = va_arg(args, atom_t); term_t obj = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_permission_error3, PL_ATOM, op, PL_ATOM, type, PL_TERM, obj); break; } case ERR_OCCURS_CHECK: { Word p1 = va_arg(args, Word); Word p2 = va_arg(args, Word); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_occurs_check2, PL_TERM, pushWordAsTermRef(p1), PL_TERM, pushWordAsTermRef(p2)); popTermRef(); popTermRef(); break; } case ERR_TIMEOUT: { atom_t op = va_arg(args, atom_t); term_t obj = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_timeout_error2, PL_ATOM, op, PL_TERM, obj); break; } case ERR_EXISTENCE: { atom_t type = va_arg(args, atom_t); term_t obj = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_existence_error2, PL_ATOM, type, PL_TERM, obj); break; } case ERR_EXISTENCE3: { atom_t type = va_arg(args, atom_t); term_t obj = va_arg(args, term_t); term_t in = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_existence_error3, PL_ATOM, type, PL_TERM, obj, PL_TERM, in); break; } case ERR_FILE_OPERATION: { atom_t action = va_arg(args, atom_t); atom_t type = va_arg(args, atom_t); term_t file = va_arg(args, term_t); switch(errno) { case EAGAIN: action = ATOM_lock; /* Hack for file-locking*/ /*FALLTHROUGH*/ case EACCES: rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_permission_error3, PL_ATOM, action, PL_ATOM, type, PL_TERM, file); break; case EMFILE: case ENFILE: rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_resource_error1, PL_ATOM, ATOM_max_files); break; #ifdef EPIPE case EPIPE: if ( !msg ) msg = "Broken pipe"; /*FALLTHROUGH*/ #endif default: /* what about the other cases? */ rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_existence_error2, PL_ATOM, type, PL_TERM, file); break; } break; } case ERR_STREAM_OP: { atom_t action = va_arg(args, atom_t); term_t stream = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_io_error2, PL_ATOM, action, PL_TERM, stream); break; } case ERR_DDE_OP: { const char *op = va_arg(args, const char *); const char *err = va_arg(args, const char *); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_dde_error2, PL_CHARS, op, PL_CHARS, err); break; } case ERR_SHARED_OBJECT_OP: { atom_t action = va_arg(args, atom_t); const char *err = va_arg(args, const char *); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_shared_object2, PL_ATOM, action, PL_CHARS, err); break; } case ERR_NOT_IMPLEMENTED: /* non-ISO */ { const char *what = va_arg(args, const char *); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_not_implemented2, PL_ATOM, ATOM_feature, PL_CHARS, what); break; } case ERR_RESOURCE: { atom_t what = va_arg(args, atom_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_resource_error1, PL_ATOM, what); break; } case ERR_SYNTAX: { const char *what = va_arg(args, const char *); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_syntax_error1, PL_CHARS, what); break; } case ERR_NOMEM: { rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_resource_error1, PL_ATOM, ATOM_no_memory); break; } case ERR_SYSCALL: { const char *op = va_arg(args, const char *); if ( !msg ) msg = op; switch(errno) { case ENOMEM: rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_resource_error1, PL_ATOM, ATOM_no_memory); break; default: rc = PL_unify_atom(formal, ATOM_system_error); break; } break; } case ERR_SHELL_FAILED: { term_t cmd = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_shell2, PL_ATOM, ATOM_execute, PL_TERM, cmd); break; } case ERR_SHELL_SIGNALLED: { term_t cmd = va_arg(args, term_t); int sig = va_arg(args, int); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_shell2, PL_FUNCTOR, FUNCTOR_signal1, PL_INT, sig, PL_TERM, cmd); break; } case ERR_SIGNALLED: { int sig = va_arg(args, int); char *signame = va_arg(args, char *); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_signal2, PL_CHARS, signame, PL_INT, sig); break; } case ERR_CLOSED_STREAM: { IOSTREAM *s = va_arg(args, IOSTREAM *); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_existence_error2, PL_ATOM, ATOM_stream, PL_POINTER, s); do_throw = TRUE; break; } case ERR_BUSY: { atom_t type = va_arg(args, atom_t); term_t mutex = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_busy2, type, mutex); break; } case ERR_FORMAT: { const char *s = va_arg(args, const char*); rc = PL_unify_term(formal, PL_FUNCTOR_CHARS, "format", 1, PL_CHARS, s); break; } case ERR_FORMAT_ARG: { const char *s = va_arg(args, const char*); term_t arg = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR_CHARS, "format_argument_type", 2, PL_CHARS, s, PL_TERM, arg); break; } case ERR_DUPLICATE_KEY: { term_t key = va_arg(args, term_t); rc = PL_unify_term(formal, PL_FUNCTOR, FUNCTOR_duplicate_key1, PL_TERM, key); break; } default: assert(0); } va_end(args); /* build SWI-Prolog context term */ if ( rc && (pred || msg || msgterm || caller) ) { term_t predterm = PL_new_term_ref(); if ( !msgterm ) msgterm = PL_new_term_ref(); if ( pred ) { rc = PL_unify_term(predterm, PL_FUNCTOR, FUNCTOR_divide2, PL_CHARS, pred, PL_INT, arity); } else if ( caller ) { rc = unify_definition(MODULE_user, predterm, caller, 0, GP_NAMEARITY); } if ( rc && msg ) { rc = PL_put_atom_chars(msgterm, msg); } if ( rc ) rc = PL_unify_term(swi, PL_FUNCTOR, FUNCTOR_context2, PL_TERM, predterm, PL_TERM, msgterm); } if ( rc ) rc = PL_unify_term(except, PL_FUNCTOR, FUNCTOR_error2, PL_TERM, formal, PL_TERM, swi); if ( !rc ) { nomem: fatalError("Cannot report error: no memory"); } if ( do_throw ) rc = PL_throw(except); else rc = PL_raise_exception(except); PL_close_foreign_frame(fid); return rc; }
word pl_current_functor(term_t name, term_t arity, control_t h) { GET_LD atom_t nm = 0; size_t index; int i, last=FALSE; int ar; fid_t fid; switch( ForeignControl(h) ) { case FRG_FIRST_CALL: if ( PL_get_atom(name, &nm) && PL_get_integer(arity, &ar) ) return isCurrentFunctor(nm, ar) ? TRUE : FALSE; if ( !(PL_is_integer(arity) || PL_is_variable(arity)) ) return PL_error("current_functor", 2, NULL, ERR_DOMAIN, ATOM_integer, arity); if ( !(PL_is_atom(name) || PL_is_variable(name)) ) return PL_error("current_functor", 2, NULL, ERR_DOMAIN, ATOM_atom, name); index = 1; break; case FRG_REDO: PL_get_atom(name, &nm); index = ForeignContextInt(h); break; case FRG_CUTTED: default: succeed; } fid = PL_open_foreign_frame(); LOCK(); for(i=MSB(index); !last; i++) { size_t upto = (size_t)2<<i; FunctorDef *b = GD->functors.array.blocks[i]; if ( upto >= GD->functors.highest ) { upto = GD->functors.highest; last = TRUE; } for(; index<upto; index++) { FunctorDef fd = b[index]; if ( fd && fd->arity > 0 && (!nm || nm == fd->name) ) { if ( PL_unify_atom(name, fd->name) && PL_unify_integer(arity, fd->arity) ) { UNLOCK(); ForeignRedoInt(index+1); } else { PL_rewind_foreign_frame(fid); } } } } UNLOCK(); return FALSE; }
/******************** * pl_fact_exists ********************/ static foreign_t pl_fact_exists(term_t pl_name, term_t pl_fields, term_t pl_list, control_t handle) { context_t *ctx; char *name, factname[64]; fid_t frame; term_t pl_values; OhmFact *f; switch (PL_foreign_control(handle)) { case PL_FIRST_CALL: if (!PL_is_list(pl_fields) || /*!PL_is_list(pl_list) ||*/ !PL_get_chars(pl_name, &name, CVT_ALL)) PL_fail; strncpy(factname, name, sizeof(factname)); factname[sizeof(factname)-1] = '\0'; if ((ctx = malloc(sizeof(*ctx))) == NULL) PL_fail; memset(ctx, 0, sizeof(*ctx)); if (get_field_names(ctx, pl_fields) != 0) { free(ctx); PL_fail; } ctx->store = ohm_fact_store_get_fact_store(); ctx->facts = ohm_fact_store_get_facts_by_name(ctx->store, factname); break; case PL_REDO: ctx = PL_foreign_context_address(handle); break; case PL_CUTTED: ctx = PL_foreign_context_address(handle); goto nomore; default: PL_fail; } /* XXX TODO: shouldn't we discard the frame here instead of closing them */ frame = PL_open_foreign_frame(); while (ctx->facts != NULL) { f = (OhmFact *)ctx->facts->data; ctx->facts = g_slist_next(ctx->facts); if (!fact_values(ctx, f, &pl_values) && PL_unify(pl_list, pl_values)) { PL_close_foreign_frame(frame); /* PL_discard_foreign_frame ??? */ PL_retry_address(ctx); } PL_rewind_foreign_frame(frame); } PL_close_foreign_frame(frame); /* PL_discard_foreign_frame ??? */ nomore: if (ctx->fields) free(ctx->fields); free(ctx); PL_fail; }
static HDDEDATA CALLBACK DdeCallback(UINT type, UINT fmt, HCONV hconv, HSZ hsz1, HSZ hsz2, HDDEDATA hData, DWORD dwData1, DWORD dwData2) { switch(type) { case XTYP_CONNECT: { fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(3); predicate_t pred = PL_pred(FUNCTOR_dde_connect3, MODULE_dde); int rval; PL_put_atom( argv+0, hszToAtom(hsz2)); /* topic */ PL_put_atom( argv+1, hszToAtom(hsz1)); /* service */ PL_put_integer(argv+2, dwData2 ? 1 : 0); /* same instance */ rval = PL_call_predicate(MODULE_dde, TRUE, pred, argv); PL_discard_foreign_frame(cid); return (void *)rval; } case XTYP_CONNECT_CONFIRM: { fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(3); predicate_t pred = PL_pred(FUNCTOR_dde_connect_confirm3, MODULE_dde); int plhandle; if ( (plhandle = allocServerHandle(hconv)) >= 0 ) { fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(3); predicate_t pred = PL_pred(FUNCTOR_dde_connect_confirm3, MODULE_dde); PL_put_atom( argv+0, hszToAtom(hsz2)); /* topic */ PL_put_atom( argv+1, hszToAtom(hsz1)); /* service */ PL_put_integer(argv+2, plhandle); PL_call_predicate(MODULE_dde, TRUE, pred, argv); PL_discard_foreign_frame(cid); } return NULL; } case XTYP_DISCONNECT: { fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(1); predicate_t pred = PL_pred(FUNCTOR_dde_disconnect1, MODULE_dde); int plhandle = findServerHandle(hconv); if ( plhandle >= 0 && plhandle < MAX_CONVERSATIONS ) server_handle[plhandle] = (HCONV)NULL; PL_put_integer(argv+0, plhandle); PL_call_predicate(MODULE_dde, TRUE, pred, argv); PL_discard_foreign_frame(cid); return NULL; } case XTYP_EXECUTE: { int plhandle = findServerHandle(hconv); HDDEDATA rval = DDE_FNOTPROCESSED; fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(3); predicate_t pred = PL_pred(FUNCTOR_dde_execute3, MODULE_dde); DEBUG(0, Sdprintf("Got XTYP_EXECUTE request\n")); PL_put_integer(argv+0, plhandle); PL_put_atom( argv+1, hszToAtom(hsz1)); unify_hdata( argv+2, hData); if ( PL_call_predicate(MODULE_dde, TRUE, pred, argv) ) rval = (void *) DDE_FACK; PL_discard_foreign_frame(cid); DdeFreeDataHandle(hData); return rval; } case XTYP_REQUEST: { HDDEDATA data = (HDDEDATA) NULL; if ( fmt == CF_TEXT ) { fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(4); predicate_t pred = PL_pred(FUNCTOR_dde_request4, MODULE_dde); int plhandle = findServerHandle(hconv); PL_put_integer( argv+0, plhandle); PL_put_atom( argv+1, hszToAtom(hsz1)); /* topic */ PL_put_atom( argv+2, hszToAtom(hsz2)); /* item */ PL_put_variable(argv+3); if ( PL_call_predicate(MODULE_dde, TRUE, pred, argv) ) { char *s; if ( PL_get_chars(argv+3, &s, CVT_ALL) ) data = DdeCreateDataHandle(ddeInst, s, strlen(s)+1, 0, hsz2, CF_TEXT, 0); } PL_discard_foreign_frame(cid); } return data; } default: ; } return (HDDEDATA)NULL; }
static HDDEDATA CALLBACK DdeCallback(UINT type, UINT fmt, HCONV hconv, HSZ hsz1, HSZ hsz2, HDDEDATA hData, DWORD dwData1, DWORD dwData2) { GET_LD DWORD ddeInst = LD->os.dde_instance; switch(type) { case XTYP_CONNECT: { fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(3); predicate_t pred = PL_pred(FUNCTOR_dde_connect3, MODULE_dde); int rval; if ( unify_hsz(ddeInst, argv+0, hsz2) && /* topic */ unify_hsz(ddeInst, argv+1, hsz1) && /* service */ PL_unify_integer(argv+2, dwData2 ? 1 : 0) ) /* same instance */ { rval = PL_call_predicate(MODULE_dde, TRUE, pred, argv); } else { rval = FALSE; } PL_discard_foreign_frame(cid); return (void *)(intptr_t)rval; } case XTYP_CONNECT_CONFIRM: { int plhandle; if ( (plhandle = allocServerHandle(hconv)) >= 0 ) { fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(3); predicate_t pred = PL_pred(FUNCTOR_dde_connect_confirm3, MODULE_dde); if ( unify_hsz(ddeInst, argv+0, hsz2) && /* topic */ unify_hsz(ddeInst, argv+1, hsz1) && /* service */ PL_unify_integer(argv+2, plhandle) ) PL_call_predicate(MODULE_dde, TRUE, pred, argv); PL_discard_foreign_frame(cid); } return NULL; } case XTYP_DISCONNECT: { fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(1); predicate_t pred = PL_pred(FUNCTOR_dde_disconnect1, MODULE_dde); int plhandle = findServerHandle(hconv); if ( plhandle >= 0 && plhandle < MAX_CONVERSATIONS ) server_handle[plhandle] = (HCONV)NULL; PL_put_integer(argv+0, plhandle); PL_call_predicate(MODULE_dde, TRUE, pred, argv); PL_discard_foreign_frame(cid); return NULL; } case XTYP_EXECUTE: { int plhandle = findServerHandle(hconv); HDDEDATA rval = DDE_FNOTPROCESSED; fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(3); predicate_t pred = PL_pred(FUNCTOR_dde_execute3, MODULE_dde); DEBUG(1, Sdprintf("Got XTYP_EXECUTE request\n")); PL_put_integer(argv+0, plhandle); unify_hsz(ddeInst, argv+1, hsz1); unify_hdata( argv+2, hData); if ( PL_call_predicate(MODULE_dde, TRUE, pred, argv) ) rval = (void *) DDE_FACK; PL_discard_foreign_frame(cid); DdeFreeDataHandle(hData); return rval; } case XTYP_REQUEST: { HDDEDATA data = (HDDEDATA) NULL; if ( fmt == CF_UNICODETEXT ) { fid_t cid = PL_open_foreign_frame(); term_t argv = PL_new_term_refs(4); predicate_t pred = PL_pred(FUNCTOR_dde_request4, MODULE_dde); int plhandle = findServerHandle(hconv); PL_put_integer( argv+0, plhandle); unify_hsz(ddeInst, argv+1, hsz1); /* topic */ unify_hsz(ddeInst, argv+2, hsz2); /* item */ if ( PL_call_predicate(MODULE_dde, TRUE, pred, argv) ) { wchar_t *s; size_t len; /* TBD: error handling */ if ( PL_get_wchars(argv+3, &len, &s, CVT_ALL) ) data = DdeCreateDataHandle(ddeInst, (unsigned char*) s, (DWORD)(len+1)*sizeof(wchar_t), 0, hsz2, CF_UNICODETEXT, 0); } PL_discard_foreign_frame(cid); } return data; } default: ; } return (HDDEDATA)NULL; }
static PyObject* pyswipl_run(PyObject* self_Py, PyObject* args_Py) { char* goalString; char* answer; int answerCount; PyObject* answerList_Py; PyObject* answerString_Py; PyObject* bindingList_Py; PyObject* binding_Py; term_t swipl_args; term_t swipl_goalCharList; term_t swipl_bindingList; term_t swipl_head; term_t swipl_list; predicate_t swipl_predicate; qid_t swipl_qid; fid_t swipl_fid; /**********************************************************/ /* The queryString_C should be a python string represting */ /* the query to be executed on the prolog system. */ /**********************************************************/ if(!PyArg_ParseTuple(args_Py, "s", &goalString)) return NULL; else { /**********************************************************/ /* Create a Python list to hold the lists of bindings. */ /**********************************************************/ //if ( answerList_Py != NULL ) // Py_DECREF(answerList_Py); answerList_Py=PyList_New(0); /**********************************************************/ /* Open a foreign frame and initialize the term refs. */ /**********************************************************/ swipl_fid=PL_open_foreign_frame(); swipl_head=PL_new_term_ref(); /* Used in unpacking the binding List */ swipl_args=PL_new_term_refs(2); /* The compound term for arguments to run/2 */ swipl_goalCharList=swipl_args; /* Alias for arg 1 */ swipl_bindingList=swipl_args+1; /* Alias for arg 2 */ /**********************************************************/ /* Pack the query string into the argument compund term. */ /**********************************************************/ PL_put_list_chars(swipl_goalCharList,goalString); /**********************************************************/ /* Generate a predicate to pyrun/2 */ /**********************************************************/ swipl_predicate=PL_predicate("pyrun",2,NULL); /**********************************************************/ /* Open the query, and iterate through the solutions. */ /**********************************************************/ swipl_qid=PL_open_query(NULL,PL_Q_NORMAL,swipl_predicate, swipl_args); while(PL_next_solution(swipl_qid)) { /**********************************************************/ /* Create a Python list to hold the bindings. */ /**********************************************************/ bindingList_Py=PyList_New(0); /**********************************************************/ /* Step through the bindings and add each to the list. */ /**********************************************************/ swipl_list=PL_copy_term_ref(swipl_bindingList); while(PL_get_list(swipl_list, swipl_head, swipl_list)) { PL_get_chars(swipl_head, &answer, CVT_ALL|CVT_WRITE|BUF_RING); answerString_Py = PyString_FromString(answer); PyList_Append(bindingList_Py, answerString_Py); Py_DECREF(answerString_Py); } /**********************************************************/ /* Add this binding list to the list of all solutions. */ /**********************************************************/ PyList_Append(answerList_Py, bindingList_Py); Py_DECREF(bindingList_Py); } /**********************************************************/ /* Free this foreign frame... */ /* Added by Nathan Denny, July 18, 2001. */ /* Fixes a bug with running out of global stack when */ /* asserting _lots_ of facts. */ /**********************************************************/ PL_close_query(swipl_qid); PL_discard_foreign_frame(swipl_fid); /**********************************************************/ /* Return the list of solutions. */ /**********************************************************/ return answerList_Py; } }
static foreign_t pl_new_order_table(term_t name, term_t options) { OrdTable t = malloc(sizeof(ordtable)); term_t tail = PL_copy_term_ref(options); term_t head = PL_new_term_ref(); exact_table(t); if ( !PL_get_atom(name, &t->name) ) { free(t); return error(ERR_INSTANTIATION, "new_order_table/2", 1, name); } while(PL_get_list(tail, head, tail)) { atom_t name; int arity; if ( PL_get_name_arity(head, &name, &arity) ) { if ( name == ATOM_case_insensitive ) { case_insensitive_table(t); } else if ( name == ATOM_iso_latin_1 ) { iso_latin_1_table(t); } else if ( name == ATOM_iso_latin_1_case_insensitive ) { iso_latin_1_case_table(t); } else if ( name == ATOM_copy && arity == 1 ) { term_t a = PL_new_term_ref(); OrdTable from; _PL_get_arg(1, head, a); if ( get_order_table(a, &from) ) { copy_table(t, from); } else { free(t); return FALSE; } } else if ( arity == 1 ) { fid_t fid = PL_open_foreign_frame(); term_t a = PL_new_term_ref(); _PL_get_arg(1, head, a); if ( !parse_set(t, name, a) ) goto err1; PL_close_foreign_frame(fid); } else if ( name == ATOM_eq && arity == 2 ) { fid_t fid = PL_open_foreign_frame(); term_t c = PL_new_term_ref(); int from, to; if ( !PL_get_arg(1, head, c) || !get_char(c, &from) || !PL_get_arg(2, head, c) || !get_char(c, &to) ) { free(t); return FALSE; } ORD(t, from) = to; PL_close_foreign_frame(fid); } else goto err1; } else { err1: free(t); return error(ERR_INSTANTIATION, "new_order_table/2", 2, options); } } if ( !PL_get_nil(tail) ) goto err1; register_table(t); PL_succeed; }
int pl_error(const char *pred, int arity, const char *msg, int id, ...) { fid_t fid; term_t except, formal, swi; int rc; va_list args; if ( !(fid=PL_open_foreign_frame()) ) return FALSE; except = PL_new_term_ref(); formal = PL_new_term_ref(); swi = PL_new_term_ref(); va_start(args, id); switch(id) { case ERR_ERRNO: { int err = va_arg(args, int); const char *action = va_arg(args, const char *); const char *type = va_arg(args, const char *); term_t object = va_arg(args, term_t); if ( !object ) object = PL_new_term_ref(); msg = strerror(err); switch(err) { case ENOMEM: case EAGAIN: /* fork(); might be other resource */ rc = PL_unify_term(formal, CompoundArg("resource_error", 1), AtomArg("no_memory")); break; case EACCES: case EPERM: { rc = PL_unify_term(formal, CompoundArg("permission_error", 3), AtomArg(action), AtomArg(type), PL_TERM, object); break; } case ENOENT: case ESRCH: { rc = PL_unify_term(formal, CompoundArg("existence_error", 2), AtomArg(type), PL_TERM, object); break; } default: rc = PL_unify_atom_chars(formal, "system_error"); break; } break; } case ERR_ARGTYPE: { int argn = va_arg(args, int); /* argument position (unused) */ term_t actual = va_arg(args, term_t); atom_t expected = PL_new_atom(va_arg(args, const char*)); (void)argn; /* avoid unused warning */ if ( PL_is_variable(actual) && expected != PL_new_atom("variable") ) rc = PL_unify_atom_chars(formal, "instantiation_error"); else rc = PL_unify_term(formal, CompoundArg("type_error", 2), PL_ATOM, expected, PL_TERM, actual); break; } case ERR_TYPE: { term_t actual = va_arg(args, term_t); atom_t expected = PL_new_atom(va_arg(args, const char*)); if ( PL_is_variable(actual) && expected != PL_new_atom("variable") ) rc = PL_unify_atom_chars(formal, "instantiation_error"); else rc = PL_unify_term(formal, CompoundArg("type_error", 2), PL_ATOM, expected, PL_TERM, actual); break; } case ERR_DOMAIN: { term_t actual = va_arg(args, term_t); atom_t expected = PL_new_atom(va_arg(args, const char*)); rc = PL_unify_term(formal, CompoundArg("domain_error", 2), PL_ATOM, expected, PL_TERM, actual); break; } case ERR_EXISTENCE: { const char *type = va_arg(args, const char *); term_t obj = va_arg(args, term_t); rc = PL_unify_term(formal, CompoundArg("existence_error", 2), PL_CHARS, type, PL_TERM, obj); break; } case ERR_PERMISSION: { term_t obj = va_arg(args, term_t); const char *op = va_arg(args, const char *); const char *objtype = va_arg(args, const char *); rc = PL_unify_term(formal, CompoundArg("permission_error", 3), AtomArg(op), AtomArg(objtype), PL_TERM, obj); break; } case ERR_NOTIMPLEMENTED: { const char *op = va_arg(args, const char *); term_t obj = va_arg(args, term_t); rc = PL_unify_term(formal, CompoundArg("not_implemented", 2), AtomArg(op), PL_TERM, obj); break; } case ERR_RESOURCE: { const char *res = va_arg(args, const char *); rc = PL_unify_term(formal, CompoundArg("resource_error", 1), AtomArg(res)); break; } case ERR_SYNTAX: { const char *culprit = va_arg(args, const char *); rc = PL_unify_term(formal, CompoundArg("syntax_error", 1), AtomArg(culprit)); break; } default: assert(0); rc = FALSE; } va_end(args); if ( rc && (pred || msg) ) { term_t predterm = PL_new_term_ref(); term_t msgterm = PL_new_term_ref(); if ( pred ) { rc = PL_unify_term(predterm, CompoundArg("/", 2), AtomArg(pred), IntArg(arity)); } if ( msg ) { rc = PL_put_atom_chars(msgterm, msg); } if ( rc ) rc = PL_unify_term(swi, CompoundArg("context", 2), PL_TERM, predterm, PL_TERM, msgterm); } if ( rc ) rc = PL_unify_term(except, CompoundArg("error", 2), PL_TERM, formal, PL_TERM, swi); if ( rc ) rc = PL_raise_exception(except); PL_close_foreign_frame(fid); return rc; }