00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020 #include <plang/context.h>
00021 #include <plang/errors.h>
00022 #include "context-priv.h"
00023 #include "term-priv.h"
00024 #include "database-priv.h"
00025 #include "parser-priv.h"
00026 #include <errno.h>
00027 #include <string.h>
00028 #include <stdio.h>
00029 #include <stdlib.h>
00030 #if defined(HAVE_LIBDL) && defined(HAVE_DLFCN_H) && defined(HAVE_DLOPEN)
00031 #include <unistd.h>
00032 #include <dlfcn.h>
00033 #define P_HAVE_DLOPEN 1
00034 #endif
00035
00039
00040
00041 static void p_context_find_system_imports(p_context *context);
00042
00049 p_context *p_context_create(void)
00050 {
00051 GC_INIT();
00052 p_context *context = GC_NEW_UNCOLLECTABLE(struct p_context);
00053 if (!context)
00054 return 0;
00055 context->nil_atom = p_term_create_atom(context, "[]");
00056 context->prototype_atom = p_term_create_atom(context, "prototype");
00057 context->class_name_atom = p_term_create_atom(context, "className");
00058 context->dot_atom = p_term_create_atom(context, ".");
00059 context->clause_atom = p_term_create_atom(context, ":-");
00060 context->dcg_atom = p_term_create_atom(context, "-->");
00061 context->comma_atom = p_term_create_atom(context, ",");
00062 context->line_atom = p_term_create_atom(context, "$$line");
00063 context->if_atom = p_term_create_atom(context, "->");
00064 context->in_atom = p_term_create_atom(context, "in");
00065 context->slash_atom = p_term_create_atom(context, "/");
00066 context->true_atom = p_term_create_atom(context, "true");
00067 context->fail_atom = p_term_create_atom(context, "fail");
00068 context->commit_atom = p_term_create_atom(context, "commit");
00069 context->call_member_atom = p_term_create_atom(context, "$$call_member");
00070 context->call_args_atom = p_term_create_atom(context, "$$");
00071 context->unify_atom = p_term_create_atom(context, "=");
00072 context->pop_catch_atom = p_term_create_atom(context, "$$pop_catch");
00073 context->pop_database_atom = p_term_create_atom(context, "$$pop_database");
00074 context->trail_top = P_TRACE_SIZE;
00075 context->confidence = 1.0;
00076 _p_db_init(context);
00077 _p_db_init_builtins(context);
00078 _p_db_init_arith(context);
00079 _p_db_init_io(context);
00080 _p_db_init_fuzzy(context);
00081 _p_db_init_sort(context);
00082 p_context_find_system_imports(context);
00083 return context;
00084 }
00085
00086 static void p_context_free_libraries(p_context *context);
00087
00094 void p_context_free(p_context *context)
00095 {
00096 if (!context)
00097 return;
00098 p_context_free_libraries(context);
00099 GC_FREE(context);
00100 }
00101
00102
00103 P_INLINE int p_context_push_trail(p_context *context, void **word)
00104 {
00105 if (context->trail_top >= P_TRACE_SIZE) {
00106 struct p_trail *trail = GC_NEW(struct p_trail);
00107 if (!trail)
00108 return 0;
00109 trail->next = context->trail;
00110 context->trail = trail;
00111 context->trail_top = 0;
00112 }
00113 context->trail->bindings[(context->trail_top)++] = word;
00114 return 1;
00115 }
00116
00117
00118 P_INLINE void **p_context_pop_trail(p_context *context, void *marker)
00119 {
00120 void **word;
00121 void ***wordp;
00122
00123
00124 if (!context->trail)
00125 return 0;
00126 wordp = &(context->trail->bindings[context->trail_top]);
00127 if (wordp == (void ***)marker)
00128 return 0;
00129
00130
00131
00132 --(context->trail_top);
00133 word = *(--wordp);
00134 *wordp = 0;
00135
00136
00137 if (context->trail_top <= 0) {
00138 struct p_trail *trail = context->trail;
00139 context->trail = trail->next;
00140 context->trail_top = P_TRACE_SIZE;
00141 GC_FREE(trail);
00142 }
00143 return word;
00144 }
00145
00153 void *p_context_mark_trail(p_context *context)
00154 {
00155 if (context->trail)
00156 return (void *)&(context->trail->bindings[context->trail_top]);
00157 else
00158 return 0;
00159 }
00160
00168 void p_context_backtrack_trail(p_context *context, void *marker)
00169 {
00170 void **word;
00171 while ((word = p_context_pop_trail(context, marker)) != 0) {
00172 if (!(((long)word) & 1L)) {
00173
00174 *word = 0;
00175 } else {
00176
00177 void *value = (void *)p_context_pop_trail(context, marker);
00178 word = (void **)(((long)word) & ~1L);
00179 *word = value;
00180 }
00181 }
00182 }
00183
00184 int _p_context_record_in_trail(p_context *context, p_term *var)
00185 {
00186 return p_context_push_trail(context, (void **)&(var->var.value));
00187 }
00188
00189 int _p_context_record_contents_in_trail(p_context *context, void **location, void *prev_value)
00190 {
00191 long loc = ((long)location) | 1L;
00192 if (!p_context_push_trail(context, (void **)prev_value))
00193 return 0;
00194 if (p_context_push_trail(context, (void **)loc))
00195 return 1;
00196 p_context_pop_trail(context, 0);
00197 return 0;
00198 }
00199
00200
00201 int p_term_lex_init_extra(p_input_stream *extra, yyscan_t *scanner);
00202 int p_term_lex_destroy(yyscan_t scanner);
00203 int p_term_parse(p_context *context, yyscan_t scanner);
00204
00205 int p_context_consult(p_context *context, p_input_stream *stream)
00206 {
00207 yyscan_t scanner;
00208 int error, ok;
00209
00210
00211 if (p_term_lex_init_extra(stream, &scanner) != 0) {
00212 error = errno;
00213 if (stream->close_stream)
00214 fclose(stream->stream);
00215 return error;
00216 }
00217
00218
00219 ok = (p_term_parse(context, scanner) == 0);
00220 if (stream->error_count != 0)
00221 ok = 0;
00222
00223
00224 if (stream->generate_vars) {
00225 size_t index;
00226 p_term *tail = 0;
00227 p_term *new_tail;
00228 for (index = 0; index < stream->num_variables; ++index) {
00229 p_term *head = p_term_create_functor
00230 (context, context->unify_atom, 2);
00231 p_term_bind_functor_arg
00232 (head, 0, stream->variables[index].name);
00233 p_term_bind_functor_arg
00234 (head, 1, stream->variables[index].var);
00235 new_tail = p_term_create_list(context, head, 0);
00236 if (tail)
00237 p_term_set_tail(tail, new_tail);
00238 else
00239 stream->vars = new_tail;
00240 tail = new_tail;
00241 }
00242 if (tail)
00243 p_term_set_tail(tail, context->nil_atom);
00244 else
00245 stream->vars = context->nil_atom;
00246 }
00247
00248
00249 if (stream->variables)
00250 GC_FREE(stream->variables);
00251 if (stream->close_stream)
00252 fclose(stream->stream);
00253 p_term_lex_destroy(scanner);
00254
00255
00256 if (ok && stream->declarations) {
00257 p_term *list = stream->declarations;
00258 p_term *clause_atom = context->clause_atom;
00259 p_term *goal_atom = p_term_create_atom(context, "?-");
00260 p_term *test_goal_atom = p_term_create_atom(context, "\?\?--");
00261 p_term *read_atom = p_term_create_atom(context, "\?\?-");
00262 p_term *decl;
00263 while (list->header.type == P_TERM_LIST) {
00264 decl = p_term_deref(list->list.head);
00265 if (decl && decl->header.type == P_TERM_FUNCTOR &&
00266 decl->header.size == 3 &&
00267 decl->functor.functor_name == context->line_atom)
00268 decl = p_term_deref(p_term_arg(decl, 2));
00269 if (decl && decl->header.type == P_TERM_FUNCTOR) {
00270 if (decl->functor.functor_name == clause_atom) {
00271
00272 p_db_clause_assert_last(context, decl);
00273 } else if (decl->functor.functor_name == goal_atom) {
00274
00275 if (p_goal_call_from_parser
00276 (context, p_term_arg(decl, 0)) != P_RESULT_TRUE)
00277 ok = 0;
00278 } else if (decl->functor.functor_name == test_goal_atom) {
00279
00280
00281 if (context->allow_test_goals)
00282 context->test_goal = p_term_arg(decl, 0);
00283 } else if (decl->functor.functor_name == read_atom) {
00284 stream->read_term = p_term_arg(decl, 0);
00285 }
00286 }
00287 list = list->list.tail;
00288 }
00289 }
00290 return ok ? 0 : EINVAL;
00291 }
00292
00293 static int p_stdio_read_func
00294 (p_input_stream *stream, char *buf, size_t max_size)
00295 {
00296 size_t result;
00297 errno = 0;
00298 while ((result = fread(buf, 1, max_size, stream->stream)) == 0
00299 && ferror(stream->stream)) {
00300 if (errno != EINTR)
00301 break;
00302 errno = 0;
00303 clearerr(stream->stream);
00304 }
00305 return (int)result;
00306 }
00307
00349 int p_context_consult_file
00350 (p_context *context, const char *filename, p_consult_option option)
00351 {
00352 p_input_stream stream;
00353 memset(&stream, 0, sizeof(stream));
00354 stream.context = context;
00355 stream.read_func = p_stdio_read_func;
00356 if (!strcmp(filename, "-")) {
00357 stream.stream = stdin;
00358 stream.filename = "(standard-input)";
00359 stream.close_stream = 0;
00360 } else {
00361 if (option == P_CONSULT_ONCE) {
00362 size_t index;
00363 for (index = 0; index < context->loaded_files.num_paths; ++index) {
00364 if (!strcmp(filename, context->loaded_files.paths[index]))
00365 return 0;
00366 }
00367 }
00368 stream.stream = fopen(filename, "r");
00369 if (!stream.stream)
00370 return errno;
00371 stream.filename = filename;
00372 stream.close_stream = 1;
00373 p_context_add_path(context->loaded_files, filename);
00374 }
00375 return p_context_consult(context, &stream);
00376 }
00377
00378 int p_string_read_func(p_input_stream *stream, char *buf, size_t max_size)
00379 {
00380 size_t len = max_size;
00381 if (len > stream->buffer_len)
00382 len = stream->buffer_len;
00383 if (len > 0) {
00384 memcpy(buf, stream->buffer, len);
00385 stream->buffer += len;
00386 stream->buffer_len -= len;
00387 }
00388 return (int)len;
00389 }
00390
00406 int p_context_consult_string(p_context *context, const char *str)
00407 {
00408 p_input_stream stream;
00409 if (!str)
00410 return ENOENT;
00411 memset(&stream, 0, sizeof(stream));
00412 stream.context = context;
00413 stream.buffer = str;
00414 stream.buffer_len = strlen(str);
00415 stream.read_func = p_string_read_func;
00416 return p_context_consult(context, &stream);
00417 }
00418
00456
00457 void _p_context_basic_fail_func
00458 (p_context *context, p_exec_fail_node *node)
00459 {
00460 p_context_backtrack_trail(context, node->fail_marker);
00461 context->confidence = node->confidence;
00462 context->catch_node = node->catch_node;
00463 context->database = node->database;
00464 }
00465
00466
00467
00468 void _p_context_clause_fail_func
00469 (p_context *context, p_exec_fail_node *node)
00470 {
00471 p_exec_clause_node *current = (p_exec_clause_node *)node;
00472 p_term_clause_iter clause_iter;
00473 p_term *clause;
00474 p_term *body;
00475 p_exec_node *new_current;
00476
00477
00478 _p_context_basic_fail_func(context, node);
00479
00480
00481
00482
00483 clause_iter = current->clause_iter;
00484 body = 0;
00485 while ((clause = p_term_clauses_next(&clause_iter)) != 0) {
00486 body = p_term_unify_clause
00487 (context, current->parent.parent.goal, clause);
00488 if (body)
00489 break;
00490 }
00491 if (body) {
00492 if (p_term_clauses_has_more(&clause_iter)) {
00493 p_exec_clause_node *next = GC_NEW(p_exec_clause_node);
00494 if (next) {
00495 next->parent.parent.goal = current->parent.parent.goal;
00496 next->parent.parent.success_node = current->parent.parent.success_node;
00497 next->parent.parent.cut_node = current->parent.parent.cut_node;
00498 _p_context_init_fail_node
00499 (context, &(next->parent), _p_context_clause_fail_func);
00500 next->parent.fail_marker = current->parent.fail_marker;
00501 next->clause_iter = clause_iter;
00502 context->fail_node = &(next->parent);
00503 } else {
00504 body = context->fail_atom;
00505 }
00506 }
00507 } else {
00508 body = context->fail_atom;
00509 }
00510 new_current = GC_NEW(p_exec_node);
00511 if (new_current) {
00512 new_current->goal = body;
00513 new_current->success_node = current->parent.parent.success_node;
00514 new_current->cut_node = current->parent.parent.cut_node;
00515 context->current_node = new_current;
00516 } else {
00517 current->parent.parent.goal = context->fail_atom;
00518 }
00519 }
00520
00521 void _p_context_init_fail_node
00522 (p_context *context, p_exec_fail_node *node,
00523 p_exec_fail_func fail_func)
00524 {
00525 node->parent.fail_func = fail_func;
00526 node->fail_marker = context->fail_marker;
00527 node->confidence = context->confidence;
00528 node->catch_node = context->catch_node;
00529 node->database = context->database;
00530 }
00531
00532
00533
00534 static p_goal_result p_goal_execute_inner(p_context *context, p_term *goal, p_term **error)
00535 {
00536 p_term *pred;
00537 p_term *name;
00538 unsigned int arity;
00539 p_db_builtin builtin;
00540 p_database_info *info;
00541 p_exec_node *current;
00542 p_exec_node *next;
00543 p_exec_node *new_current;
00544 p_term *predicate;
00545
00546
00547
00548 if (!goal || (goal->header.type & P_TERM_VARIABLE) != 0) {
00549 *error = p_create_instantiation_error(context);
00550 return P_RESULT_ERROR;
00551 }
00552
00553
00554 if (goal->header.type == P_TERM_ATOM) {
00555 name = goal;
00556 arity = 0;
00557 } else if (goal->header.type == P_TERM_FUNCTOR) {
00558 if (goal->header.size == 2 &&
00559 goal->functor.functor_name == context->comma_atom) {
00560
00561
00562
00563 current = context->current_node;
00564 next = GC_NEW(p_exec_node);
00565 new_current = GC_NEW(p_exec_node);
00566 if (!next || !new_current)
00567 return P_RESULT_FAIL;
00568 new_current->goal = goal->functor.arg[0];
00569 new_current->success_node = next;
00570 new_current->cut_node = current->cut_node;
00571 next->goal = goal->functor.arg[1];
00572 next->success_node = current->success_node;
00573 next->cut_node = current->cut_node;
00574 context->current_node = new_current;
00575 return P_RESULT_TREE_CHANGE;
00576 }
00577 name = goal->functor.functor_name;
00578 arity = goal->header.size;
00579 } else {
00580
00581 *error = p_create_type_error(context, "callable", goal);
00582 return P_RESULT_ERROR;
00583 }
00584
00585
00586 info = name->atom.db_info;
00587 while (info && info->arity != arity)
00588 info = info->next;
00589 if (info && (builtin = info->builtin_func) != 0) {
00590 if (arity != 0)
00591 return (*builtin)(context, goal->functor.arg, error);
00592 else
00593 return (*builtin)(context, 0, error);
00594 }
00595
00596
00597 predicate = info ? info->predicate : 0;
00598 if (context->database) {
00599 p_term *pred = p_term_database_lookup_predicate
00600 (context->database, name, arity);
00601 if (pred)
00602 predicate = pred;
00603 }
00604
00605
00606 if (predicate) {
00607 p_term_clause_iter clause_iter;
00608 p_term_clauses_begin(predicate, goal, &clause_iter);
00609 p_term *clause;
00610 p_term *body;
00611 while ((clause = p_term_clauses_next(&clause_iter)) != 0) {
00612
00613 body = p_term_unify_clause(context, goal, clause);
00614 if (body) {
00615 current = context->current_node;
00616 if (p_term_clauses_has_more(&clause_iter)) {
00617 p_exec_clause_node *next = GC_NEW(p_exec_clause_node);
00618 new_current = GC_NEW(p_exec_node);
00619 if (!next || !new_current)
00620 return P_RESULT_FAIL;
00621 next->parent.parent.goal = current->goal;
00622 next->parent.parent.success_node = current->success_node;
00623 next->parent.parent.cut_node = context->fail_node;
00624 _p_context_init_fail_node
00625 (context, &(next->parent), _p_context_clause_fail_func);
00626 next->clause_iter = clause_iter;
00627 new_current->goal = body;
00628 new_current->success_node = current->success_node;
00629 new_current->cut_node = context->fail_node;
00630 context->current_node = new_current;
00631 context->fail_node = &(next->parent);
00632 } else {
00633 new_current = GC_NEW(p_exec_node);
00634 if (!new_current)
00635 return P_RESULT_FAIL;
00636 new_current->goal = body;
00637 new_current->success_node = current->success_node;
00638 new_current->cut_node = context->fail_node;
00639 context->current_node = new_current;
00640 }
00641 return P_RESULT_TREE_CHANGE;
00642 }
00643 }
00644 return P_RESULT_FAIL;
00645 }
00646
00647
00648 if (context->fail_on_unknown)
00649 return P_RESULT_FAIL;
00650 pred = p_term_create_functor(context, context->slash_atom, 2);
00651 p_term_bind_functor_arg(pred, 0, name);
00652 p_term_bind_functor_arg
00653 (pred, 1, p_term_create_integer(context, (int)arity));
00654 *error = p_create_existence_error(context, "procedure", pred);
00655 return P_RESULT_ERROR;
00656 }
00657
00658
00659 int p_builtin_handle_catch(p_context *context, p_term *error);
00660
00661
00662 static p_goal_result p_goal_execute(p_context *context, p_term **error)
00663 {
00664 p_term *goal;
00665 p_goal_result result = P_RESULT_FAIL;
00666 p_exec_node *current;
00667
00668 for (;;) {
00669
00670 current = context->current_node;
00671 goal = p_term_deref_member(context, current->goal);
00672
00673
00674 #ifdef P_GOAL_DEBUG
00675 {
00676 p_term_print(context, goal,
00677 p_term_stdio_print_func, stdout);
00678 putc('\n', stdout);
00679 if (context->current_node->success_node) {
00680 fputs("\tsuccess: ", stdout);
00681 p_term_print
00682 (context, context->current_node->success_node->goal,
00683 p_term_stdio_print_func, stdout);
00684 putc('\n', stdout);
00685 } else {
00686 fputs("\tsuccess: top-level success\n", stdout);
00687 }
00688 if (context->fail_node) {
00689 fputs("\tfail: ", stdout);
00690 p_term_print
00691 (context, context->fail_node->parent.goal,
00692 p_term_stdio_print_func, stdout);
00693 putc('\n', stdout);
00694 } else {
00695 fputs("\tfail: top-level fail\n", stdout);
00696 }
00697 if (context->current_node->cut_node) {
00698 fputs("\tcut: ", stdout);
00699 p_term_print
00700 (context, context->current_node->cut_node->parent.goal,
00701 p_term_stdio_print_func, stdout);
00702 putc('\n', stdout);
00703 } else {
00704 fputs("\tcut: top-level fail\n", stdout);
00705 }
00706 if (context->catch_node) {
00707 fputs("\tcatch: ", stdout);
00708 p_term_print
00709 (context, context->catch_node->parent.parent.goal,
00710 p_term_stdio_print_func, stdout);
00711 putc('\n', stdout);
00712 }
00713 }
00714 #endif
00715
00716
00717 *error = 0;
00718 context->fail_marker = p_context_mark_trail(context);
00719 result = p_goal_execute_inner(context, goal, error);
00720 if (result == P_RESULT_TRUE) {
00721
00722 #ifdef P_GOAL_DEBUG
00723 fputs("\tresult: true\n", stdout);
00724 #endif
00725 current = context->current_node;
00726 context->current_node = current->success_node;
00727 if (!(context->current_node)) {
00728
00729
00730 context->current_node = &(context->fail_node->parent);
00731 if (context->current_node)
00732 context->fail_node = context->current_node->cut_node;
00733 else
00734 context->fail_node = 0;
00735 break;
00736 }
00737 } else if (result == P_RESULT_FAIL) {
00738
00739 #ifdef P_GOAL_DEBUG
00740 fputs("\tresult: fail\n", stdout);
00741 #endif
00742 context->current_node = &(context->fail_node->parent);
00743 if (!(context->current_node))
00744 break;
00745 context->fail_node = context->current_node->cut_node;
00746 (*(context->current_node->fail_func))
00747 (context, (p_exec_fail_node *)(context->current_node));
00748 } else if (result == P_RESULT_ERROR) {
00749
00750 #ifdef P_GOAL_DEBUG
00751 fputs("\tresult: throw(", stdout);
00752 p_term_print
00753 (context, *error, p_term_stdio_print_func, stdout);
00754 fputs(")\n", stdout);
00755 #endif
00756 if (!p_builtin_handle_catch(context, *error))
00757 break;
00758 *error = 0;
00759 } else if (result == P_RESULT_HALT) {
00760
00761 #ifdef P_GOAL_DEBUG
00762 fputs("\tresult: halt(", stdout);
00763 p_term_print
00764 (context, *error, p_term_stdio_print_func, stdout);
00765 fputs(")\n", stdout);
00766 #endif
00767 break;
00768 } else {
00769
00770
00771 }
00772 }
00773
00774 return result;
00775 }
00776
00796 p_goal_result p_context_execute_goal
00797 (p_context *context, p_term *goal, p_term **error)
00798 {
00799 p_term *error_term = 0;
00800 p_goal_result result;
00801 p_context_abandon_goal(context);
00802 #ifdef P_GOAL_DEBUG
00803 fputs("top-level goal: ", stdout);
00804 p_term_print(context, goal, p_term_stdio_print_func, stdout);
00805 putc('\n', stdout);
00806 #endif
00807 context->current_node = GC_NEW(p_exec_node);
00808 if (!context->current_node)
00809 return P_RESULT_FAIL;
00810 context->current_node->goal = goal;
00811 context->fail_node = 0;
00812 context->catch_node = 0;
00813 context->confidence = 1.0;
00814 context->database = 0;
00815 context->goal_active = 1;
00816 context->goal_marker = p_context_mark_trail(context);
00817 result = p_goal_execute(context, &error_term);
00818 if (error)
00819 *error = error_term;
00820 if (result != P_RESULT_TRUE) {
00821 context->current_node = 0;
00822 context->fail_node = 0;
00823 context->confidence = 0.0;
00824 }
00825 return result;
00826 }
00827
00848 p_goal_result p_context_reexecute_goal(p_context *context, p_term **error)
00849 {
00850 p_term *error_term = 0;
00851 p_goal_result result;
00852 if (!context->current_node)
00853 return P_RESULT_FAIL;
00854 (*(context->current_node->fail_func))
00855 (context, (p_exec_fail_node *)(context->current_node));
00856 result = p_goal_execute(context, &error_term);
00857 if (error)
00858 *error = error_term;
00859 if (result != P_RESULT_TRUE) {
00860 context->current_node = 0;
00861 context->fail_node = 0;
00862 context->confidence = 0.0;
00863 context->database = 0;
00864 }
00865 return result;
00866 }
00867
00878 void p_context_abandon_goal(p_context *context)
00879 {
00880 if (context->goal_active) {
00881 p_context_backtrack_trail(context, context->goal_marker);
00882 context->goal_active = 0;
00883 context->goal_marker = 0;
00884 context->current_node = 0;
00885 context->fail_node = 0;
00886 context->catch_node = 0;
00887 context->confidence = 1.0;
00888 context->database = 0;
00889 }
00890 }
00891
00911 double p_context_fuzzy_confidence(p_context *context)
00912 {
00913 return context->confidence;
00914 }
00915
00930 void p_context_set_fuzzy_confidence(p_context *context, double value)
00931 {
00932 if (value < 0.00001)
00933 value = 0.00001;
00934 else if (value > 1.0)
00935 value = 1.0;
00936 context->confidence = value;
00937 }
00938
00950 p_goal_result p_context_call_once
00951 (p_context *context, p_term *goal, p_term **error)
00952 {
00953 p_goal_result result;
00954 p_exec_node *current = context->current_node;
00955 p_exec_fail_node *fail = context->fail_node;
00956 p_exec_catch_node *catch_node = context->catch_node;
00957 double confidence = context->confidence;
00958 p_term *database = context->database;
00959 p_exec_node *goal_node = GC_NEW(p_exec_node);
00960 p_term *error_node = 0;
00961 if (goal_node) {
00962 goal_node->goal = goal;
00963 context->current_node = goal_node;
00964 context->fail_node = 0;
00965 context->catch_node = 0;
00966 context->confidence = 1.0;
00967 context->database = 0;
00968 result = p_goal_execute(context, &error_node);
00969 if (result == P_RESULT_TRUE && context->confidence != 1.0) {
00970
00971 if (context->confidence < confidence)
00972 confidence = context->confidence;
00973 }
00974 context->current_node = current;
00975 context->fail_node = fail;
00976 context->catch_node = catch_node;
00977 context->confidence = confidence;
00978 context->database = database;
00979 } else {
00980 result = P_RESULT_FAIL;
00981 }
00982 if (error)
00983 *error = error_node;
00984 return result;
00985 }
00986
00987
00988
00989 p_goal_result p_goal_call_from_parser(p_context *context, p_term *goal)
00990 {
00991 p_term *error = 0;
00992 void *marker = p_context_mark_trail(context);
00993 p_goal_result result;
00994 p_exec_node *current = context->current_node;
00995 p_exec_fail_node *fail = context->fail_node;
00996 p_exec_catch_node *catch_node = context->catch_node;
00997 double confidence = context->confidence;
00998 p_term *database = context->database;
00999 p_exec_node *goal_node = GC_NEW(p_exec_node);
01000 if (goal_node) {
01001 goal_node->goal = goal;
01002 context->current_node = goal_node;
01003 context->fail_node = 0;
01004 context->catch_node = 0;
01005 context->confidence = 1.0;
01006 context->database = 0;
01007 result = p_goal_execute(context, &error);
01008 context->current_node = current;
01009 context->fail_node = fail;
01010 context->catch_node = catch_node;
01011 context->confidence = confidence;
01012 context->database = database;
01013 } else {
01014 result = P_RESULT_FAIL;
01015 }
01016 p_context_backtrack_trail(context, marker);
01017 if (result == P_RESULT_TRUE)
01018 return result;
01019 goal = p_term_deref_member(context, goal);
01020 if (goal && goal->header.type == P_TERM_FUNCTOR &&
01021 goal->header.size == 3 &&
01022 goal->functor.functor_name == context->line_atom) {
01023 p_term_print_unquoted
01024 (context, p_term_arg(goal, 0),
01025 p_term_stdio_print_func, stderr);
01026 putc(':', stderr);
01027 p_term_print_unquoted
01028 (context, p_term_arg(goal, 1),
01029 p_term_stdio_print_func, stderr);
01030 putc(':', stderr);
01031 putc(' ', stderr);
01032 p_term_print
01033 (context, p_term_arg(goal, 2),
01034 p_term_stdio_print_func, stderr);
01035 } else {
01036 p_term_print(context, goal, p_term_stdio_print_func, stderr);
01037 }
01038 if (result == P_RESULT_ERROR) {
01039 fputs(": uncaught error: ", stderr);
01040 p_term_print(context, error, p_term_stdio_print_func, stderr);
01041 putc('\n', stderr);
01042 } else if (result == P_RESULT_HALT) {
01043 fputs(": halt during directive\n", stderr);
01044 } else {
01045 fputs(": fail\n", stderr);
01046 }
01047 return result;
01048 }
01049
01050
01051 p_term *_p_context_test_goal(p_context *context)
01052 {
01053 p_term *goal = context->test_goal;
01054 context->allow_test_goals = 1;
01055 context->test_goal = 0;
01056 return goal;
01057 }
01058
01065 int p_context_is_debug(p_context *context)
01066 {
01067 return context->debug ? 1 : 0;
01068 }
01069
01076 void p_context_set_debug(p_context *context, int debug)
01077 {
01078 context->debug = debug;
01079 }
01080
01088 void p_context_add_import_path(p_context *context, const char *path)
01089 {
01090 p_context_add_path(context->user_imports, path);
01091 }
01092
01100 void p_context_add_library_path(p_context *context, const char *path)
01101 {
01102 p_context_add_path(context->user_libs, path);
01103 }
01104
01105 static p_term *p_create_load_library_error
01106 (p_context *context, p_term *name, const char *message)
01107 {
01108 p_term *error = p_term_create_functor
01109 (context, p_term_create_atom(context, "load_library_error"), 2);
01110 p_term_bind_functor_arg(error, 0, name);
01111 p_term_bind_functor_arg
01112 (error, 1, p_term_create_string(context, message));
01113 return p_create_generic_error(context, error);
01114 }
01115
01116 #if defined(HAVE_DLOPEN)
01117
01118 static char *p_context_library_path
01119 (const char *path, const char *prefix,
01120 const char *base_name, const char *suffix)
01121 {
01122 char *lib_path = (char *)malloc
01123 (strlen(path) + 1 + strlen(prefix) + strlen(base_name) + strlen(suffix) + 1);
01124 if (!lib_path)
01125 return 0;
01126 strcpy(lib_path, path);
01127 strcat(lib_path, "/");
01128 strcat(lib_path, prefix);
01129 strcat(lib_path, base_name);
01130 strcat(lib_path, suffix);
01131 if (access(lib_path, 0) >= 0)
01132 return lib_path;
01133 free(lib_path);
01134 return 0;
01135 }
01136
01137 #endif
01138
01139 p_goal_result _p_context_load_library(p_context *context, p_term *name, p_term **error)
01140 {
01141 #if defined(HAVE_DLOPEN)
01142 const char *base_name = p_term_name(name);
01143 size_t index;
01144 char *lib_path;
01145 void *handle;
01146 p_library_entry_func setup_func;
01147 p_library_entry_func shutdown_func;
01148 p_library *library;
01149
01150
01151
01152 if (*base_name == '\0' || strchr(base_name, '/') != 0 ||
01153 strchr(base_name, '\\') != 0) {
01154 *error = p_create_type_error(context, "library_name", name);
01155 return P_RESULT_ERROR;
01156 }
01157
01158
01159 lib_path = 0;
01160 for (index = 0; !lib_path && index < context->user_libs.num_paths; ++index) {
01161 lib_path = p_context_library_path
01162 (context->user_libs.paths[index], "lib", base_name, ".so");
01163 }
01164 for (index = 0; !lib_path && index < context->system_libs.num_paths; ++index) {
01165 lib_path = p_context_library_path
01166 (context->system_libs.paths[index], "lib", base_name, ".so");
01167 }
01168 if (!lib_path) {
01169 *error = p_create_existence_error(context, "library", name);
01170 return P_RESULT_ERROR;
01171 }
01172
01173
01174 dlerror();
01175 handle = dlopen(lib_path, RTLD_LAZY | RTLD_LOCAL);
01176 if (!handle) {
01177 *error = p_create_load_library_error(context, name, dlerror());
01178 free(lib_path);
01179 return P_RESULT_ERROR;
01180 }
01181 setup_func = (p_library_entry_func)dlsym(handle, "plang_module_setup");
01182 shutdown_func = (p_library_entry_func)dlsym(handle, "plang_module_shutdown");
01183 if (!setup_func) {
01184 *error = p_create_load_library_error
01185 (context, name,
01186 "plang_module_setup() entry point not found");
01187 free(lib_path);
01188 return P_RESULT_ERROR;
01189 }
01190 free(lib_path);
01191
01192
01193 (*setup_func)(context);
01194
01195
01196 library = GC_NEW(p_library);
01197 library->handle = handle;
01198 library->shutdown_func = shutdown_func;
01199 library->next = context->libraries;
01200 context->libraries = library;
01201
01202
01203 return P_RESULT_TRUE;
01204 #else
01205 *error = p_create_load_library_error
01206 (context, name, "do not know how to load libraries");
01207 return P_RESULT_ERROR;
01208 #endif
01209 }
01210
01211 static void p_context_free_libraries(p_context *context)
01212 {
01213 #if defined(HAVE_DLOPEN)
01214 p_library *library = context->libraries;
01215 while (library != 0) {
01216 if (library->shutdown_func)
01217 (*(library->shutdown_func))(context);
01218 dlclose(library->handle);
01219 library = library->next;
01220 }
01221 #endif
01222 }
01223
01224
01225 static void p_context_find_system_imports(p_context *context)
01226 {
01227 #if !defined(P_WIN32)
01228 #if defined(P_SYSTEM_IMPORT_PATH)
01229 p_context_add_path(context->system_imports, P_SYSTEM_IMPORT_PATH);
01230 #else
01231 p_context_add_path(context->system_imports, "/usr/local/share/plang/imports");
01232 p_context_add_path(context->system_imports, "/opt/local/share/plang/imports");
01233 p_context_add_path(context->system_imports, "/usr/share/plang/imports");
01234 p_context_add_path(context->system_imports, "/opt/share/plang/imports");
01235 #endif
01236
01237 #if defined(P_SYSTEM_LIB_PATH)
01238 p_context_add_path(context->system_libs, P_SYSTEM_LIB_PATH);
01239 #else
01240 p_context_add_path(context->system_libs, "/usr/local/lib/plang");
01241 p_context_add_path(context->system_libs, "/opt/local/lib/plang");
01242 p_context_add_path(context->system_libs, "/usr/lib/plang");
01243 p_context_add_path(context->system_libs, "/opt/lib/plang");
01244 #endif
01245 #else
01246
01247 #endif
01248 }
01249
01250