This commit is contained in:
Vitor Santos Costa
2017-06-05 13:06:12 +01:00
parent 78768c354c
commit 2ad3420fac
155 changed files with 2502 additions and 45809 deletions

View File

@@ -5,7 +5,7 @@ INCLUDE(NewUseSWIG)
include(FindPythonModule)
set (PROLOG_SOURCES ${CMAKE_CURRENT_SOURCE_DIR}/yapi.yap)
set (PROLOG_SOURCES ${CMAKE_CURRENT_SOURCE_DIR}/yapi.yap ${CMAKE_CURRENT_SOURCE_DIR}/jupyter.yap)
set (PYTHON_SOURCES ${CMAKE_CURRENT_SOURCE_DIR}/yapi.py ${CMAKE_CURRENT_SOURCE_DIR}/__init__.py ${CMAKE_CURRENT_SOURCE_DIR}/__main__.py)
file(RELATIVE_PATH RELATIVE_SOURCE ${CMAKE_CURRENT_BINARY_DIR} ${CMAKE_SOURCE_DIR})
@@ -59,28 +59,31 @@ else()
)
endif()
file( MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog/pl )
file( MAKE_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog/os )
set (PL ${pl_library} ${PROLOG_SOURCES} )
add_custom_target( YAP4PY ALL
COMMAND ${CMAKE_COMMAND} -E copy ${dlls} ${CMAKE_BINARY_DIR}/libYap${CMAKE_SHARED_LIBRARY_SUFFIX} ${CMAKE_BINARY_DIR}/${YAP_STARTUP} ${CMAKE_CURRENT_BINARY_DIR}/yap4py
COMMAND ${CMAKE_COMMAND} -E copy ${pl_library} ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog
COMMAND ${CMAKE_COMMAND} -E copy ${PYTHON_SOURCES} ${CMAKE_CURRENT_BINARY_DIR}/yap4py
COMMAND ${CMAKE_COMMAND} -E copy ${CMAKE_CURRENT_SOURCE_DIR}/yapi.yap ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog
COMMAND ${CMAKE_COMMAND} -E copy ${pl_library} ${PROLOG_SOURCES} ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog
COMMAND ${CMAKE_COMMAND} -E copy ${pl_boot_library} ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog/pl
COMMAND ${CMAKE_COMMAND} -E copy ${pl_os_library} ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog/os
COMMAND ${PYTHON_EXECUTABLE} ${CMAKE_CURRENT_BINARY_DIR}/setup.py sdist bdist_wheel
WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}
add_custom_target( YAP4PY_SETUP
COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_CURRENT_BINARY_DIR}/yap4py
COMMAND ${CMAKE_COMMAND} -E copy ${dlls} ${CMAKE_BINARY_DIR}/libYap${CMAKE_SHARED_LIBRARY_SUFFIX} ${CMAKE_BINARY_DIR}/${YAP_STARTUP} ${PYTHON_SOURCES} ${CMAKE_CURRENT_BINARY_DIR}/yap4py
COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog
COMMAND ${CMAKE_COMMAND} -E copy ${PL} ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog
COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog/pl
COMMAND ${CMAKE_COMMAND} -E copy ${pl_boot_library} ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog/pl
COMMAND ${CMAKE_COMMAND} -E make_directory ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog/os
COMMAND ${CMAKE_COMMAND} -E copy ${pl_os_library} ${CMAKE_CURRENT_BINARY_DIR}/yap4py/prolog/os
DEPENDS STARTUP ${dlls} ${PYTHON_SOURCES} ${PROLOG_SOURCES} ${CMAKE_CURRENT_BINARY_DIR}/setup.py ${SWIG_MODULE_Py2YAP_REAL_NAME} )
add_custom_target( YAP4PY ALL
COMMAND ${PYTHON_EXECUTABLE} setup.py sdist bdist_wheel
WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}
DEPENDS YAP4PY_SETUP)
install(CODE "execute_process(COMMAND ${PYTHON_EXECUTABLE} -m pip install --force --no-index -f dist yap4py
WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR})"
DEPENDS Py4YAP ${CMAKE_BINARY_DIR}/${YAP_STARTUP} ${dlls} )
install(FILES yapi.yap DESTINATION ${libpl})
install(FILES ${PROLOG_SOURCES} DESTINATION ${libpl})

View File

@@ -1,406 +0,0 @@
index(foreach,2,aggretate,library(aggregate)).
index(aggregate,3,aggretate,library(aggregate)).
index(aggregate,4,aggretate,library(aggregate)).
index(aggregate_all,3,aggretate,library(aggregate)).
index(aggregate_all,4,aggretate,library(aggregate)).
index(free_variables,4,aggretate,library(aggregate)).
index(genarg,3,arg,library(arg)).
index(arg0,3,arg,library(arg)).
index(genarg0,3,arg,library(arg)).
index(args,3,arg,library(arg)).
index(args0,3,arg,library(arg)).
index(path_arg,3,arg,library(arg)).
index(empty_assoc,1,assoc,library(assoc)).
index(assoc_to_list,2,assoc,library(assoc)).
index(is_assoc,1,assoc,library(assoc)).
index(min_assoc,3,assoc,library(assoc)).
index(max_assoc,3,assoc,library(assoc)).
index(gen_assoc,3,assoc,library(assoc)).
index(get_assoc,3,assoc,library(assoc)).
index(get_assoc,5,assoc,library(assoc)).
index(get_next_assoc,4,assoc,library(assoc)).
index(get_prev_assoc,4,assoc,library(assoc)).
index(list_to_assoc,2,assoc,library(assoc)).
index(ord_list_to_assoc,2,assoc,library(assoc)).
index(map_assoc,2,assoc,library(assoc)).
index(map_assoc,3,assoc,library(assoc)).
index(put_assoc,4,assoc,library(assoc)).
index(del_assoc,4,assoc,library(assoc)).
index(assoc_to_keys,2,assoc,library(assoc)).
index(del_min_assoc,4,assoc,library(assoc)).
index(del_max_assoc,4,assoc,library(assoc)).
index(avl_new,1,avl,library(avl)).
index(avl_insert,4,avl,library(avl)).
index(avl_lookup,3,avl,library(avl)).
index(b_hash_new,1,b_hash,library(bhash)).
index(b_hash_new,2,b_hash,library(bhash)).
index(b_hash_new,4,b_hash,library(bhash)).
index(b_hash_lookup,3,b_hash,library(bhash)).
index(b_hash_update,3,b_hash,library(bhash)).
index(b_hash_update,4,b_hash,library(bhash)).
index(b_hash_insert_new,4,b_hash,library(bhash)).
index(b_hash_insert,4,b_hash,library(bhash)).
index(format_to_chars,3,charsio,library(charsio)).
index(format_to_chars,4,charsio,library(charsio)).
index(write_to_chars,3,charsio,library(charsio)).
index(write_to_chars,2,charsio,library(charsio)).
index(atom_to_chars,3,charsio,library(charsio)).
index(atom_to_chars,2,charsio,library(charsio)).
index(number_to_chars,3,charsio,library(charsio)).
index(number_to_chars,2,charsio,library(charsio)).
index(read_from_chars,2,charsio,library(charsio)).
index(open_chars_stream,2,charsio,library(charsio)).
index(with_output_to_chars,2,charsio,library(charsio)).
index(with_output_to_chars,3,charsio,library(charsio)).
index(with_output_to_chars,4,charsio,library(charsio)).
index(term_to_atom,2,charsio,library(charsio)).
index(chr_show_store,1,chr,library(chr)).
index(find_chr_constraint,1,chr,library(chr)).
index(chr_trace,0,chr,library(chr)).
index(chr_notrace,0,chr,library(chr)).
index(chr_leash,1,chr,library(chr)).
index(#>,2,clpfd,library(clpfd)).
index(#<,2,clpfd,library(clpfd)).
index(#>=,2,clpfd,library(clpfd)).
index(#=<,2,clpfd,library(clpfd)).
index(#=,2,clpfd,library(clpfd)).
index(#\=,2,clpfd,library(clpfd)).
index(#\,1,clpfd,library(clpfd)).
index(#<==>,2,clpfd,library(clpfd)).
index(#==>,2,clpfd,library(clpfd)).
index(#<==,2,clpfd,library(clpfd)).
index(#\/,2,clpfd,library(clpfd)).
index(#/\,2,clpfd,library(clpfd)).
index(in,2,clpfd,library(clpfd)).
index(ins,2,clpfd,library(clpfd)).
index(all_different,1,clpfd,library(clpfd)).
index(all_distinct,1,clpfd,library(clpfd)).
index(sum,3,clpfd,library(clpfd)).
index(scalar_product,4,clpfd,library(clpfd)).
index(tuples_in,2,clpfd,library(clpfd)).
index(labeling,2,clpfd,library(clpfd)).
index(label,1,clpfd,library(clpfd)).
index(indomain,1,clpfd,library(clpfd)).
index(lex_chain,1,clpfd,library(clpfd)).
index(serialized,2,clpfd,library(clpfd)).
index(global_cardinality,2,clpfd,library(clpfd)).
index(global_cardinality,3,clpfd,library(clpfd)).
index(circuit,1,clpfd,library(clpfd)).
index(element,3,clpfd,library(clpfd)).
index(automaton,3,clpfd,library(clpfd)).
index(automaton,8,clpfd,library(clpfd)).
index(transpose,2,clpfd,library(clpfd)).
index(zcompare,3,clpfd,library(clpfd)).
index(chain,2,clpfd,library(clpfd)).
index(fd_var,1,clpfd,library(clpfd)).
index(fd_inf,2,clpfd,library(clpfd)).
index(fd_sup,2,clpfd,library(clpfd)).
index(fd_size,2,clpfd,library(clpfd)).
index(fd_dom,2,clpfd,library(clpfd)).
index({},1,clpr,library(clpr)).
index(maximize,1,clpr,library(clpr)).
index(minimize,1,clpr,library(clpr)).
index(inf,2,clpr,library(clpr)).
index(inf,4,clpr,library(clpr)).
index(sup,2,clpr,library(clpr)).
index(sup,4,clpr,library(clpr)).
index(bb_inf,3,clpr,library(clpr)).
index(bb_inf,5,clpr,library(clpr)).
index(ordering,1,clpr,library(clpr)).
index(entailed,1,clpr,library(clpr)).
index(clp_type,2,clpr,library(clpr)).
index(dump,3,clpr,library(clpr)).
index(gensym,2,gensym,library(gensym)).
index(reset_gensym,1,gensym,library(gensym)).
index(reset_gensym,0,gensym,library(gensym)).
index(add_to_heap,4,heaps,library(heaps)).
index(get_from_heap,4,heaps,library(heaps)).
index(empty_heap,1,heaps,library(heaps)).
index(heap_size,2,heaps,library(heaps)).
index(heap_to_list,2,heaps,library(heaps)).
index(list_to_heap,2,heaps,library(heaps)).
index(min_of_heap,3,heaps,library(heaps)).
index(min_of_heap,5,heaps,library(heaps)).
index(jpl_get_default_jvm_opts,1,jpl,library(jpl)).
index(jpl_set_default_jvm_opts,1,jpl,library(jpl)).
index(jpl_get_actual_jvm_opts,1,jpl,library(jpl)).
index(jpl_pl_lib_version,1,jpl,library(jpl)).
index(jpl_c_lib_version,1,jpl,library(jpl)).
index(jpl_new,3,jpl,library(jpl)).
index(jpl_call,4,jpl,library(jpl)).
index(jpl_get,3,jpl,library(jpl)).
index(jpl_set,3,jpl,library(jpl)).
index(jpl_servlet_byref,3,jpl,library(jpl)).
index(jpl_servlet_byval,3,jpl,library(jpl)).
index(jpl_class_to_classname,2,jpl,library(jpl)).
index(jpl_class_to_type,2,jpl,library(jpl)).
index(jpl_classname_to_class,2,jpl,library(jpl)).
index(jpl_classname_to_type,2,jpl,library(jpl)).
index(jpl_datum_to_type,2,jpl,library(jpl)).
index(jpl_false,1,jpl,library(jpl)).
index(jpl_is_class,1,jpl,library(jpl)).
index(jpl_is_false,1,jpl,library(jpl)).
index(jpl_is_null,1,jpl,library(jpl)).
index(jpl_is_object,1,jpl,library(jpl)).
index(jpl_is_object_type,1,jpl,library(jpl)).
index(jpl_is_ref,1,jpl,library(jpl)).
index(jpl_is_true,1,jpl,library(jpl)).
index(jpl_is_type,1,jpl,library(jpl)).
index(jpl_is_void,1,jpl,library(jpl)).
index(jpl_null,1,jpl,library(jpl)).
index(jpl_object_to_class,2,jpl,library(jpl)).
index(jpl_object_to_type,2,jpl,library(jpl)).
index(jpl_primitive_type,1,jpl,library(jpl)).
index(jpl_ref_to_type,2,jpl,library(jpl)).
index(jpl_true,1,jpl,library(jpl)).
index(jpl_type_to_class,2,jpl,library(jpl)).
index(jpl_type_to_classname,2,jpl,library(jpl)).
index(jpl_void,1,jpl,library(jpl)).
index(jpl_array_to_length,2,jpl,library(jpl)).
index(jpl_array_to_list,2,jpl,library(jpl)).
index(jpl_datums_to_array,2,jpl,library(jpl)).
index(jpl_enumeration_element,2,jpl,library(jpl)).
index(jpl_enumeration_to_list,2,jpl,library(jpl)).
index(jpl_hashtable_pair,2,jpl,library(jpl)).
index(jpl_iterator_element,2,jpl,library(jpl)).
index(jpl_list_to_array,2,jpl,library(jpl)).
index(jpl_list_to_array,3,jpl,library(jpl)).
index(jpl_terms_to_array,2,jpl,library(jpl)).
index(jpl_map_element,2,jpl,library(jpl)).
index(jpl_set_element,2,jpl,library(jpl)).
index(append,3,lists,library(lists)).
index(append,2,lists,library(lists)).
index(delete,3,lists,library(lists)).
index(intersection,3,lists,library(lists)).
index(flatten,2,lists,library(lists)).
index(last,2,lists,library(lists)).
index(list_concat,2,lists,library(lists)).
index(max_list,2,lists,library(lists)).
index(member,2,lists,library(lists)).
index(memberchk,2,lists,library(lists)).
index(min_list,2,lists,library(lists)).
index(nextto,3,lists,library(lists)).
index(nth,3,lists,library(lists)).
index(nth,4,lists,library(lists)).
index(nth0,3,lists,library(lists)).
index(nth0,4,lists,library(lists)).
index(nth1,3,lists,library(lists)).
index(nth1,4,lists,library(lists)).
index(numlist,3,lists,library(lists)).
index(permutation,2,lists,library(lists)).
index(prefix,2,lists,library(lists)).
index(remove_duplicates,2,lists,library(lists)).
index(reverse,2,lists,library(lists)).
index(same_length,2,lists,library(lists)).
index(select,3,lists,library(lists)).
index(selectchk,3,lists,library(lists)).
index(sublist,2,lists,library(lists)).
index(substitute,4,lists,library(lists)).
index(subtract,3,lists,library(lists)).
index(suffix,2,lists,library(lists)).
index(sum_list,2,lists,library(lists)).
index(sum_list,3,lists,library(lists)).
index(sumlist,2,lists,library(lists)).
index(nb_queue,1,nb,library(nb)).
index(nb_queue,2,nb,library(nb)).
index(nb_queue_close,3,nb,library(nb)).
index(nb_queue_enqueue,2,nb,library(nb)).
index(nb_queue_dequeue,2,nb,library(nb)).
index(nb_queue_peek,2,nb,library(nb)).
index(nb_queue_empty,1,nb,library(nb)).
index(nb_queue_size,2,nb,library(nb)).
index(nb_heap,2,nb,library(nb)).
index(nb_heap_close,1,nb,library(nb)).
index(nb_heap_add,3,nb,library(nb)).
index(nb_heap_del,3,nb,library(nb)).
index(nb_heap_peek,3,nb,library(nb)).
index(nb_heap_empty,1,nb,library(nb)).
index(nb_heap_size,2,nb,library(nb)).
index(nb_beam,2,nb,library(nb)).
index(nb_beam_close,1,nb,library(nb)).
index(nb_beam_add,3,nb,library(nb)).
index(nb_beam_del,3,nb,library(nb)).
index(nb_beam_peek,3,nb,library(nb)).
index(nb_beam_empty,1,nb,library(nb)).
index(nb_beam_size,2,nb,library(nb)).
index(contains_term,2,occurs,library(occurs)).
index(contains_var,2,occurs,library(occurs)).
index(free_of_term,2,occurs,library(occurs)).
index(free_of_var,2,occurs,library(occurs)).
index(occurrences_of_term,3,occurs,library(occurs)).
index(occurrences_of_var,3,occurs,library(occurs)).
index(sub_term,2,occurs,library(occurs)).
index(sub_var,2,occurs,library(occurs)).
index(option,2,swi_option,library(option)).
index(option,3,swi_option,library(option)).
index(select_option,3,swi_option,library(option)).
index(select_option,4,swi_option,library(option)).
index(merge_options,3,swi_option,library(option)).
index(meta_options,3,swi_option,library(option)).
index(list_to_ord_set,2,ordsets,library(ordsets)).
index(merge,3,ordsets,library(ordsets)).
index(ord_add_element,3,ordsets,library(ordsets)).
index(ord_del_element,3,ordsets,library(ordsets)).
index(ord_disjoint,2,ordsets,library(ordsets)).
index(ord_insert,3,ordsets,library(ordsets)).
index(ord_member,2,ordsets,library(ordsets)).
index(ord_intersect,2,ordsets,library(ordsets)).
index(ord_intersect,3,ordsets,library(ordsets)).
index(ord_intersection,3,ordsets,library(ordsets)).
index(ord_intersection,4,ordsets,library(ordsets)).
index(ord_seteq,2,ordsets,library(ordsets)).
index(ord_setproduct,3,ordsets,library(ordsets)).
index(ord_subset,2,ordsets,library(ordsets)).
index(ord_subtract,3,ordsets,library(ordsets)).
index(ord_symdiff,3,ordsets,library(ordsets)).
index(ord_union,2,ordsets,library(ordsets)).
index(ord_union,3,ordsets,library(ordsets)).
index(ord_union,4,ordsets,library(ordsets)).
index(ord_empty,1,ordsets,library(ordsets)).
index(ord_memberchk,2,ordsets,library(ordsets)).
index(pairs_keys_values,3,pairs,library(pairs)).
index(pairs_values,2,pairs,library(pairs)).
index(pairs_keys,2,pairs,library(pairs)).
index(group_pairs_by_key,2,pairs,library(pairs)).
index(transpose_pairs,2,pairs,library(pairs)).
index(map_list_to_pairs,3,pairs,library(pairs)).
index(xref_source,1,prolog_xref,library(prolog_xref)).
index(xref_called,3,prolog_xref,library(prolog_xref)).
index(xref_defined,3,prolog_xref,library(prolog_xref)).
index(xref_definition_line,2,prolog_xref,library(prolog_xref)).
index(xref_exported,2,prolog_xref,library(prolog_xref)).
index(xref_module,2,prolog_xref,library(prolog_xref)).
index(xref_op,2,prolog_xref,library(prolog_xref)).
index(xref_clean,1,prolog_xref,library(prolog_xref)).
index(xref_current_source,1,prolog_xref,library(prolog_xref)).
index(xref_done,2,prolog_xref,library(prolog_xref)).
index(xref_built_in,1,prolog_xref,library(prolog_xref)).
index(xref_expand,2,prolog_xref,library(prolog_xref)).
index(xref_source_file,3,prolog_xref,library(prolog_xref)).
index(xref_source_file,4,prolog_xref,library(prolog_xref)).
index(xref_public_list,4,prolog_xref,library(prolog_xref)).
index(xref_meta,2,prolog_xref,library(prolog_xref)).
index(xref_hook,1,prolog_xref,library(prolog_xref)).
index(xref_used_class,2,prolog_xref,library(prolog_xref)).
index(xref_defined_class,3,prolog_xref,library(prolog_xref)).
index(set_test_options,1,plunit,library(plunit)).
index(begin_tests,1,plunit,library(plunit)).
index(begin_tests,2,plunit,library(plunit)).
index(end_tests,1,plunit,library(plunit)).
index(run_tests,0,plunit,library(plunit)).
index(run_tests,1,plunit,library(plunit)).
index(load_test_files,1,plunit,library(plunit)).
index(running_tests,0,plunit,library(plunit)).
index(test_report,1,plunit,library(plunit)).
index(make_queue,1,queues,library(queues)).
index(join_queue,3,queues,library(queues)).
index(list_join_queue,3,queues,library(queues)).
index(jump_queue,3,queues,library(queues)).
index(list_jump_queue,3,queues,library(queues)).
index(head_queue,2,queues,library(queues)).
index(serve_queue,3,queues,library(queues)).
index(length_queue,2,queues,library(queues)).
index(empty_queue,1,queues,library(queues)).
index(list_to_queue,2,queues,library(queues)).
index(queue_to_list,2,queues,library(queues)).
index(random,1,random,library(random)).
index(random,3,random,library(random)).
index(randseq,3,random,library(random)).
index(randset,3,random,library(random)).
index(getrand,1,random,library(random)).
index(setrand,1,random,library(random)).
index(rb_new,1,rbtrees,library(rbtrees)).
index(rb_empty,1,rbtrees,library(rbtrees)).
index(rb_lookup,3,rbtrees,library(rbtrees)).
index(rb_update,4,rbtrees,library(rbtrees)).
index(rb_update,5,rbtrees,library(rbtrees)).
index(rb_apply,4,rbtrees,library(rbtrees)).
index(rb_lookupall,3,rbtrees,library(rbtrees)).
index(rb_insert,4,rbtrees,library(rbtrees)).
index(rb_insert_new,4,rbtrees,library(rbtrees)).
index(rb_delete,3,rbtrees,library(rbtrees)).
index(rb_delete,4,rbtrees,library(rbtrees)).
index(rb_visit,2,rbtrees,library(rbtrees)).
index(rb_visit,3,rbtrees,library(rbtrees)).
index(rb_keys,2,rbtrees,library(rbtrees)).
index(rb_keys,3,rbtrees,library(rbtrees)).
index(rb_map,2,rbtrees,library(rbtrees)).
index(rb_map,3,rbtrees,library(rbtrees)).
index(rb_partial_map,4,rbtrees,library(rbtrees)).
index(rb_clone,3,rbtrees,library(rbtrees)).
index(rb_clone,4,rbtrees,library(rbtrees)).
index(rb_min,3,rbtrees,library(rbtrees)).
index(rb_max,3,rbtrees,library(rbtrees)).
index(rb_del_min,4,rbtrees,library(rbtrees)).
index(rb_del_max,4,rbtrees,library(rbtrees)).
index(rb_next,4,rbtrees,library(rbtrees)).
index(rb_previous,4,rbtrees,library(rbtrees)).
index(list_to_rbtree,2,rbtrees,library(rbtrees)).
index(ord_list_to_rbtree,2,rbtrees,library(rbtrees)).
index(is_rbtree,1,rbtrees,library(rbtrees)).
index(rb_size,2,rbtrees,library(rbtrees)).
index(rb_in,3,rbtrees,library(rbtrees)).
index(read_line_to_codes,2,read_util,library(readutil)).
index(read_line_to_codes,3,read_util,library(readutil)).
index(read_stream_to_codes,2,read_util,library(readutil)).
index(read_stream_to_codes,3,read_util,library(readutil)).
index(read_file_to_codes,3,read_util,library(readutil)).
index(read_file_to_terms,3,read_util,library(readutil)).
index(regexp,3,regexp,library(regexp)).
index(regexp,4,regexp,library(regexp)).
index(load_foreign_library,1,shlib,library(shlib)).
index(load_foreign_library,2,shlib,library(shlib)).
index(unload_foreign_library,1,shlib,library(shlib)).
index(unload_foreign_library,2,shlib,library(shlib)).
index(current_foreign_library,2,shlib,library(shlib)).
index(reload_foreign_libraries,0,shlib,library(shlib)).
index(use_foreign_library,1,shlib,library(shlib)).
index(use_foreign_library,2,shlib,library(shlib)).
index(datime,1,operating_system_support,library(system)).
index(delete_file,1,operating_system_support,library(system)).
index(delete_file,2,operating_system_support,library(system)).
index(directory_files,2,operating_system_support,library(system)).
index(environ,2,operating_system_support,library(system)).
index(exec,3,operating_system_support,library(system)).
index(file_exists,1,operating_system_support,library(system)).
index(file_exists,2,operating_system_support,library(system)).
index(file_property,2,operating_system_support,library(system)).
index(host_id,1,operating_system_support,library(system)).
index(host_name,1,operating_system_support,library(system)).
index(pid,1,operating_system_support,library(system)).
index(kill,2,operating_system_support,library(system)).
index(mktemp,2,operating_system_support,library(system)).
index(make_directory,1,operating_system_support,library(system)).
index(popen,3,operating_system_support,library(system)).
index(rename_file,2,operating_system_support,library(system)).
index(shell,0,operating_system_support,library(system)).
index(shell,1,operating_system_support,library(system)).
index(shell,2,operating_system_support,library(system)).
index(sleep,1,operating_system_support,library(system)).
index(system,0,operating_system_support,library(system)).
index(system,1,operating_system_support,library(system)).
index(system,2,operating_system_support,library(system)).
index(mktime,2,operating_system_support,library(system)).
index(tmpnam,1,operating_system_support,library(system)).
index(tmp_file,2,operating_system_support,library(system)).
index(tmpdir,1,operating_system_support,library(system)).
index(wait,2,operating_system_support,library(system)).
index(working_directory,2,operating_system_support,library(system)).
index(term_hash,2,terms,library(terms)).
index(term_hash,4,terms,library(terms)).
index(instantiated_term_hash,4,terms,library(terms)).
index(variant,2,terms,library(terms)).
index(unifiable,3,terms,library(terms)).
index(subsumes,2,terms,library(terms)).
index(subsumes_chk,2,terms,library(terms)).
index(cyclic_term,1,terms,library(terms)).
index(variable_in_term,2,terms,library(terms)).
index(variables_within_term,3,terms,library(terms)).
index(new_variables_in_term,3,terms,library(terms)).
index(time_out,3,timeout,library(timeout)).
index(get_label,3,trees,library(trees)).
index(list_to_tree,2,trees,library(trees)).
index(map_tree,3,trees,library(trees)).
index(put_label,4,trees,library(trees)).
index(tree_size,2,trees,library(trees)).
index(tree_to_list,2,trees,library(trees)).

View File

@@ -1,52 +0,0 @@
/**
* @file apply.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Mon Nov 16 23:00:08 2015
*
* @brief Stub for maplist and friends
*
*
*/
:- module(apply_stub,[]).
/**
* @file apply.yap
* @defgroup apply_stub Apply Predicates
*
* @ingroup library
*
* @{
This library provides a SWI-compatible set of utilities for applying a
predicate to all elements of a list.
The apply library is a _stub_, it just forwards definitions to the
@ref maplist library. The predicates forwarded are:
- maplist/2,
- maplist/3,
- maplist/4,
- maplist/5,
- include/3,
- exclude/3,
- partition/4,
- partition/5
*/
:- reexport(library(maplist),
[maplist/2,
maplist/3,
maplist/4,
maplist/5,
include/3,
exclude/3,
partition/4,
partition/5
]).
%% @}

View File

@@ -1,38 +0,0 @@
%% @file apply_macros.yap
%% @author E. Alphonse from code by Joachim Schimpf
%% @date 15 June 2002
%% @nrief Purpose: Macros to apply a predicate to all elements
% of a list or to all sub-terms of a term.
:- module(apply_macros, []).
/**
@defgroup apply_macros Apply Interface to maplist
@ingroup library
@{
This library provides a SWI-compatible set of utilities for applying a
predicate to all elements of a list.
The apply library just forwards
definitions to the @ref maplist library, these include:
- maplist/2,
- maplist/3,
- maplist/4,
- maplist/5,
- include/3,
- exclude/3,
- partition/4,
- partition/5
*/
:- reexport(maplist).
:- reexport(mapargs).
%% @}

View File

@@ -1,167 +0,0 @@
/**
* @file arg.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 01:08:55 2015
*
* @brief
*/
/**
*
@defgroup args Term Argument Manipulation.
@ingroup @library
@{
Extends arg/3 by including backtracking through arguments and access
to sub-arguments,
- arg0/3
- args/3
- args0/3
- genarg/3
- genarg0/3
- path_arg/3
It is based on the Quintus Prolog arg library. Except for project, all
predicates use the arg/3 argument pattern.
This file has been included in the YAP library by Vitor Santos Costa, 2008. No error checking is actuallly performed within the package: this left to the C-code thaat implements arg``/3 and
genarg/3.
*/
:- module(arg,
[
genarg/3,
arg0/3,
genarg0/3,
args/3,
args0/3,
% project/3
path_arg/3
]).
/**
* @pred arg0( +_Index_, +_Term_ , -_Arg_ )
*
* Similar to arg/3, but `arg0(0,_T_,_F_)` unifies _F_ with _T_'s principal functor:
~~~~~~~~~
?- arg0(0, f(a,b), A).
A = f.
?- arg0(1, f(a,b), A).
A = a.
?- arg0(2, f(a,b), A).
A = b.
~~~~~~~~~
*/
arg0(0,T,A) :- !,
functor(T,A,_).
arg0(I,T,A) :-
arg(I,T,A).
/**
* @pred genarg0( +_Index_, +_Term_ , -_Arg_ )
*
* Similar to genarg/3, but `genarg0(0,_T_,_F_)` unifies _F_ with _T_'s principal functor:
~~~~~~~~~
?- genarg0(I,f(a,b),A).
A = f,
I = 0 ? ;
A = a,
I = 1 ? ;
A = b,
I = 2.
~~~~~~~~~
*/
genarg0(I,T,A) :-
nonvar(I), !,
arg0(I,T,A).
genarg0(0,T,A) :-
functor(T,A,_).
genarg0(I,T,A) :-
genarg(I,T,A).
/**
* @pred args( +_Index_, +_ListOfTerms_ , -_ListOfArgs_ )
*
* Succeeds if _ListOfArgs_ unifies with the application of genarg/3 to every element of _ListOfTerms_.
It corresponds to calling maplist/3 on genarg/3:
~~~~~~~~~
args( I, Ts, As) :-
maplist( genarg(I), Ts, As).
~~~~~~~~~
Notice that unification allows _ListOfArgs_ to be bound, eg:
~~~~~~~~~
?- args(1, [X1+Y1,X2-Y2,X3*Y3,X4/Y4], [1,1,1,1]).
X1 = X2 = X3 = X4 = 1.
~~~~~~~~~
*/
args(_,[],[]).
args(I,[T|List],[A|ArgList]) :-
genarg(I, T, A),
args(I, List, ArgList).
/**
* @pred args0( +_Index_, +_ListOfTerms_ , -_ListOfArgs_ )
*
* Succeeds if _ListOfArgs_ unifies with the application of genarg0/3 to every element of _ListOfTerms_.
It corresponds to calling maplist/3 on genarg0/3:
~~~~~~~~~
args( I, Ts, As) :-
maplist( genarg0(I), Ts, As).
~~~~~~~~~
Notice that unification allows _ListOfArgs_ to be bound, eg:
~~~~~~~~~
?- args(1, [X1+Y1,X2-Y2,X3*Y3,X4/Y4], [1,1,1,1]).
X1 = X2 = X3 = X4 = 1.
~~~~~~~~~
*/
args0(_,[],[]).
args0(I,[T|List],[A|ArgList]) :-
genarg(I, T, A),
args0(I, List, ArgList).
/**
* @pred args0( +_ListOfTerms_ , +_Index_, -_ListOfArgs_ )
*
* Succeeds if _ListOfArgs_ unifies with the application of genarg0/3 to every element of _ListOfTerms_.
It corresponds to calling args0/3 but with a different order.
*/
project(Terms, Index, Args) :-
args0(Index, Terms, Args).
% no error checking here!
/**
* @pred path_arg( +_Path_ , +_Term_, -_Arg_ )
*
* Succeeds if _Path_ is empty and _Arg unifies with _Term_, or if _Path_ is a list with _Head_ and _Tail_, genarg/3 succeeds on the current term, and path_arg/3 succeeds on its argument.
*
* Notice that it can be used to enumerate all possible paths in a term.
*/
path_arg([], Term, Term).
path_arg([Index|Indices], Term, SubTerm) :-
genarg(Index, Term, Arg),
path_arg(Indices, Arg, SubTerm).
%%% @}
/** @} */

View File

@@ -1,296 +0,0 @@
/**
* @file assoc.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 13:53:34 2015
*
* @brief Red-Black Implementation of Association Lists.
*
* This file has been included as an YAP library by Vitor Santos Costa, 1999
*
* Note: the keys should be bound, the associated values need not be.
*/
:- module(assoc, [
empty_assoc/1,
assoc_to_list/2,
is_assoc/1,
min_assoc/3,
max_assoc/3,
gen_assoc/3,
get_assoc/3,
get_assoc/5,
get_next_assoc/4,
get_prev_assoc/4,
list_to_assoc/2,
ord_list_to_assoc/2,
map_assoc/2,
map_assoc/3,
put_assoc/4,
del_assoc/4,
assoc_to_keys/2,
del_min_assoc/4,
del_max_assoc/4
]).
/** @defgroup Association_Lists Association Lists
@ingroup library
@{
The following association list manipulation predicates are available
once included with the `use_module(library(assoc))` command. The
original library used Richard O'Keefe's implementation, on top of
unbalanced binary trees. The current code utilises code from the
red-black trees library and emulates the SICStus Prolog interface.
The library exports the following definitions:
- is/assoc/1
*/
:- meta_predicate map_assoc(2, +, -), map_assoc(1, +).
:- use_module(library(rbtrees), [
rb_empty/1,
rb_visit/2,
is_rbtree/1,
rb_min/3,
rb_max/3,
rb_in/3,
rb_lookup/3,
rb_update/5,
rb_next/4,
rb_previous/4,
list_to_rbtree/2,
ord_list_to_rbtree/2,
rb_map/2,
rb_map/3,
rb_keys/2,
rb_update/4,
rb_insert/4,
rb_delete/4,
rb_del_min/4,
rb_del_max/4
]).
/** @pred empty_assoc(+ _Assoc_)
Succeeds if association list _Assoc_ is empty.
*/
empty_assoc(t).
/** @pred assoc_to_list(+ _Assoc_,? _List_)
Given an association list _Assoc_ unify _List_ with a list of
the form _Key-Val_, where the elements _Key_ are in ascending
order.
*/
assoc_to_list(t, L) :- !, L = [].
assoc_to_list(T, L) :-
rb_visit(T, L).
/** @pred is_assoc(+ _Assoc_)
Succeeds if _Assoc_ is an association list, that is, if it is a
red-black tree.
*/
is_assoc(t) :- !.
is_assoc(T) :-
is_rbtree(T).
/** @pred min_assoc(+ _Assoc_,- _Key_,? _Value_)
Given the association list
_Assoc_, _Key_ in the smallest key in the list, and _Value_
the associated value.
*/
min_assoc(T,K,V) :-
rb_min(T,K,V).
/** @pred max_assoc(+ _Assoc_,- _Key_,? _Value_)
Given the association list
_Assoc_, _Key_ in the largest key in the list, and _Value_
the associated value.
*/
max_assoc(T,K,V) :-
rb_max(T,K,V).
/** @pred gen_assoc( ?Key, +Assoc, ?Valu_)
Given the association list _Assoc_, unify _Key_ and _Value_
with a key-value pair in the list. It can be used to enumerate all elements
in the association list.
*/
gen_assoc(K, T, V) :-
rb_in(K,V,T).
/** @pred get_assoc(+ _Key_,+ _Assoc_,? _Value_)
If _Key_ is one of the elements in the association list _Assoc_,
return the associated value.
*/
get_assoc(K,T,V) :-
rb_lookup(K,V,T).
/** @pred get_assoc(+ _Key_,+ _Assoc_,? _Value_,+ _NAssoc_,? _NValue_)
If _Key_ is one of the elements in the association list _Assoc_,
return the associated value _Value_ and a new association list
_NAssoc_ where _Key_ is associated with _NValue_.
*/
get_assoc(K,T,V,NT,NV) :-
rb_update(T,K,V,NV,NT).
/** @pred get_next_assoc(+ _Key_,+ _Assoc_,? _Next_,? _Value_)
If _Key_ is one of the elements in the association list _Assoc_,
return the next key, _Next_, and its value, _Value_.
*/
get_next_assoc(K,T,KN,VN) :-
rb_next(T,K,KN,VN).
/** @pred get_prev_assoc(+ _Key_,+ _Assoc_,? _Next_,? _Value_)
If _Key_ is one of the elements in the association list _Assoc_,
return the previous key, _Next_, and its value, _Value_.
*/
get_prev_assoc(K,T,KP,VP) :-
rb_previous(T,K,KP,VP).
/** @pred list_to_assoc(+ _List_,? _Assoc_)
Given a list _List_ such that each element of _List_ is of the
form _Key-Val_, and all the _Keys_ are unique, _Assoc_ is
the corresponding association list.
*/
list_to_assoc(L, T) :-
list_to_rbtree(L, T).
/** @pred ord_list_to_assoc(+ _List_,? _Assoc_)
Given an ordered list _List_ such that each element of _List_ is
of the form _Key-Val_, and all the _Keys_ are unique, _Assoc_ is
the corresponding association list.
*/
ord_list_to_assoc(L, T) :-
ord_list_to_rbtree(L, T).
/** @pred map_assoc(+ _Pred_,+ _Assoc_)
Succeeds if the unary predicate name _Pred_( _Val_) holds for every
element in the association list.
*/
map_assoc(t, _) :- !.
map_assoc(P, T) :-
yap_flag(typein_module, M0),
extract_mod(P, M0, M, G),
functor(G, Name, 1),
rb_map(T, M:Name).
/** @pred map_assoc(+ _Pred_,+ _Assoc_,? _New_)
Given the binary predicate name _Pred_ and the association list
_Assoc_, _New_ in an association list with keys in _Assoc_,
and such that if _Key-Val_ is in _Assoc_, and _Key-Ans_ is in
_New_, then _Pred_( _Val_, _Ans_) holds.*/
map_assoc(t, T, T) :- !.
map_assoc(P, T, NT) :-
yap_flag(typein_module, M0),
extract_mod(P, M0, M, G),
functor(G, Name, 2),
rb_map(T, M:Name, NT).
extract_mod(G,_,_) :- var(G), !, fail.
extract_mod(M:G, _, FM, FG ) :- !,
extract_mod(G, M, FM, FG ).
extract_mod(G, M, M, G ).
/** @pred put_assoc(+ _Key_,+ _Assoc_,+ _Val_,+ _New_)
The association list _New_ includes and element of association
_key_ with _Val_, and all elements of _Assoc_ that did not
have key _Key_.
*/
put_assoc(K, T, V, NT) :-
rb_update(T, K, V, NT), !.
put_assoc(K, t, V, NT) :- !,
rbtrees:rb_new(K,V,NT).
put_assoc(K, T, V, NT) :-
rb_insert(T, K, V, NT).
/** @pred del_assoc(+ _Key_, + _Assoc_, ? _Val_, ? _NewAssoc_)
Succeeds if _NewAssoc_ is an association list, obtained by removing
the element with _Key_ and _Val_ from the list _Assoc_.
*/
del_assoc(K, T, V, NT) :-
rb_delete(T, K, V, NT).
/** @pred del_min_assoc(+ _Assoc_, ? _Key_, ? _Val_, ? _NewAssoc_)
Succeeds if _NewAssoc_ is an association list, obtained by removing
the smallest element of the list, with _Key_ and _Val_
from the list _Assoc_.
*/
del_min_assoc(T, K, V, NT) :-
rb_del_min(T, K, V, NT).
/** @pred del_max_assoc(+ _Assoc_, ? _Key_, ? _Val_, ? _NewAssoc_)
Succeeds if _NewAssoc_ is an association list, obtained by removing
the largest element of the list, with _Key_ and _Val_ from the
list _Assoc_.
*/
del_max_assoc(T, K, V, NT) :-
rb_del_max(T, K, V, NT).
assoc_to_keys(T, Ks) :-
rb_keys(T, Ks).
/**
@}
*/

View File

@@ -1,280 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: atts.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: attribute support for Prolog *
* *
*************************************************************************/
:- module(attributes, [op(1150, fx, attribute)]).
/**
*
* @defgroup sicsatts SICStus style attribute declarations
*
* @ingroup attributes
*
* @{
*
SICStus style attribute declarations are activated through loading the
library <tt>atts</tt>. The command
~~~~~
| ?- use_module(library(atts)).
~~~~~
enables this form of attributed variables.
The directive
- attribute/1
and the following user defined predicates can be used:
- Module:get_atts/2
- Module:put_atts/2
- Module:put_atts/3
- Module:woken_att_do/4
*/
:- use_module(library(lists), [member/2]).
:- multifile
user:goal_expansion/3.
:- multifile
user:term_expansion/2.
:- multifile
attributed_module/3.
:- dynamic existing_attribute/4.
:- dynamic modules_with_attributes/1.
:- dynamic attributed_module/3.
modules_with_attributes([]).
%
% defining a new attribute is just a question of establishing a
% Functor, Mod -> INT mappings
%
new_attribute(V) :- var(V), !,
throw(error(instantiation_error,attribute(V))).
new_attribute((At1,At2)) :-
new_attribute(At1),
new_attribute(At2).
new_attribute(Na/Ar) :-
source_module(Mod),
functor(S,Na,Ar),
existing_attribute(S,Mod,_,_) , !.
new_attribute(Na/Ar) :-
source_module(Mod),
functor(S,Na,Ar),
store_new_module(Mod,Ar,Position),
assertz(existing_attribute(S,Mod,Ar,Position)).
store_new_module(Mod,Ar,ArgPosition) :-
(
retract(attributed_module(Mod,Position,_))
->
true
;
retract(modules_with_attributes(Mods)),
assert(modules_with_attributes([Mod|Mods])), Position = 2
),
ArgPosition is Position+1,
( Ar == 0 -> NOfAtts is Position+1 ; NOfAtts is Position+Ar),
functor(AccessTerm,Mod,NOfAtts),
assertz(attributed_module(Mod,NOfAtts,AccessTerm)).
:- user_defined_directive(attribute(G), attributes:new_attribute(G)).
/** @pred Module:get_atts( _-Var_, _?ListOfAttributes_)
Unify the list _?ListOfAttributes_ with the attributes for the unbound
variable _Var_. Each member of the list must be a bound term of the
form `+( _Attribute_)`, `-( _Attribute_)` (the <tt>kbd</tt>
prefix may be dropped). The meaning of <tt>+</tt> and <tt>-</tt> is:
+ +( _Attribute_)
Unifies _Attribute_ with a corresponding attribute associated with
_Var_, fails otherwise.
+ -( _Attribute_)
Succeeds if a corresponding attribute is not associated with
_Var_. The arguments of _Attribute_ are ignored.
*/
user:goal_expansion(get_atts(Var,AccessSpec), Mod, Goal) :-
expand_get_attributes(AccessSpec,Mod,Var,Goal).
/** @pred Module:put_atts( _-Var_, _?ListOfAttributes_)
Associate with or remove attributes from a variable _Var_. The
attributes are given in _?ListOfAttributes_, and the action depends
on how they are prefixed:
+ +( _Attribute_ )
Associate _Var_ with _Attribute_. A previous value for the
attribute is simply replace (like with `set_mutable/2`).
+ -( _Attribute_ )
Remove the attribute with the same name. If no such attribute existed,
simply succeed.
*/
user:goal_expansion(put_atts(Var,AccessSpec), Mod, Goal) :-
expand_put_attributes(AccessSpec, Mod, Var, Goal).
expand_get_attributes(V,_,_,_) :- var(V), !, fail.
expand_get_attributes([],_,_,true) :- !.
expand_get_attributes([-G1],Mod,V,attributes:free_att(V,Mod,Pos)) :-
existing_attribute(G1,Mod,_,Pos), !.
expand_get_attributes([+G1],Mod,V,attributes:get_att(V,Mod,Pos,A)) :-
existing_attribute(G1,Mod,1,Pos), !,
arg(1,G1,A).
expand_get_attributes([G1],Mod,V,attributes:get_att(V,Mod,Pos,A)) :-
existing_attribute(G1,Mod,1,Pos), !,
arg(1,G1,A).
expand_get_attributes(Atts,Mod,Var,attributes:get_module_atts(Var,AccessTerm)) :- Atts = [_|_], !,
attributed_module(Mod,NOfAtts,AccessTerm),
void_term(Void),
cvt_atts(Atts,Mod,Void,LAtts),
sort(LAtts,SortedLAtts),
free_term(Free),
build_att_term(1,NOfAtts,SortedLAtts,Free,AccessTerm).
expand_get_attributes(Att,Mod,Var,Goal) :-
expand_get_attributes([Att],Mod,Var,Goal).
build_att_term(NOfAtts,NOfAtts,[],_,_) :- !.
build_att_term(I0,NOfAtts,[I-Info|SortedLAtts],Void,AccessTerm) :-
I is I0+1, !,
copy_att_args(Info,I0,NI,AccessTerm),
build_att_term(NI,NOfAtts,SortedLAtts,Void,AccessTerm).
build_att_term(I0,NOfAtts,SortedLAtts,Void,AccessTerm) :-
I is I0+1,
arg(I,AccessTerm,Void),
build_att_term(I,NOfAtts,SortedLAtts,Void,AccessTerm).
cvt_atts(V,_,_,_) :- var(V), !, fail.
cvt_atts([],_,_,[]).
cvt_atts([V|_],_,_,_) :- var(V), !, fail.
cvt_atts([+Att|Atts],Mod,Void,[Pos-LAtts|Read]) :- !,
existing_attribute(Att,Mod,_,Pos),
(atom(Att) -> LAtts = [_] ; Att=..[_|LAtts]),
cvt_atts(Atts,Mod,Void,Read).
cvt_atts([-Att|Atts],Mod,Void,[Pos-LVoids|Read]) :- !,
existing_attribute(Att,Mod,_,Pos),
(
atom(Att)
->
LVoids = [Void]
;
Att =..[_|LAtts],
void_vars(LAtts,Void,LVoids)
),
cvt_atts(Atts,Mod,Void,Read).
cvt_atts([Att|Atts],Mod,Void,[Pos-LAtts|Read]) :- !,
existing_attribute(Att,Mod,_,Pos),
(atom(Att) -> LAtts = [_] ; Att=..[_|LAtts]),
cvt_atts(Atts,Mod,Void,Read).
copy_att_args([],I,I,_).
copy_att_args([V|Info],I,NI,AccessTerm) :-
I1 is I+1,
arg(I1,AccessTerm,V),
copy_att_args(Info,I1,NI,AccessTerm).
void_vars([],_,[]).
void_vars([_|LAtts],Void,[Void|LVoids]) :-
void_vars(LAtts,Void,LVoids).
expand_put_attributes(V,_,_,_) :- var(V), !, fail.
expand_put_attributes([-G1],Mod,V,attributes:rm_att(V,Mod,NOfAtts,Pos)) :-
existing_attribute(G1,Mod,_,Pos), !,
attributed_module(Mod,NOfAtts,_).
expand_put_attributes([+G1],Mod,V,attributes:put_att(V,Mod,NOfAtts,Pos,A)) :-
existing_attribute(G1,Mod,1,Pos), !,
attributed_module(Mod,NOfAtts,_),
arg(1,G1,A).
expand_put_attributes([G1],Mod,V,attributes:put_att(V,Mod,NOfAtts,Pos,A)) :-
existing_attribute(G1,Mod,1,Pos), !,
attributed_module(Mod,NOfAtts,_),
arg(1,G1,A).
expand_put_attributes(Atts,Mod,Var,attributes:put_module_atts(Var,AccessTerm)) :- Atts = [_|_], !,
attributed_module(Mod,NOfAtts,AccessTerm),
void_term(Void),
cvt_atts(Atts,Mod,Void,LAtts),
sort(LAtts,SortedLAtts),
free_term(Free),
build_att_term(1,NOfAtts,SortedLAtts,Free,AccessTerm).
expand_put_attributes(Att,Mod,Var,Goal) :-
expand_put_attributes([Att],Mod,Var,Goal).
woken_att_do(AttVar, Binding, NGoals, DoNotBind) :-
modules_with_attributes(AttVar,Mods0),
modules_with_attributes(Mods),
find_used(Mods,Mods0,[],ModsI),
do_verify_attributes(ModsI, AttVar, Binding, Goals),
process_goals(Goals, NGoals, DoNotBind).
% dirty trick to be able to unbind a variable that has been constrained.
process_goals([], [], _).
process_goals((M:do_not_bind_variable(Gs)).Goals, (M:Gs).NGoals, true) :- !,
process_goals(Goals, NGoals, _).
process_goals(G.Goals, G.NGoals, Do) :-
process_goals(Goals, NGoals, Do).
find_used([],_,L,L).
find_used([M|Mods],Mods0,L0,Lf) :-
member(M,Mods0), !,
find_used(Mods,Mods0,[M|L0],Lf).
find_used([_|Mods],Mods0,L0,Lf) :-
find_used(Mods,Mods0,L0,Lf).
/** @pred Module:verify_attributes( _-Var_, _+Value_, _-Goals_)
The predicate is called when trying to unify the attributed variable
_Var_ with the Prolog term _Value_. Note that _Value_ may be
itself an attributed variable, or may contain attributed variables. The
goal <tt>verify_attributes/3</tt> is actually called before _Var_ is
unified with _Value_.
It is up to the user to define which actions may be performed by
<tt>verify_attributes/3</tt> but the procedure is expected to return in
_Goals_ a list of goals to be called <em>after</em> _Var_ is
unified with _Value_. If <tt>verify_attributes/3</tt> fails, the
unification will fail.
Notice that the <tt>verify_attributes/3</tt> may be called even if _Var_<
has no attributes in module <tt>Module</tt>. In this case the routine should
simply succeed with _Goals_ unified with the empty list.
*/
do_verify_attributes([], _, _, []).
do_verify_attributes([Mod|Mods], AttVar, Binding, [Mod:Goal|Goals]) :-
current_predicate(verify_attributes,Mod:verify_attributes(_,_,_)), !,
Mod:verify_attributes(AttVar, Binding, Goal),
do_verify_attributes(Mods, AttVar, Binding, Goals).
do_verify_attributes([_|Mods], AttVar, Binding, Goals) :-
do_verify_attributes(Mods, AttVar, Binding, Goals).
/**
@}
*/

View File

@@ -1,127 +0,0 @@
:- module(autoloader,[make_library_index/0]).
:- use_module(library(lists),[append/3]).
:- dynamic exported/3, loaded/1.
make_library_index :-
scan_library_exports,
scan_swi_exports.
scan_library_exports :-
% init table file.
open('INDEX.pl', write, W),
close(W),
scan_exports('../GPL/aggregate', library(aggregate)),
scan_exports(apply, library(apply)),
scan_exports(arg, library(arg)),
scan_exports(assoc, library(assoc)),
scan_exports(avl, library(avl)),
scan_exports(bhash, library(bhash)),
scan_exports(charsio, library(charsio)),
scan_exports('../packages/chr/chr_swi', library(chr)),
scan_exports(clp/clpfd, library(clpfd)),
scan_exports('../packages/clpqr/clpr', library(clpr)),
scan_exports(gensym, library(gensym)),
scan_exports(heaps, library(heaps)),
scan_exports('../packages/jpl/jpl', library(jpl)),
scan_exports(lists, library(lists)),
scan_exports(nb, library(nb)),
scan_exports(occurs, library(occurs)),
scan_exports('../LGPL/option', library(option)),
scan_exports(ordsets, library(ordsets)),
scan_exports(pairs, library(pairs)),
scan_exports('../LGPL/prolog_xref', library(prolog_xref)),
scan_exports('../packages/plunit/plunit', library(plunit)),
scan_exports(queues, library(queues)),
scan_exports(random, library(random)),
scan_exports(rbtrees, library(rbtrees)),
scan_exports('../LGPL/readutil', library(readutil)),
scan_exports(regexp, library(regexp)),
scan_exports('../LGPL/shlib', library(shlib)),
scan_exports(system, library(system)),
scan_exports(terms, library(terms)),
scan_exports(timeout, library(timeout)),
scan_exports(trees, library(trees)).
scan_exports(Library, CallName) :-
absolute_file_name(Library, Path,
[ file_type(prolog),
access(read),
file_errors(fail)
]),
open(Path, read, O),
!,
get_exports(O, Exports, Module),
close(O),
open('INDEX.pl', append, W),
publish_exports(Exports, W, CallName, Module),
close(W).
scan_exports(Library) :-
format(user_error,'[ warning: library ~w not defined ]~n',[Library]).
%
% SWI is the only language that uses autoload.
%
scan_swi_exports :-
retractall(exported(_,_,_)),
absolute_file_name(dialect/swi, Path,
[ file_type(prolog),
access(read),
file_errors(fail)
]),
open(Path, read, O),
get_exports(O, Exports, Module),
get_reexports(O, Reexports, Exports),
close(O),
open('dialect/swi/INDEX.pl', write, W),
publish_exports(Reexports, W, library(dialect/swi), Module),
close(W).
get_exports(O, Exports, Module) :-
read(O, (:- module(Module,Exports))), !.
get_exports(O, Exports, Module) :-
get_exports(O, Exports, Module).
get_reexports(O, Exports, ExportsL) :-
read(O, (:- reexport(_File,ExportsI))), !,
get_reexports(O, Exports0, ExportsL),
append(ExportsI, Exports0, Exports).
get_reexports(_, Exports, Exports).
publish_exports([], _, _, _).
publish_exports([F/A|Exports], W, Path, Module) :-
publish_export(F, A, W, Path, Module),
publish_exports(Exports, W, Path, Module).
publish_exports([F//A0|Exports], W, Path, Module) :-
A is A0+2,
publish_export(F, A, W, Path, Module),
publish_exports(Exports, W, Path, Module).
publish_exports([op(_,_,_)|Exports], W, Path, Module) :-
publish_exports(Exports, W, Path, Module).
publish_export(F, A, _, _, Module) :-
exported(F, A, M), M \= Module, !,
format(user_error,'[ warning: clash between ~a and ~a over ~a/~d ]~n',[Module,M,F,A]).
publish_export(F, A, W, Path, Module) :-
assert(exported(F, A, Module)), !,
portray_clause(W, index(F, A, Module, Path)).
find_predicate(G,ExportingModI) :-
nonvar(G), !,
functor(G, Name, Arity),
index(Name,Arity,ExportingModI,File),
ensure_file_loaded(File).
find_predicate(G,ExportingModI) :-
var(G),
index(Name,Arity,ExportingModI,File),
functor(G, Name, Arity),
ensure_file_loaded(File).
ensure_file_loaded(File) :-
loaded(File), !.
ensure_file_loaded(File) :-
load_files(autoloader:File,[silent(true),if(not_loaded)]),
assert(loaded(File)).

View File

@@ -1,152 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: regexp.yap *
* Last rev: 5/15/2000 *
* mods: *
* comments: AVL trees in YAP (from code by M. van Emden, P. Vasey) *
* *
*************************************************************************/
/**
* @file avl.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 00:59:28 2015
*
* @brief Support for constructing AVL trees
*
*
*/
:- module(avl, [
avl_new/1,
avl_insert/4,
avl_lookup/3
]).
/**
* @defgroup avl AVL Trees
* @ingroup library
@{
Supports constructing AVL trees, available through the directive:
~~~~~~~
:- use_module(library(avl)).
~~~~~~~
It includes the following predicates:
- avl_insert/4
- avl_lookup/3
- avl_new/1
AVL trees are balanced search binary trees. They are named after their
inventors, Adelson-Velskii and Landis, and they were the first
dynamically balanced trees to be proposed. The YAP AVL tree manipulation
predicates library uses code originally written by Martin van Emdem and
published in the Logic Programming Newsletter, Autumn 1981. A bug in
this code was fixed by Philip Vasey, in the Logic Programming
Newsletter, Summer 1982. The library currently only includes routines to
insert and lookup elements in the tree. Please try red-black trees if
you need deletion.
*/
/** @pred avl_new(+ _T_)
Create a new tree.
*/
avl_new([]).
/** @pred avl_insert(+ _Key_,? _Value_,+ _T0_,- _TF_)
Add an element with key _Key_ and _Value_ to the AVL tree
_T0_ creating a new AVL tree _TF_. Duplicated elements are
allowed.
*/
avl_insert(Key, Value, T0, TF) :-
insert(T0, Key, Value, TF, _).
insert([], Key, Value, avl([],Key,Value,-,[]), yes).
insert(avl(L,Root,RVal,Bl,R), E, Value, NewTree, WhatHasChanged) :-
E @< Root, !,
insert(L, E, Value, NewL, LeftHasChanged),
adjust(avl(NewL,Root,RVal,Bl,R), LeftHasChanged, left, NewTree, WhatHasChanged).
insert(avl(L,Root,RVal,Bl,R), E, Val, NewTree, WhatHasChanged) :-
% E @>= Root, currently we allow duplicated values, although
% lookup will only fetch the first.
insert(R, E, Val,NewR, RightHasChanged),
adjust(avl(L,Root,RVal,Bl,NewR), RightHasChanged, right, NewTree, WhatHasChanged).
adjust(Oldtree, no, _, Oldtree, no).
adjust(avl(L,Root,RVal,Bl,R), yes, Lor, NewTree, WhatHasChanged) :-
table(Bl, Lor, Bl1, WhatHasChanged, ToBeRebalanced),
rebalance(avl(L, Root, RVal, Bl, R), Bl1, ToBeRebalanced, NewTree).
% balance where balance whole tree to be
% before inserted after increased rebalanced
table(- , left , < , yes , no ).
table(- , right , > , yes , no ).
table(< , left , - , no , yes ).
table(< , right , - , no , no ).
table(> , left , - , no , no ).
table(> , right , - , no , yes ).
rebalance(avl(Lst, Root, RVal, _Bl, Rst), Bl1, no, avl(Lst, Root, RVal, Bl1,Rst)).
rebalance(OldTree, _, yes, NewTree) :-
avl_geq(OldTree,NewTree).
avl_geq(avl(Alpha,A,VA,>,avl(Beta,B,VB,>,Gamma)),
avl(avl(Alpha,A,VA,-,Beta),B,VB,-,Gamma)).
avl_geq(avl(avl(Alpha,A,VA,<,Beta),B,VB,<,Gamma),
avl(Alpha,A,VA,-,avl(Beta,B,VB,-,Gamma))).
avl_geq(avl(Alpha,A,VA,>,avl(avl(Beta,X,VX,Bl1,Gamma),B,VB,<,Delta)),
avl(avl(Alpha,A,VA,Bl2,Beta),X,VX,-,avl(Gamma,B,VB,Bl3,Delta))) :-
table2(Bl1,Bl2,Bl3).
avl_geq(avl(avl(Alpha,A,VA,>,avl(Beta,X,VX,Bl1,Gamma)),B,VB,<,Delta),
avl(avl(Alpha,A,VA,Bl2,Beta),X,VX,-,avl(Gamma,B,VB,Bl3,Delta))) :-
table2(Bl1,Bl2,Bl3).
table2(< ,- ,> ).
table2(> ,< ,- ).
table2(- ,- ,- ).
/** @pred avl_lookup(+ _Key_,- _Value_,+ _T_)
Lookup an element with key _Key_ in the AVL tree
_T_, returning the value _Value_.
*/
avl_lookup(Key, Value, avl(L,Key0,KVal,_,R)) :-
compare(Cmp, Key, Key0),
avl_lookup(Cmp, Value, L, R, Key, KVal).
avl_lookup(=, Value, _, _, _, Value).
avl_lookup(<, Value, L, _, Key, _) :-
avl_lookup(Key, Value, L).
avl_lookup(>, Value, _, R, Key, _) :-
avl_lookup(Key, Value, R).
/**
@}
*/

View File

@@ -1,332 +0,0 @@
%% -*- Prolog -*-
/**
* @file bhash.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 01:11:29 2015
*
* @brief Backtrackable Hash Tables
*
*
*/
:- source.
:- yap_flag(unknown,error).
:- style_check(all).
:- module(b_hash, [ b_hash_new/1,
b_hash_new/2,
b_hash_new/4,
b_hash_lookup/3,
b_hash_update/3,
b_hash_update/4,
b_hash_insert_new/4,
b_hash_insert/4,
b_hash_size/2,
b_hash_code/2,
is_b_hash/1,
b_hash_to_list/2,
b_hash_values_to_list/2,
b_hash_keys_to_list/2
]).
/**
* @defgroup bhash Backtrackable Hash Tables
* @ingroup library
@{
This library implements hash-arrays.
It requires the hash key to be a ground term. The library can
be loaded as
:- use_module( library( bhash ) ).
This code relies on backtrackable updates. The default hash key is
generated by term_hash/4.
*/
:- use_module(library(terms), [ term_hash/4 ]).
:- meta_predicate(b_hash_new(-,+,3,2)).
array_default_size(2048).
/** @pred is_b_hash( +Hash )
Term _Hash_ is a hash table.
*/
is_b_hash(V) :- var(V), !, fail.
is_b_hash(hash(_,_,_,_,_)).
/** @pred b_hash_new( -NewHash )
Create a empty hash table _NewHash_, with size 2048 entries.
*/
b_hash_new(hash(Keys, Vals, Size, N, _, _)) :-
array_default_size(Size),
array(Keys, Size),
array(Vals, Size),
create_mutable(0, N).
/** @pred b_hash_new( -_NewHash_, +_Size_ )
Create a empty hash table, with size _Size_ entries.
*/
b_hash_new(hash(Keys, Vals, Size, N, _, _), Size) :-
array(Keys, Size),
array(Vals, Size),
create_mutable(0, N).
/** @pred b_hash_new( -_NewHash_, +_Size_, :_Hash_, :_Cmp_ )
Create a empty hash table, with size _Size_ entries.
_Hash_ defines a partition function, and _Cmp_ defined a comparison function.
*/
b_hash_new(hash(Keys,Vals, Size, N, HashF, CmpF), Size, HashF, CmpF) :-
array(Keys, Size),
array(Vals, Size),
create_mutable(0, N).
/**
@pred b_hash_size( +_Hash_, -_Size_ )
_Size_ unifies with the size of the hash table _Hash_.
*/
b_hash_size(hash(_, _, Size, _, _, _), Size).
/**
@pred b_hash_lookup( +_Key_, ?_Val_, +_Hash_ )
Search the ground term _Key_ in table _Hash_ and unify _Val_ with the associated entry.
*/
b_hash_lookup(Key, Val, hash(Keys, Vals, Size, _, F, CmpF)):-
hash_f(Key, Size, Index, F),
fetch_key(Keys, Index, Size, Key, CmpF, ActualIndex),
array_element(Vals, ActualIndex, Mutable),
get_mutable(Val, Mutable).
fetch_key(Keys, Index, Size, Key, CmpF, ActualIndex) :-
array_element(Keys, Index, El),
nonvar(El),
(
cmp_f(CmpF, El, Key)
->
Index = ActualIndex
;
I1 is (Index+1) mod Size,
fetch_key(Keys, I1, Size, Key, CmpF, ActualIndex)
).
/**
@pred b_hash_update( +_Key_, +_Hash_, +NewVal )
Update to the value associated with the ground term _Key_ in table _Hash_ to _NewVal_.
*/
b_hash_update(Hash, Key, NewVal):-
Hash = hash(Keys, Vals, Size, _, F, CmpF),
hash_f(Key,Size,Index,F),
fetch_key(Keys, Index, Size, Key, CmpF, ActualIndex),
array_element(Vals, ActualIndex, Mutable),
update_mutable(NewVal, Mutable).
/**
@pred b_hash_update( +_Key_, -_OldVal_, +_Hash_, +NewVal )
Update to the value associated with the ground term _Key_ in table _Hash_ to _NewVal_, and unify _OldVal_ with the current value.
*/
b_hash_update(Hash, Key, OldVal, NewVal):-
Hash = hash(Keys, Vals, Size, _, F, CmpF),
hash_f(Key,Size,Index,F),
fetch_key(Keys, Index, Size, Key, CmpF, ActualIndex),
array_element(Vals, ActualIndex, Mutable),
get_mutable(OldVal, Mutable),
update_mutable(NewVal, Mutable).
/** b_hash_insert(+_Hash_, +_Key_, _Val_, +_NewHash_ )
Insert the term _Key_-_Val_ in table _Hash_ and unify _NewHash_ with the result. If ground term _Key_ exists, update the dictionary.
*/
b_hash_insert(Hash, Key, NewVal, NewHash):-
Hash = hash(Keys, Vals, Size, N, F, CmpF),
hash_f(Key,Size,Index,F),
find_or_insert(Keys, Index, Size, N, CmpF, Vals, Key, NewVal, Hash, NewHash).
find_or_insert(Keys, Index, Size, N, CmpF, Vals, Key, NewVal, Hash, NewHash) :-
array_element(Keys, Index, El),
(
var(El)
->
add_element(Keys, Index, Size, N, Vals, Key, NewVal, Hash, NewHash)
;
cmp_f(CmpF, El, Key)
->
% do rb_update
array_element(Vals, Index, Mutable),
update_mutable(NewVal, Mutable),
Hash = NewHash
;
I1 is (Index+1) mod Size,
find_or_insert(Keys, I1, Size, N, CmpF, Vals, Key, NewVal, Hash, NewHash)
).
/**
@pred b_hash_insert_new(+_Hash_, +_Key_, _Val_, +_NewHash_ )
Insert the term _Key_-_Val_ in table _Hash_ and unify _NewHash_ with the result. If ground term _Key_ exists, fail.
*/
b_hash_insert_new(Hash, Key, NewVal, NewHash):-
Hash = hash(Keys, Vals, Size, N, F, CmpF),
hash_f(Key,Size,Index,F),
find_or_insert_new(Keys, Index, Size, N, CmpF, Vals, Key, NewVal, Hash, NewHash).
find_or_insert_new(Keys, Index, Size, N, CmpF, Vals, Key, NewVal, Hash, NewHash) :-
array_element(Keys, Index, El),
(
var(El)
->
add_element(Keys, Index, Size, N, Vals, Key, NewVal, Hash, NewHash)
;
cmp_f(CmpF, El, Key)
->
fail
;
I1 is (Index+1) mod Size,
find_or_insert_new(Keys, I1, Size, N, CmpF, Vals, Key, NewVal, Hash, NewHash)
).
add_element(Keys, Index, Size, N, Vals, Key, NewVal, Hash, NewHash) :-
get_mutable(NEls, N),
NN is NEls+1,
update_mutable(NN, N),
array_element(Keys, Index, Key),
update_mutable(NN, N),
array_element(Vals, Index, Mutable),
create_mutable(NewVal, Mutable),
(
NN > Size/3
->
expand_array(Hash, NewHash)
;
Hash = NewHash
).
expand_array(Hash, NewHash) :-
Hash == NewHash, !,
Hash = hash(Keys, Vals, Size, _X, F, _CmpF),
new_size(Size, NewSize),
array(NewKeys, NewSize),
array(NewVals, NewSize),
copy_hash_table(Size, Keys, Vals, F, NewSize, NewKeys, NewVals),
/* overwrite in place */
setarg(1, Hash, NewKeys),
setarg(2, Hash, NewVals),
setarg(3, Hash, NewSize).
expand_array(Hash, hash(NewKeys, NewVals, NewSize, X, F, CmpF)) :-
Hash = hash(Keys, Vals, Size, X, F, CmpF),
new_size(Size, NewSize),
array(NewKeys, NewSize),
array(NewVals, NewSize),
copy_hash_table(Size, Keys, Vals, F, NewSize, NewKeys, NewVals).
new_size(Size, NewSize) :-
Size > 1048576, !,
NewSize is Size+1048576.
new_size(Size, NewSize) :-
NewSize is Size*2.
copy_hash_table(0, _, _, _, _, _, _) :- !.
copy_hash_table(I1, Keys, Vals, F, Size, NewKeys, NewVals) :-
I is I1-1,
array_element(Keys, I, Key),
nonvar(Key), !,
array_element(Vals, I, Val),
insert_el(Key, Val, Size, F, NewKeys, NewVals),
copy_hash_table(I, Keys, Vals, F, Size, NewKeys, NewVals).
copy_hash_table(I1, Keys, Vals, F, Size, NewKeys, NewVals) :-
I is I1-1,
copy_hash_table(I, Keys, Vals, F, Size, NewKeys, NewVals).
insert_el(Key, Val, Size, F, NewKeys, NewVals) :-
hash_f(Key,Size,Index, F),
find_free(Index, Size, NewKeys, TrueIndex),
array_element(NewKeys, TrueIndex, Key),
array_element(NewVals, TrueIndex, Val).
find_free(Index, Size, Keys, NewIndex) :-
array_element(Keys, Index, El),
(
var(El)
->
NewIndex = Index
;
I1 is (Index+1) mod Size,
find_free(I1, Size, Keys, NewIndex)
).
hash_f(Key, Size, Index, F) :-
var(F), !,
term_hash(Key,-1,Size,Index).
hash_f(Key, Size, Index, F) :-
call(F, Key, Size, Index).
cmp_f(F, A, B) :-
var(F), !,
A == B.
cmp_f(F, A, B) :-
call(F, A, B).
/**
@pred b_hash_to_list(+_Hash_, -_KeyValList_ )
The term _KeyValList_ unifies with a list containing all terms _Key_-_Val_ in the hash table.
*/
b_hash_to_list(hash(Keys, Vals, _, _, _, _), LKeyVals) :-
Keys =.. (_.LKs),
Vals =.. (_.LVs),
mklistpairs(LKs, LVs, LKeyVals).
/**
@pred b_key_to_list(+_Hash_, -_KeyList_ )
The term _KeyList_ unifies with a list containing all keys in the hash table.
*/
b_hash_keys_to_list(hash(Keys, _, _, _, _, _), LKeys) :-
Keys =.. (_.LKs),
mklistels(LKs, LKeys).
/**
@pred b_key_to_list(+_Hash_, -_ValList_ )
The term _`valList_ unifies with a list containing all values in the hash table.
*/
b_hash_values_to_list(hash(_, Vals, _, _, _, _), LVals) :-
Vals =.. (_.LVs),
mklistvals(LVs, LVals).
mklistpairs([], [], []).
mklistpairs(V.LKs, _.LVs, KeyVals) :- var(V), !,
mklistpairs(LKs, LVs, KeyVals).
mklistpairs(K.LKs, V.LVs, (K-VV).KeyVals) :-
get_mutable(VV, V),
mklistpairs(LKs, LVs, KeyVals).
mklistels([], []).
mklistels(V.Els, NEls) :- var(V), !,
mklistels(Els, NEls).
mklistels(K.Els, K.NEls) :-
mklistels(Els, NEls).
mklistvals([], []).
mklistvals(V.Vals, NVals) :- var(V), !,
mklistvals(Vals, NVals).
mklistvals(K.Vals, KK.NVals) :-
get_mutable(KK, K),
mklistvals(Vals, NVals).
/**
@}
*/

View File

@@ -1,477 +0,0 @@
%%% -*- Mode: Prolog; -*-
/**
* @file block_diagram.yap
* @author Theofrastos Mantadelis, Sugestions from Paulo Moura
* @date Tue Nov 17 14:12:02 2015
*
* @brief Graph the program structure.
*
* @{
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Flags was developed at Katholieke Universiteit Leuven
%
% Copyright 2010
% Katholieke Universiteit Leuven
%
% Contributions to this file:
% Author: Theofrastos Mantadelis
% Sugestions: Paulo Moura
% Version: 1
% Date: 19/11/2010
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Artistic License 2.0
%
% Copyright (c) 2000-2006, The Perl Foundation.
%
% Everyone is permitted to copy and distribute verbatim copies of this
% license document, but changing it is not allowed. Preamble
%
% This license establishes the terms under which a given free software
% Package may be copied, modified, distributed, and/or
% redistributed. The intent is that the Copyright Holder maintains some
% artistic control over the development of that Package while still
% keeping the Package available as open source and free software.
%
% You are always permitted to make arrangements wholly outside of this
% license directly with the Copyright Holder of a given Package. If the
% terms of this license do not permit the full use that you propose to
% make of the Package, you should contact the Copyright Holder and seek
% a different licensing arrangement. Definitions
%
% "Copyright Holder" means the individual(s) or organization(s) named in
% the copyright notice for the entire Package.
%
% "Contributor" means any party that has contributed code or other
% material to the Package, in accordance with the Copyright Holder's
% procedures.
%
% "You" and "your" means any person who would like to copy, distribute,
% or modify the Package.
%
% "Package" means the collection of files distributed by the Copyright
% Holder, and derivatives of that collection and/or of those files. A
% given Package may consist of either the Standard Version, or a
% Modified Version.
%
% "Distribute" means providing a copy of the Package or making it
% accessible to anyone else, or in the case of a company or
% organization, to others outside of your company or organization.
%
% "Distributor Fee" means any fee that you charge for Distributing this
% Package or providing support for this Package to another party. It
% does not mean licensing fees.
%
% "Standard Version" refers to the Package if it has not been modified,
% or has been modified only in ways explicitly requested by the
% Copyright Holder.
%
% "Modified Version" means the Package, if it has been changed, and such
% changes were not explicitly requested by the Copyright Holder.
%
% "Original License" means this Artistic License as Distributed with the
% Standard Version of the Package, in its current version or as it may
% be modified by The Perl Foundation in the future.
%
% "Source" form means the source code, documentation source, and
% configuration files for the Package.
%
% "Compiled" form means the compiled bytecode, object code, binary, or
% any other form resulting from mechanical transformation or translation
% of the Source form.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Permission for Use and Modification Without Distribution
%
% (1) You are permitted to use the Standard Version and create and use
% Modified Versions for any purpose without restriction, provided that
% you do not Distribute the Modified Version.
%
% Permissions for Redistribution of the Standard Version
%
% (2) You may Distribute verbatim copies of the Source form of the
% Standard Version of this Package in any medium without restriction,
% either gratis or for a Distributor Fee, provided that you duplicate
% all of the original copyright notices and associated disclaimers. At
% your discretion, such verbatim copies may or may not include a
% Compiled form of the Package.
%
% (3) You may apply any bug fixes, portability changes, and other
% modifications made available from the Copyright Holder. The resulting
% Package will still be considered the Standard Version, and as such
% will be subject to the Original License.
%
% Distribution of Modified Versions of the Package as Source
%
% (4) You may Distribute your Modified Version as Source (either gratis
% or for a Distributor Fee, and with or without a Compiled form of the
% Modified Version) provided that you clearly document how it differs
% from the Standard Version, including, but not limited to, documenting
% any non-standard features, executables, or modules, and provided that
% you do at least ONE of the following:
%
% (a) make the Modified Version available to the Copyright Holder of the
% Standard Version, under the Original License, so that the Copyright
% Holder may include your modifications in the Standard Version. (b)
% ensure that installation of your Modified Version does not prevent the
% user installing or running the Standard Version. In addition, the
% modified Version must bear a name that is different from the name of
% the Standard Version. (c) allow anyone who receives a copy of the
% Modified Version to make the Source form of the Modified Version
% available to others under (i) the Original License or (ii) a license
% that permits the licensee to freely copy, modify and redistribute the
% Modified Version using the same licensing terms that apply to the copy
% that the licensee received, and requires that the Source form of the
% Modified Version, and of any works derived from it, be made freely
% available in that license fees are prohibited but Distributor Fees are
% allowed.
%
% Distribution of Compiled Forms of the Standard Version or
% Modified Versions without the Source
%
% (5) You may Distribute Compiled forms of the Standard Version without
% the Source, provided that you include complete instructions on how to
% get the Source of the Standard Version. Such instructions must be
% valid at the time of your distribution. If these instructions, at any
% time while you are carrying out such distribution, become invalid, you
% must provide new instructions on demand or cease further
% distribution. If you provide valid instructions or cease distribution
% within thirty days after you become aware that the instructions are
% invalid, then you do not forfeit any of your rights under this
% license.
%
% (6) You may Distribute a Modified Version in Compiled form without the
% Source, provided that you comply with Section 4 with respect to the
% Source of the Modified Version.
%
% Aggregating or Linking the Package
%
% (7) You may aggregate the Package (either the Standard Version or
% Modified Version) with other packages and Distribute the resulting
% aggregation provided that you do not charge a licensing fee for the
% Package. Distributor Fees are permitted, and licensing fees for other
% components in the aggregation are permitted. The terms of this license
% apply to the use and Distribution of the Standard or Modified Versions
% as included in the aggregation.
%
% (8) You are permitted to link Modified and Standard Versions with
% other works, to embed the Package in a larger work of your own, or to
% build stand-alone binary or bytecode versions of applications that
% include the Package, and Distribute the result without restriction,
% provided the result does not expose a direct interface to the Package.
%
% Items That are Not Considered Part of a Modified Version
%
% (9) Works (including, but not limited to, modules and scripts) that
% merely extend or make use of the Package, do not, by themselves, cause
% the Package to be a Modified Version. In addition, such works are not
% considered parts of the Package itself, and are not subject to the
% terms of this license.
%
% General Provisions
%
% (10) Any use, modification, and distribution of the Standard or
% Modified Versions is governed by this Artistic License. By using,
% modifying or distributing the Package, you accept this license. Do not
% use, modify, or distribute the Package, if you do not accept this
% license.
%
% (11) If your Modified Version has been derived from a Modified Version
% made by someone other than you, you are nevertheless required to
% ensure that your Modified Version complies with the requirements of
% this license.
%
% (12) This license does not grant you the right to use any trademark,
% service mark, tradename, or logo of the Copyright Holder.
%
% (13) This license includes the non-exclusive, worldwide,
% free-of-charge patent license to make, have made, use, offer to sell,
% sell, import and otherwise transfer the Package with respect to any
% patent claims licensable by the Copyright Holder that are necessarily
% infringed by the Package. If you institute patent litigation
% (including a cross-claim or counterclaim) against any party alleging
% that the Package constitutes direct or contributory patent
% infringement, then this Artistic License to you shall terminate on the
% date that such litigation is filed.
%
% (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT
% HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED
% WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
% PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT
% PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT
% HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT,
% INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE
% OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/** @defgroup block_diagram Block Diagram
@ingroup library
@{
This library provides a way of visualizing a prolog program using
modules with blocks. To use it use:
`:-use_module(library(block_diagram))`.
*/
:- module(block_diagram, [make_diagram/2, make_diagram/5]).
/* ---------------------------------------------------------------------- *\
|* Missing stuff: a parameter that bounds the module connection depth *|
|* and a parameter that diseables/limits the text over edges *|
\* ---------------------------------------------------------------------- */
:- style_check(all).
:- yap_flag(unknown, error).
:- use_module(library(charsio), [term_to_atom/2]).
:- use_module(library(lists), [memberchk/2, member/2, append/3]).
:- use_module(library(system), [working_directory/2]).
:- dynamic([seen_module/1, parameter/1]).
parameter(texts((+inf))).
parameter(depth((+inf))).
parameter(default_ext('.yap')).
/** @pred make_diagram(+Inputfilename, +Ouputfilename)
This will crawl the files following the use_module, ensure_loaded directives withing the inputfilename.
The result will be a file in dot format.
You can make a pdf at the shell by asking `dot -Tpdf filename > output.pdf`.
*/
make_diagram(InputFile, OutputFile):-
tell(OutputFile),
write('digraph G {\nrankdir=BT'), nl,
extract_name_file(InputFile, Name, File),
nb_setval(depth, 0),
read_module_file(File, Name),
write_explicit,
write('}'), nl,
told.
/** @pred make_diagram(+Inputfilename, +Ouputfilename, +Predicate, +Depth, +Extension)
The same as make_diagram/2 but you can define how many of the imported/exporeted predicates will be shown with predicate, and how deep the crawler is allowed to go with depth. The extension is used if the file use module directives do not include a file extension.
*/
make_diagram(InputFile, OutputFile, Texts, Depth, Ext):-
integer(Texts),
integer(Depth),
retractall(parameter(_)),
assertz(parameter(texts(Texts))),
assertz(parameter(depth(Depth))),
assertz(parameter(default_ext(Ext))),
make_diagram(InputFile, OutputFile),
retractall(parameter(_)),
assertz(parameter(texts((+inf)))),
assertz(parameter(depth((+inf)))),
assertz(parameter(default_ext('.yap'))).
path_seperator('\\'):-
yap_flag(windows, true), !.
path_seperator('/').
split_path_file(PathFile, Path, File):-
path_seperator(PathSeperator),
atom_concat(Path, File, PathFile),
name(PathSeperator, [PathSeperatorName]),
name(File, FileName),
\+ memberchk(PathSeperatorName, FileName),
!.
split_file_ext(FileExt, File, Ext):-
atom_concat(File, Ext, FileExt),
atom_concat('.', _, Ext),
name('.', [DotName]),
name(Ext, ExtName),
findall(A, (member(A, ExtName), A = DotName), L),
length(L, 1), !.
parse_module_directive(':-'(module(Name)), _):-
seen_module(node(Name)), !.
parse_module_directive(':-'(module(Name, _Exported)), _):-
seen_module(node(Name)), !.
parse_module_directive(':-'(module(Name, Exported)), Shape):-
!, \+ seen_module(node(Name)),
assertz(seen_module(node(Name))),
list_to_message(Exported, ExportedMessage),
atom_concat([Name, ' [shape=', Shape,',label="', Name, '\\n', ExportedMessage, '"]'], NodeDefinition),
write(NodeDefinition), nl.
parse_module_directive(':-'(module(Name)), Shape):-
\+ seen_module(node(Name)),
assertz(seen_module(node(Name))),
atom_concat([Name, ' [shape=', Shape,',label="', Name, '"]'], NodeDefinition),
write(NodeDefinition), nl.
extract_name_file(PathFile, Name, FinalFile):-
split_path_file(PathFile, Path, FileName), Path \== '', !,
extract_name_file(FileName, Name, File),
atom_concat(Path, File, FinalFile).
extract_name_file(File, Name, File):-
split_file_ext(File, Name, _), !.
extract_name_file(Name, Name, File):-
parameter(default_ext(Ext)),
atom_concat(Name, Ext, File).
read_use_module_directive(':-'(ensure_loaded(library(Name))), Name, library(Name), []):- !.
read_use_module_directive(':-'(ensure_loaded(Path)), Name, FinalFile, []):-
extract_name_file(Path, Name, FinalFile), !.
read_use_module_directive(':-'(use_module(library(Name))), Name, library(Name), []):- !.
read_use_module_directive(':-'(use_module(Path)), Name, FinalFile, []):-
extract_name_file(Path, Name, FinalFile), !.
read_use_module_directive(':-'(use_module(library(Name), Import)), Name, library(Name), Import):- !.
read_use_module_directive(':-'(use_module(Path, Import)), Name, FinalFile, Import):-
extract_name_file(Path, Name, FinalFile), !.
read_use_module_directive(':-'(use_module(Name, Path, Import)), Name, FinalFile, Import):-
nonvar(Path),
extract_name_file(Path, _, FinalFile), !.
read_use_module_directive(':-'(use_module(Name, Path, Import)), Name, FinalFile, Import):-
var(Path),
extract_name_file(Name, _, FinalFile), !.
parse_use_module_directive(Module, Directive):-
read_use_module_directive(Directive, Name, File, Imported),
parse_use_module_directive(Module, Name, File, Imported).
parse_use_module_directive(Module, Name, _File, _Imported):-
seen_module(edge(Module, Name)), !.
parse_use_module_directive(Module, Name, File, Imported):-
\+ seen_module(edge(Module, Name)),
assertz(seen_module(edge(Module, Name))),
read_module_file(File, Name),
list_to_message(Imported, ImportedMessage),
atom_concat([Module, ' -> ', Name, ' [label="', ImportedMessage, '"]'], NodeConnection),
write(NodeConnection), nl.
list_to_message(List, Message):-
length(List, Len),
parameter(texts(TextCnt)),
(Len > TextCnt + 1 ->
append(FirstCnt, _, List),
length(FirstCnt, TextCnt),
append(FirstCnt, ['...'], First)
;
First = List
),
list_to_message(First, '', Message).
list_to_message([], Message, Message).
list_to_message([H|T], '', FinalMessage):-
term_to_atom(H, HAtom), !,
list_to_message(T, HAtom, FinalMessage).
list_to_message([H|T], AccMessage, FinalMessage):-
term_to_atom(H, HAtom),
atom_concat([AccMessage, '\\n', HAtom], NewMessage),
list_to_message(T, NewMessage, FinalMessage).
read_module_file(library(Module), Module):-
!, parse_module_directive(':-'(module(Module, [])), component).
read_module_file(File, Module):-
parameter(depth(MaxDepth)),
nb_getval(depth, Depth),
MaxDepth > Depth,
split_path_file(File, Path, FileName),
catch((working_directory(CurDir,Path), open(FileName, read, S)), _, (parse_module_directive(':-'(module(Module, [])), box3d), fail)),
NDepth is Depth + 1,
nb_setval(depth, NDepth),
repeat,
catch(read(S, Next),_,fail),
process(Module, Next),
nb_setval(depth, Depth),
close(S), working_directory(_,CurDir), !.
read_module_file(_, _).
/** @pred process(+ _StreamInp_, + _Goal_)
For every line _LineIn_ in stream _StreamInp_, call
`call(Goal,LineIn)`.
*/
process(_, end_of_file):-!.
process(_, Term):-
parse_module_directive(Term, box), !, fail.
process(Module, Term):-
parse_use_module_directive(Module, Term), !, fail.
process(Module, Term):-
find_explicit_qualification(Module, Term), fail.
find_explicit_qualification(OwnerModule, ':-'(Module:Goal)):-
!, explicit_qualification(OwnerModule, Module, Goal).
find_explicit_qualification(OwnerModule, ':-'(_Head, Body)):-
find_explicit_qualification(OwnerModule, Body).
find_explicit_qualification(OwnerModule, (Module:Goal, RestBody)):-
!, explicit_qualification(OwnerModule, Module, Goal),
find_explicit_qualification(OwnerModule, RestBody).
find_explicit_qualification(OwnerModule, (_Goal, RestBody)):-
!, find_explicit_qualification(OwnerModule, RestBody).
find_explicit_qualification(OwnerModule, Module:Goal):-
!, explicit_qualification(OwnerModule, Module, Goal).
find_explicit_qualification(_OwnerModule, _Goal).
explicit_qualification(InModule, ToModule, Goal):-
nonvar(Goal), nonvar(ToModule), !,
functor(Goal, FunctorName, Arity),
\+ seen_module(explicit(InModule, ToModule, FunctorName/Arity)),
assertz(seen_module(explicit(InModule, ToModule, FunctorName/Arity))).
explicit_qualification(InModule, ToModule, Goal):-
var(Goal), nonvar(ToModule), !,
\+ seen_module(explicit(InModule, ToModule, 'DYNAMIC')),
assertz(seen_module(explicit(InModule, ToModule, 'DYNAMIC'))).
explicit_qualification(InModule, ToModule, Goal):-
nonvar(Goal), var(ToModule), !,
functor(Goal, FunctorName, Arity),
\+ seen_module(explicit(InModule, 'DYNAMIC', FunctorName/Arity)),
assertz(seen_module(explicit(InModule, 'DYNAMIC', FunctorName/Arity))).
explicit_qualification(InModule, ToModule, Goal):-
var(Goal), var(ToModule),
\+ seen_module(explicit(InModule, 'DYNAMIC', 'DYNAMIC')),
assertz(seen_module(explicit(InModule, 'DYNAMIC', 'DYNAMIC'))).
write_explicit:-
seen_module(explicit(InModule, ToModule, _Goal)),
\+ seen_module(generate_explicit(InModule, ToModule)),
assertz(seen_module(generate_explicit(InModule, ToModule))),
all(Goal, seen_module(explicit(InModule, ToModule, Goal)), Goals),
list_to_message(Goals, Explicit),
atom_concat([InModule, ' -> ', ToModule, ' [label="', Explicit, '",style=dashed]'], NodeConnection),
write(NodeConnection), nl, fail.
write_explicit.
/*
functor(Goal, FunctorName, Arity),
term_to_atom(FunctorName/Arity, Imported),
atom_concat([InModule, ' -> ', ToModule, ' [label="', Imported, '",style=dashed]'], NodeConnection),
write(NodeConnection), nl.
atom_concat([InModule, ' -> ', ToModule, ' [label="DYNAMIC",style=dashed]'], NodeConnection),
write(NodeConnection), nl.
functor(Goal, FunctorName, Arity),
term_to_atom(FunctorName/Arity, Imported),
atom_concat([InModule, ' -> DYNAMIC [label="', Imported, '",style=dashed]'], NodeConnection),
write(NodeConnection), nl.
atom_concat([InModule, ' -> DYNAMIC [label="DYNAMIC",style=dashed]'], NodeConnection),
write(NodeConnection), nl.
*/
%% @} @}

View File

@@ -1,422 +0,0 @@
%%% -*- Mode: Prolog; -*-
/**
* @file c_alarms.yap
* @author Theofrastos Mantadelis
* @date Tue Nov 17 14:50:03 2015
*
* @brief Concurrent alarms
*
*
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Concurrent alarms was developed at Katholieke Universiteit Leuven
%
% Copyright 2010
% Katholieke Universiteit Leuven
%
% Contributions to this file:
% Author: Theofrastos Mantadelis
% $Date: 2011-02-04 16:04:49 +0100 (Fri, 04 Feb 2011) $
% $Revision: 11 $
% Contributions: The timer implementation is inspired by Bernd Gutmann's timers
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Artistic License 2.0
%
% Copyright (c) 2000-2006, The Perl Foundation.
%
% Everyone is permitted to copy and distribute verbatim copies of this
% license document, but changing it is not allowed. Preamble
%
% This license establishes the terms under which a given free software
% Package may be copied, modified, distributed, and/or
% redistributed. The intent is that the Copyright Holder maintains some
% artistic control over the development of that Package while still
% keeping the Package available as open source and free software.
%
% You are always permitted to make arrangements wholly outside of this
% license directly with the Copyright Holder of a given Package. If the
% terms of this license do not permit the full use that you propose to
% make of the Package, you should contact the Copyright Holder and seek
% a different licensing arrangement. Definitions
%
% "Copyright Holder" means the individual(s) or organization(s) named in
% the copyright notice for the entire Package.
%
% "Contributor" means any party that has contributed code or other
% material to the Package, in accordance with the Copyright Holder's
% procedures.
%
% "You" and "your" means any person who would like to copy, distribute,
% or modify the Package.
%
% "Package" means the collection of files distributed by the Copyright
% Holder, and derivatives of that collection and/or of those files. A
% given Package may consist of either the Standard Version, or a
% Modified Version.
%
% "Distribute" means providing a copy of the Package or making it
% accessible to anyone else, or in the case of a company or
% organization, to others outside of your company or organization.
%
% "Distributor Fee" means any fee that you charge for Distributing this
% Package or providing support for this Package to another party. It
% does not mean licensing fees.
%
% "Standard Version" refers to the Package if it has not been modified,
% or has been modified only in ways explicitly requested by the
% Copyright Holder.
%
% "Modified Version" means the Package, if it has been changed, and such
% changes were not explicitly requested by the Copyright Holder.
%
% "Original License" means this Artistic License as Distributed with the
% Standard Version of the Package, in its current version or as it may
% be modified by The Perl Foundation in the future.
%
% "Source" form means the source code, documentation source, and
% configuration files for the Package.
%
% "Compiled" form means the compiled bytecode, object code, binary, or
% any other form resulting from mechanical transformation or translation
% of the Source form.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Permission for Use and Modification Without Distribution
%
% (1) You are permitted to use the Standard Version and create and use
% Modified Versions for any purpose without restriction, provided that
% you do not Distribute the Modified Version.
%
% Permissions for Redistribution of the Standard Version
%
% (2) You may Distribute verbatim copies of the Source form of the
% Standard Version of this Package in any medium without restriction,
% either gratis or for a Distributor Fee, provided that you duplicate
% all of the original copyright notices and associated disclaimers. At
% your discretion, such verbatim copies may or may not include a
% Compiled form of the Package.
%
% (3) You may apply any bug fixes, portability changes, and other
% modifications made available from the Copyright Holder. The resulting
% Package will still be considered the Standard Version, and as such
% will be subject to the Original License.
%
% Distribution of Modified Versions of the Package as Source
%
% (4) You may Distribute your Modified Version as Source (either gratis
% or for a Distributor Fee, and with or without a Compiled form of the
% Modified Version) provided that you clearly document how it differs
% from the Standard Version, including, but not limited to, documenting
% any non-standard features, executables, or modules, and provided that
% you do at least ONE of the following:
%
% (a) make the Modified Version available to the Copyright Holder of the
% Standard Version, under the Original License, so that the Copyright
% Holder may include your modifications in the Standard Version. (b)
% ensure that installation of your Modified Version does not prevent the
% user installing or running the Standard Version. In addition, the
% modified Version must bear a name that is different from the name of
% the Standard Version. (c) allow anyone who receives a copy of the
% Modified Version to make the Source form of the Modified Version
% available to others under (i) the Original License or (ii) a license
% that permits the licensee to freely copy, modify and redistribute the
% Modified Version using the same licensing terms that apply to the copy
% that the licensee received, and requires that the Source form of the
% Modified Version, and of any works derived from it, be made freely
% available in that license fees are prohibited but Distributor Fees are
% allowed.
%
% Distribution of Compiled Forms of the Standard Version or
% Modified Versions without the Source
%
% (5) You may Distribute Compiled forms of the Standard Version without
% the Source, provided that you include complete instructions on how to
% get the Source of the Standard Version. Such instructions must be
% valid at the time of your distribution. If these instructions, at any
% time while you are carrying out such distribution, become invalid, you
% must provide new instructions on demand or cease further
% distribution. If you provide valid instructions or cease distribution
% within thirty days after you become aware that the instructions are
% invalid, then you do not forfeit any of your rights under this
% license.
%
% (6) You may Distribute a Modified Version in Compiled form without the
% Source, provided that you comply with Section 4 with respect to the
% Source of the Modified Version.
%
% Aggregating or Linking the Package
%
% (7) You may aggregate the Package (either the Standard Version or
% Modified Version) with other packages and Distribute the resulting
% aggregation provided that you do not charge a licensing fee for the
% Package. Distributor Fees are permitted, and licensing fees for other
% components in the aggregation are permitted. The terms of this license
% apply to the use and Distribution of the Standard or Modified Versions
% as included in the aggregation.
%
% (8) You are permitted to link Modified and Standard Versions with
% other works, to embed the Package in a larger work of your own, or to
% build stand-alone binary or bytecode versions of applications that
% include the Package, and Distribute the result without restriction,
% provided the result does not expose a direct interface to the Package.
%
% Items That are Not Considered Part of a Modified Version
%
% (9) Works (including, but not limited to, modules and scripts) that
% merely extend or make use of the Package, do not, by themselves, cause
% the Package to be a Modified Version. In addition, such works are not
% considered parts of the Package itself, and are not subject to the
% terms of this license.
%
% General Provisions
%
% (10) Any use, modification, and distribution of the Standard or
% Modified Versions is governed by this Artistic License. By using,
% modifying or distributing the Package, you accept this license. Do not
% use, modify, or distribute the Package, if you do not accept this
% license.
%
% (11) If your Modified Version has been derived from a Modified Version
% made by someone other than you, you are nevertheless required to
% ensure that your Modified Version complies with the requirements of
% this license.
%
% (12) This license does not grant you the right to use any trademark,
% service mark, tradename, or logo of the Copyright Holder.
%
% (13) This license includes the non-exclusive, worldwide,
% free-of-charge patent license to make, have made, use, offer to sell,
% sell, import and otherwise transfer the Package with respect to any
% patent claims licensable by the Copyright Holder that are necessarily
% infringed by the Package. If you institute patent litigation
% (including a cross-claim or counterclaim) against any party alleging
% that the Package constitutes direct or contributory patent
% infringement, then this Artistic License to you shall terminate on the
% date that such litigation is filed.
%
% (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT
% HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED
% WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
% PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT
% PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT
% HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT,
% INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE
% OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(c_alarms, [set_alarm/3,
unset_alarm/1,
time_out_call_once/3,
timer_start/1,
timer_restart/1,
timer_stop/2,
timer_elapsed/2,
timer_pause/2]).
/** @defgroup c_alarms Concurrent Alarms
@ingroup library
@{
This library provides a concurrent signals. To use it use:
`:-use_module(library(c_alarms))`.
*/
:- use_module(library(lists), [member/2, memberchk/2, delete/3]).
:- use_module(library(ordsets), [ord_add_element/3]).
:- use_module(library(apply_macros), [maplist/3]).
:- dynamic('$timer'/3).
:- meta_predicate(set_alarm(+, 0, -)).
:- meta_predicate(time_out_call_once(+, 0, -)).
:- meta_predicate(prove_once(0)).
:- initialization(local_init).
local_init:-
bb_put(alarms, []),
bb_put(identity, 0).
get_next_identity(ID):-
bb_get(identity, ID),
NID is ID + 1,
bb_put(identity, NID).
set_alarm(Seconds, Execute, ID):-
bb_get(alarms, []),
get_next_identity(ID), !,
bb_put(alarms, [alarm(Seconds, ID, Execute)]),
alarm(Seconds, alarm_handler, _).
%% set_alarm(+Seconds, +Execute, -ID)
%
% calls Executes after a time interval of Seconds
% ID is returned to be able to unset the alarm (the call will not be executed)
% set_alarm/3 supports multiple & nested settings of alarms.
% Known Bug: There is the case that an alarm might trigger +-1 second of the set time.
%
set_alarm(Seconds, Execute, ID):-
get_next_identity(ID), !,
bb_get(alarms, [alarm(CurrentSeconds, CurrentID, CurrentExecute)|Alarms]),
alarm(0, true, Remaining),
Elapsed is CurrentSeconds - Remaining - 1,
maplist(subtract(Elapsed), [alarm(CurrentSeconds, CurrentID, CurrentExecute)|Alarms], RemainingAlarms),
ord_add_element(RemainingAlarms, alarm(Seconds, ID, Execute), [alarm(NewSeconds, NewID, NewToExecute)|NewAlarms]),
bb_put(alarms, [alarm(NewSeconds, NewID, NewToExecute)|NewAlarms]),
alarm(NewSeconds, alarm_handler, _).
set_alarm(Seconds, Execute, ID):-
throw(error(permission_error(create, alarm, set_alarm(Seconds, Execute, ID)), 'Non permitted alarm identifier.')).
subtract(Elapsed, alarm(Seconds, ID, Execute), alarm(NewSeconds, ID, Execute)):-
NewSeconds is Seconds - Elapsed.
%% unset_alarm(+ID)
%
% It will unschedule the alarm.
% It will not affect other concurrent alarms.
%
unset_alarm(ID):-
\+ ground(ID),
throw(error(instantiation_error, 'Alarm ID needs to be instantiated.')).
unset_alarm(ID):-
bb_get(alarms, Alarms),
\+ memberchk(alarm(_Seconds, ID, _Execute), Alarms),
throw(error(existence_error(alarm, unset_alarm(ID)), 'Alarm does not exist.')).
unset_alarm(ID):-
alarm(0, true, Remaining),
bb_get(alarms, Alarms),
[alarm(Seconds, _, _)|_] = Alarms,
Elapsed is Seconds - Remaining - 1,
delete_alarm(Alarms, ID, NewAlarms),
bb_put(alarms, NewAlarms),
(NewAlarms = [alarm(NewSeconds, _, _)|_] ->
RemainingSeconds is NewSeconds - Elapsed,
alarm(RemainingSeconds, alarm_handler, _)
;
true
).
delete_alarm(Alarms, ID, NewAlarms):-
memberchk(alarm(Seconds, ID, Execute), Alarms),
delete(Alarms, alarm(Seconds, ID, Execute), NewAlarms).
alarm_handler:-
bb_get(alarms, [alarm(_, _, CurrentExecute)|[]]),
bb_put(alarms, []),
call(CurrentExecute).
alarm_handler:-
bb_get(alarms, [alarm(Elapsed, CurrentID, CurrentExecute)|Alarms]),
maplist(subtract(Elapsed), Alarms, NewAlarms),
find_zeros(NewAlarms, ZeroAlarms),
findall(alarm(S, ID, E), (member(alarm(S, ID, E), NewAlarms), S > 0), NonZeroAlarms),
bb_put(alarms, NonZeroAlarms),
(NonZeroAlarms = [alarm(NewSeconds, _, _)|_] ->
alarm(NewSeconds, alarm_handler, _)
;
true
),
execute([alarm(0, CurrentID, CurrentExecute)|ZeroAlarms]).
find_zeros([], []).
find_zeros([alarm(0, ID, E)|T], [alarm(0, ID, E)|R]):-
find_zeros(T, R).
find_zeros([alarm(S, _, _)|T], R):-
S > 0,
find_zeros(T, R).
execute([]).
execute([alarm(_, _, Execute)|R]):-
call(Execute),
execute(R).
%% time_out_call(+Seconds, +Goal, -Return)
%
% It will will execute the closure Goal and returns its success or failure at Return.
% If the goal times out in Seconds then Return = timeout.
time_out_call_once(Seconds, Goal, Return):-
bb_get(identity, ID),
set_alarm(Seconds, throw(timeout(ID)), ID),
catch((
prove_once(Goal, Return),
unset_alarm(ID))
, Exception, (
(Exception == timeout(ID) ->
Return = timeout
;
unset_alarm(ID),
throw(Exception)
))).
prove_once(Goal, success):-
once(Goal), !.
prove_once(_Goal, failure).
timer_start(Name):-
\+ ground(Name),
throw(error(instantiation_error, 'Timer name needs to be instantiated.')).
timer_start(Name):-
'$timer'(Name, _, _),
throw(error(permission_error(create, timer, timer_start(Name)), 'Timer already exists.')).
timer_start(Name):-
statistics(walltime, [StartTime, _]),
assertz('$timer'(Name, running, StartTime)).
timer_restart(Name):-
\+ ground(Name),
throw(error(instantiation_error, 'Timer name needs to be instantiated.')).
timer_restart(Name):-
\+ '$timer'(Name, _, _), !,
statistics(walltime, [StartTime, _]),
assertz('$timer'(Name, running, StartTime)).
timer_restart(Name):-
retract('$timer'(Name, running, _)), !,
statistics(walltime, [StartTime, _]),
assertz('$timer'(Name, running, StartTime)).
timer_restart(Name):-
retract('$timer'(Name, paused, Duration)),
statistics(walltime, [StartTime, _]),
Elapsed is StartTime - Duration,
assertz('$timer'(Name, running, Elapsed)).
timer_stop(Name, Elapsed):-
\+ '$timer'(Name, _, _),
throw(error(existence_error(timer, timer_stop(Name, Elapsed)), 'Timer does not exist.')).
timer_stop(Name, Elapsed):-
retract('$timer'(Name, running, StartTime)), !,
statistics(walltime, [EndTime, _]),
Elapsed is EndTime - StartTime.
timer_stop(Name, Elapsed):-
retract('$timer'(Name, paused, Elapsed)).
timer_elapsed(Name, Elapsed):-
\+ '$timer'(Name, _, _),
throw(error(existence_error(timer, timer_elapsed(Name, Elapsed)), 'Timer does not exist.')).
timer_elapsed(Name, Elapsed):-
'$timer'(Name, running, StartTime), !,
statistics(walltime, [EndTime, _]),
Elapsed is EndTime - StartTime.
timer_elapsed(Name, Elapsed):-
'$timer'(Name, paused, Elapsed).
timer_pause(Name, Elapsed):-
\+ '$timer'(Name, _, _),
throw(error(existence_error(timer, timer_pause(Name, Elapsed)), 'Timer does not exist.')).
timer_pause(Name, Elapsed):-
'$timer'(Name, paused, _),
throw(error(permission_error(timer, timer_pause(Name, Elapsed)), 'Timer already paused.')).
timer_pause(Name, Elapsed):-
retract('$timer'(Name, _, StartTime)),
statistics(walltime, [EndTime, _]),
Elapsed is EndTime - StartTime,
assertz('$timer'(Name, paused, Elapsed)).
/**
@}
*/

View File

@@ -1,230 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: charsio.yap *
* Last rev: 5/12/99 *
* mods: *
* comments: I/O on character strings *
* *
*************************************************************************/
/**
* @file charsio.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 01:17:33 2015
*
* @brief Several operations on text.
* @{
*
*/
:- module(charsio, [
format_to_chars/3,
format_to_chars/4,
write_to_chars/3,
write_to_chars/2,
atom_to_chars/3,
atom_to_chars/2,
number_to_chars/3,
number_to_chars/2,
read_from_chars/2,
open_chars_stream/2,
with_output_to_chars/2,
with_output_to_chars/3,
with_output_to_chars/4,
term_to_atom/2
]).
/** @defgroup charsio Operations on Sequences of Codes.
@ingroup library
Term to sequence of codes conversion, mostly replaced by engine code.
You can use the following directive to load the files.
~~~~~~~
:- use_module(library(avl)).
~~~~~~~
It includes the following predicates:
- atom_to_chars/2
- atom_to_chars/3
- format_to_chars/3
- format_to_chars/4
- number_to_chars/2
- number_to_chars/3
- open_chars_stream/2
- read_from_chars/2
- term_to_atom/2
- with_output_to_chars/2
- with_output_to_chars/3
- with_output_to_chars/4
- write_to_chars/2
- write_to_chars/3
*/
:- meta_predicate(with_output_to_chars(0,?)).
:- meta_predicate(with_output_to_chars(0,-,?)).
:- meta_predicate(with_output_to_chars(0,-,?,?)).
/** @pred format_to_chars(+ _Form_, + _Args_, - _Result_)
Execute the built-in procedure format/2 with form _Form_ and
arguments _Args_ outputting the result to the string of character
codes _Result_.
*/
format_to_chars(Format, Args, Codes) :-
format(codes(Codes), Format, Args).
/** @pred format_to_chars(+ _Form_, + _Args_, - _Result_, - _Result0_)
Execute the built-in procedure format/2 with form _Form_ and
arguments _Args_ outputting the result to the difference list of
character codes _Result-Result0_.
*/
format_to_chars(Format, Args, OUT, L0) :-
format(codes(OUT, L0), Format, Args).
/** @pred write_to_chars(+ _Term_, - _Result_)
Execute the built-in procedure write/1 with argument _Term_
outputting the result to the string of character codes _Result_.
*/
write_to_chars(Term, Codes) :-
format(codes(Codes), '~w', [Term]).
/** @pred write_to_chars(+ _Term_, - _Result0_, - _Result_)
Execute the built-in procedure write/1 with argument _Term_
outputting the result to the difference list of character codes
_Result-Result0_.
*/
write_to_chars(Term, Out, Tail) :-
format(codes(Out,Tail),'~w',[Term]).
/** @pred atom_to_chars(+ _Atom_, - _Result_)
Convert the atom _Atom_ to the string of character codes
_Result_.
*/
atom_to_chars(Atom, OUT) :-
atom_codes(Atom, OUT).
/** @pred atom_to_chars(+ _Atom_, - _Result0_, - _Result_)
Convert the atom _Atom_ to the difference list of character codes
_Result-Result0_.
*/
atom_to_chars(Atom, L0, OUT) :-
format(codes(L0, OUT), '~a', [Atom]).
/** @pred number_to_chars(+ _Number_, - _Result_)
Convert the number _Number_ to the string of character codes
_Result_.
*/
number_to_chars(Number, OUT) :-
number_codes(Number, OUT).
/** @pred number_to_chars(+ _Number_, - _Result0_, - _Result_)
Convert the atom _Number_ to the difference list of character codes
_Result-Result0_.
*/
number_to_chars(Number, L0, OUT) :-
var(Number), !,
throw(error(instantiation_error,number_to_chars(Number, L0, OUT))).
number_to_chars(Number, L0, OUT) :-
number(Number), !,
format(codes(L0, OUT), '~w', [Number]).
number_to_chars(Number, L0, OUT) :-
throw(error(type_error(number,Number),number_to_chars(Number, L0, OUT))).
/** @pred open_chars_stream(+ _Chars_, - _Stream_)
Open the list of character codes _Chars_ as a stream _Stream_.
*/
open_chars_stream(Codes, Stream) :-
open_chars_stream(Codes, Stream, '').
open_chars_stream(Codes, Stream, Postfix) :-
predicate_property(memory_file:open_memory_file(_,_,_),_), !,
memory_file:new_memory_file(MF),
memory_file:open_memory_file(MF, write, Out),
format(Out, '~s~w', [Codes, Postfix]),
close(Out),
memory_file:open_memory_file(MF, read, Stream,
[ free_on_close(true)
]).
open_chars_stream(Codes, Stream, Postfix) :-
ensure_loaded(library(memfile)),
open_chars_stream(Codes, Stream, Postfix).
/** @pred with_output_to_chars(? _Goal_, - _Chars_)
Execute goal _Goal_ such that its standard output will be sent to a
memory buffer. After successful execution the contents of the memory
buffer will be converted to the list of character codes _Chars_.
*/
with_output_to_chars(Goal, Codes) :-
with_output_to(codes(Codes), Goal).
/** @pred with_output_to_chars(? _Goal_, ? _Chars0_, - _Chars_)
Execute goal _Goal_ such that its standard output will be sent to a
memory buffer. After successful execution the contents of the memory
buffer will be converted to the difference list of character codes
_Chars-Chars0_.
*/
with_output_to_chars(Goal, Codes, L0) :-
with_output_to(codes(Codes, L0), Goal).
%% with_output_to_chars(:Goal, -Stream, -Codes, ?Tail) is det.
%
% As with_output_to_chars/2, but Stream is unified with the
% temporary stream.
/** @pred with_output_to_chars(? _Goal_, - _Stream_, ? _Chars0_, - _Chars_)
Execute goal _Goal_ such that its standard output will be sent to a
memory buffer. After successful execution the contents of the memory
buffer will be converted to the difference list of character codes
_Chars-Chars0_ and _Stream_ receives the stream corresponding to
the memory buffer.
*/
with_output_to_chars(Goal, Stream, Codes, Tail) :-
with_output_to(codes(Codes, Tail), with_stream(Stream, Goal)).
with_stream(Stream, Goal) :-
current_output(Stream),
call(Goal).
/** @pred read_from_chars(+ _Chars_, - _Term_)
Parse the list of character codes _Chars_ and return the result in
the term _Term_. The character codes to be read must terminate with
a dot character such that either (i) the dot character is followed by
blank characters; or (ii) the dot character is the last character in the
string.
@compat The SWI-Prolog version does not require Codes to end
in a full-stop.
*/
read_from_chars("", end_of_file) :- !.
read_from_chars(List, Term) :-
atom_to_term(List, Term, _).
/**
@}
*/

View File

@@ -1,96 +0,0 @@
/**
* @file clauses.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 14:51:30 2015
*
* @brief Utilities for clause manipulation.
*
*
*/
:- module(clauses,
[list2conj/2,
conj2list/2,
clauselength/2]).
%% @{
/**
* @defgroup clauses Clause Manipulation
* @ingroup library
This library supports a number of useful utilities that come up over and
over again when manipulating Prolog programs. This will include
operations and conversion to other structures.
@author Vitor Santos Costa
*/
/** conj2list( +Conj, -List) is det
Generate a list from a conjunction of literals.
It is often easier to apply operations on lists than on clauses
*/
conj2list( M:Conj, List ) :-
conj2list_( Conj, M, List, [] ).
conj2list( Conj, List ) :-
conj2list_( Conj, List, [] ).
conj2list_( C ) -->
{ var(C) },
!,
[C].
conj2list_( true ) --> !.
conj2list_( (C1, C2) ) -->
!,
conj2list_( C1 ),
conj2list_( C2 ).
conj2list_( C ) -->
[C].
conj2list_( C, M ) -->
{ var(C) },
!,
[M: C].
conj2list_( true , _) --> !.
conj2list_( (C1, C2), M ) -->
!,
conj2list_( C1, M ),
conj2list_( C2, M ).
conj2list_( C, M ) -->
{ strip_module(M:C, NM, NC) },
[NM:NC].
/** list2conj( +List, -Conj) is det
Generate a conjunction from a list of literals.
Notice Mthat this relies on indexing within the list to avoid creating
choice-points.
*/
list2conj([], true).
list2conj([Last], Last).
list2conj([Head,Next|Tail], (Head,Goals)) :-
list2conj([Next|Tail], Goals).
/** clauselength( +Clause, -Length) is det
Count the number of literals in a clause (head counts as one).
Notice that this is 1+length(conj2list), as we ignore disjunctions.
*/
clauselength( (_Head :- Conj), Length ) :-
clauselength( Conj, Length, 1 ).
clauselength( C, I1, I ) :-
{ var(C) },
!,
I1 is I+1.
clauselength( (C1, C2), I2, I ) :- !,
clauselength( C1, I1, I ),
clauselength( C2, I2, I1 ).
clauselength( _C, I1, I ) :-
I1 is I+1.
%%@}

View File

@@ -1,216 +0,0 @@
/**
* @file coinduction.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>, Arvin Bansal,
*
*
* @date Tue Nov 17 14:55:02 2015
*
* @brief Co-inductive execution
*
*
*/
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: coinduction.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: coinduction support for Prolog *
* *
*************************************************************************/
% :- yap_flag(unknown,error).
% :- style_check(all).
%
% Code originally written by Arvin Bansal and Vitor Santos Costa
% Includes nice extensions from Jan Wielemaker (from the SWI version).
%
:- module(coinduction,
[ (coinductive)/1,
op(1150, fx, (coinductive))
]).
:- use_module(library(error)).
/** <module> coinduction Co-Logic Programming
@ingroup library
This simple module implements the directive coinductive/1 as described
in "Co-Logic Programming: Extending Logic Programming with Coinduction"
by Luke Somin et al. The idea behind coinduction is that a goal succeeds
if it unifies to a parent goal. This enables some interesting programs,
notably on infinite trees (cyclic terms).
~~~~
:- use_module(library(coinduction)).
:- coinductive stream/1.
stream([H|T]) :- i(H), stream(T).
% inductive
i(0).
i(s(N)) :- i(N).
?- X=[s(s(A))|X], stream(X).
X= [s(s(A))|X], stream(X).
A = 0,
X = [s(s(0)),**]
~~~~
This predicate is true for any cyclic list containing only 1-s,
regardless of the cycle-length.
@bug Programs mixing normal predicates and coinductive predicates must
be _stratified_. The theory does not apply to normal Prolog calling
coinductive predicates, calling normal Prolog predicates, etc.
Stratification is not checked or enforced in any other way and thus
left as a responsibility to the user.
@see "Co-Logic Programming: Extending Logic Programming with Coinduction"
by Luke Somin et al.
@{
*/
:- meta_predicate coinductive(:).
:- dynamic coinductive/3.
%-----------------------------------------------------
coinductive(Spec) :-
var(Spec),
!,
throw(error(instantiation_error,coinductive(Spec))).
coinductive(Module:Spec) :-
coinductive_declaration(Spec, Module, coinductive(Module:Spec)).
coinductive(Spec) :-
prolog_load_context(module, Module),
coinductive_declaration(Spec, Module, coinductive(Spec)).
coinductive_declaration(Spec, _M, G) :-
var(Spec),
!,
throw(error(instantiation_error,G)).
coinductive_declaration((A,B), M, G) :- !,
coinductive_declaration(A, M, G),
coinductive_declaration(B, M, G).
coinductive_declaration(M:Spec, _, G) :- !,
coinductive_declaration(Spec, M, G).
coinductive_declaration(Spec, M, _G) :-
valid_pi(Spec, F, N),
functor(S,F,N),
atomic_concat(['__coinductive__',F,'/',N],NF),
functor(NS,NF,N),
match_args(N,S,NS),
atomic_concat(['__stack_',M,':',F,'/',N],SF),
nb_setval(SF, _),
assert((M:S :-
b_getval(SF,L),
coinduction:in_stack(S, L, End),
(
nonvar(End)
->
true
;
End = [S|_],
M:NS)
)
),
assert(coinduction:coinductive(S,M,NS)).
valid_pi(Name/Arity, Name, Arity) :-
must_be(atom, Name),
must_be(integer, Arity).
match_args(0,_,_) :- !.
match_args(I,S1,S2) :-
arg(I,S1,A),
arg(I,S2,A),
I1 is I-1,
match_args(I1,S1,S2).
%-----------------------------------------------------
co_term_expansion((M:H :- B), _, (M:NH :- B)) :- !,
co_term_expansion((H :- B), M, (NH :- B)).
co_term_expansion((H :- B), M, (NH :- B)) :- !,
coinductive(H, M, NH), !.
co_term_expansion(H, M, NH) :-
coinductive(H, M, NH), !.
user:term_expansion(M:Cl,M:NCl ) :- !,
co_term_expansion(Cl, M, NCl).
user:term_expansion(G, NG) :-
prolog_load_context(module, Module),
co_term_expansion(G, Module, NG).
%-----------------------------------------------------
in_stack(_, V, V) :- var(V), !.
in_stack(G, [G|_], [G|_]) :- !.
in_stack(G, [_|T], End) :- in_stack(G, T, End).
writeG_val(G_var) :-
b_getval(G_var, G_val),
write(G_var), write(' ==> '), write(G_val), nl.
%-----------------------------------------------------
/**
Some examples from Coinductive Logic Programming and its Applications by Gopal Gupta et al, ICLP 97
~~~~
:- coinductive stream/1.
stream([H|T]) :- i(H), stream(T).
% inductive
i(0).
i(s(N)) :- i(N).
% Are there infinitely many "occurrences" of arg1 in arg2?
:- coinductive comember/2.
comember(X, L) :-
drop(X, L, L1),
comember(X, L1).
% Drop some prefix of arg2 upto an "occurrence" of arg1 from arg2,
% yielding arg3.
% ("Occurrence" of X = something unifiable with X.)
%:- table(drop/3). % not working; needs tabling supporting cyclic terms!
drop(H, [H| T], T).
drop(H, [_| T], T1) :-
drop(H, T, T1).
% X = [1, 2, 3| X], comember(E, X).
user:p(E) :-
X = [1, 2, 3| X],
comember(E, X),
format('~w~n',[E]),
get_code(_),
fail.
~~~~
@}
*/

View File

@@ -1,70 +0,0 @@
s/**
* @file dbqueues.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 15:01:49 2015
*
* @brief A library to support queues with no-backtrackable queues.
*
*
*/
:- module(nbqueue, [
nb_enqueue/2,
nb_dequeue/2,
nb_clean_queue/1,
nb_size/2
]).
/**
* @defgroup dbqueues Non-backtrackable queues in YAP.
* @ingroup library
A library to implement queues of NB Terms
*/
:- unhide_atom('$init_nb_queue').
:- unhide_atom('$nb_enqueue').
:- unhide_atom('$nb_dequeue').
nb_enqueue(Name,El) :- var(Name),
throw(error(instantiation_error(Name),nb_enqueue(Name,El))).
nb_enqueue(Name,El) :- \+ atom(Name), !,
throw(error(type_error_atom(Name),nb_enqueue(Name,El))).
nb_enqueue(Name,El) :-
recorded('$nb_queue',[Name|Ref],_), !,
prolog:'$nb_enqueue'(Ref, El).
nb_enqueue(Name,El) :-
prolog:'$init_nb_queue'(Ref),
recorda('$nb_queue',[Name|Ref],_),
prolog:'$nb_enqueue'(Ref,El).
nb_dequeue(Name,El) :- var(Name),
throw(error(instantiation_error(Name),nb_dequeue(Name,El))).
nb_dequeue(Name,El) :- \+ atom(Name), !,
throw(error(type_error_atom(Name),nb_dequeue(Name,El))).
nb_dequeue(Name,El) :-
recorded('$nb_queue',[Name|Ref],R),
( prolog:'$nb_dequeue'(Ref, El) ->
true
;
erase(R),
fail
).
nb_clean_queue(Name) :-
recorded('$nb_queue',[Name|Ref],R), !,
erase(R),
nb_dequeue_all(Ref).
nb_clean_queue(_).
nb_dequeue_all(Ref) :-
( prolog:'$nb_dequeue'(Ref, _) -> nb_dequeue_all(Ref) ; true ).
nb_dequeue_size(Ref, Size) :-
prolog:'$nb_size'(Ref, Size).

View File

@@ -1,208 +0,0 @@
/**
* @file dbusage.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 15:04:52 2015
*
* @brief Useful statistics on memory usage
*
*
*/
:- module(dbusage, [
db_usage/0,
db_static/0,
db_static/1,
db_dynamic/0,
db_dynamic/1
]).
/**
* @defgroup dbusage Memory Usage in Prolog Data-Base
* @ingroup library
@{
This library provides a set of utilities for studying memory usage in YAP.
The following routines are available once included with the
`use_module(library(dbusage))` command.
*/
/** @pred db_usage
Give general overview of data-base usage in the system.
*/
db_usage :-
statistics(heap,[HeapUsed,HeapFree]),
statistics(local_stack,[GInU,FreeS]),
statistics(global_stack,[SInU,_]),
statistics(trail,[TInU,FreeT]),
HeapUsedK is HeapUsed//1024,
HeapFreeK is HeapFree//1024,
StackSpace is (GInU+SInU+FreeS+TInU+FreeT)//1024,
format(user_error, 'Heap Space = ~D KB (+ ~D KB free)~n',[HeapUsedK,HeapFreeK]),
format(user_error, 'Stack Space = ~D KB~n',[StackSpace]),
findall(p(Cls,CSz,ISz),
(current_module(M),
current_predicate(_,M:P),
predicate_statistics(M:P,Cls,CSz,ISz)),LAll),
sumall(LAll, TCls, TCSz, TISz),
statistics(atoms,[AtomN,AtomS]),
AtomSK is AtomS//1024,
format(user_error, '~D Atoms taking ~D KB~n',[AtomN,AtomSK]),
TSz is TCSz+TISz,
TSzK is TSz//1024,
TCSzK is TCSz//1024,
TISzK is TISz//1024,
format(user_error, 'Total User Code~n ~D clauses taking ~D KB~n ~D KB in clauses + ~D KB in indices~n',
[TCls,TSzK,TCSzK,TISzK]),
statistics(static_code,[SCl,SI,SI1,SI2,SI3]),
SClK is SCl//1024,
SIK is SI//1024,
SI1K is SI1//1024,
SI2K is SI2//1024,
SI3K is SI3//1024,
ST is SCl+SI,
STK is ST//1024,
format(user_error, 'Total Static code=~D KB~n ~D KB in clauses + ~D KB in indices (~D+~D+~D)~n',
[STK,SClK,SIK,SI1K,SI2K,SI3K]),
statistics(dynamic_code,[DCl,DI,DI1,DI2,DI3,DI4]),
DClK is DCl//1024,
DIK is DI//1024,
DI1K is DI1//1024,
DI2K is DI2//1024,
DI3K is DI3//1024,
DI4K is DI4//1024,
DT is DCl+DI,
DTK is DT//1024,
format(user_error, 'Total Dynamic code=~D KB~n ~D KB in clauses + ~D KB in indices (~D+~D+~D+~D)~n',
[DTK,DClK,DIK,DI1K,DI2K,DI3K,DI4K]),
total_erased(DCls,DSZ,ICls,ISZ),
(DCls =:= 0 ->
true
;
DSZK is DSZ//1024,
format(user_error, ' ~D erased clauses not reclaimed (~D KB)~n',[DCls,DSZK])
),
(ICls =:= 0 ->
true
;
ISZK is ISZ//1024,
format(user_error, ' ~D erased indices not reclaimed (~D KB)~n',[ICls,ISZK])
),
!.
db_usage:-
write(mem_dump_error),nl.
/** @pred db_static
List memory usage for every static predicate.
*/
db_static :-
db_static(-1).
/** @pred db_static(+ _Threshold_)
List memory usage for every static predicate. Predicate must use more
than _Threshold_ bytes.
*/
db_static(Min) :-
setof(p(Sz,M:P,Cls,CSz,ISz),
PN^(current_module(M),
current_predicate(PN,M:P),
\+ predicate_property(M:P,dynamic),
predicate_statistics(M:P,Cls,CSz,ISz),
Sz is (CSz+ISz),
Sz > Min),All),
format(user_error,' Static user code~n===========================~n',[]),
display_preds(All).
/** @pred db_dynamic
List memory usage for every dynamic predicate.
*/
db_dynamic :-
db_dynamic(-1).
/** @pred db_dynamic(+ _Threshold_)
List memory usage for every dynamic predicate. Predicate must use more
than _Threshold_ bytes.
*/
db_dynamic(Min) :-
setof(p(Sz,M:P,Cls,CSz,ISz,ECls,ECSz,EISz),
PN^(current_module(M),
current_predicate(PN,M:P),
predicate_property(M:P,dynamic),
predicate_statistics(M:P,Cls,CSz,ISz),
predicate_erased_statistics(M:P,ECls,ECSz,EISz),
Sz is (CSz+ISz+ECSz+EISz),
Sz > Min),
All),
format(user_error,' Dynamic user code~n===========================~n',[]),
display_dpreds(All).
display_preds([]).
display_preds([p(Sz,M:P,Cls,CSz,ISz)|_]) :-
functor(P,A,N),
KSz is Sz//1024,
KCSz is CSz//1024,
KISz is ISz//1024,
(M = user -> Name = A/N ; Name = M:A/N),
format(user_error,'~w~t~36+:~t~D~7+ clauses using~|~t~D~8+ KB (~D + ~D)~n',[Name,Cls,KSz,KCSz,KISz]),
fail.
display_preds([_|All]) :-
display_preds(All).
display_dpreds([]).
display_dpreds([p(Sz,M:P,Cls,CSz,ISz,ECls,ECSz,EISz)|_]) :-
functor(P,A,N),
KSz is Sz//1024,
KCSz is CSz//1024,
KISz is ISz//1024,
(M = user -> Name = A/N ; Name = M:A/N),
format(user_error,'~w~t~36+:~t~D~7+ clauses using~|~t~D~8+ KB (~D + ~D)~n',[Name,Cls,KSz,KCSz,KISz]),
(ECls =:= 0
->
true
;
ECSzK is ECSz//1024,
format(user_error,' ~D erased clauses: ~D KB~n',[ECls,ECSzK])
),
(EISz =:= 0
->
true
;
EISzK is EISz//1024,
format(user_error,' ~D KB erased indices~n',[EISzK])
),
fail.
display_dpreds([_|All]) :-
display_dpreds(All).
sumall(LEDAll, TEDCls, TEDCSz, TEDISz) :-
sumall(LEDAll, 0, TEDCls, 0, TEDCSz, 0, TEDISz).
sumall([], TEDCls, TEDCls, TEDCSz, TEDCSz, TEDISz, TEDISz).
sumall([p(Cls,CSz,ISz)|LEDAll], TEDCls0, TEDCls, TEDCSz0, TEDCSz, TEDISz0, TEDISz) :-
TEDClsI is Cls+TEDCls0,
TEDCSzI is CSz+TEDCSz0,
TEDISzI is ISz+TEDISz0,
sumall(LEDAll, TEDClsI, TEDCls, TEDCSzI, TEDCSz, TEDISzI, TEDISz).
/**
@}
*/

View File

@@ -1,708 +0,0 @@
/**
* @file dgraphs.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 01:23:20 2015
*
* @brief Directed Graph Processing Utilities.
*
*
*/
:- module( dgraphs,
[
dgraph_vertices/2,
dgraph_edge/3,
dgraph_edges/2,
dgraph_add_vertex/3,
dgraph_add_vertices/3,
dgraph_del_vertex/3,
dgraph_del_vertices/3,
dgraph_add_edge/4,
dgraph_add_edges/3,
dgraph_del_edge/4,
dgraph_del_edges/3,
dgraph_to_ugraph/2,
ugraph_to_dgraph/2,
dgraph_neighbors/3,
dgraph_neighbours/3,
dgraph_complement/2,
dgraph_transpose/2,
dgraph_compose/3,
dgraph_transitive_closure/2,
dgraph_symmetric_closure/2,
dgraph_top_sort/2,
dgraph_top_sort/3,
dgraph_min_path/5,
dgraph_max_path/5,
dgraph_min_paths/3,
dgraph_isomorphic/4,
dgraph_path/3,
dgraph_path/4,
dgraph_leaves/2,
dgraph_reachable/3
]).
/** @defgroup dgraphs Directed Graphs
@ingroup library
@{
The following graph manipulation routines use the red-black tree library
to try to avoid linear-time scans of the graph for all graph
operations. Graphs are represented as a red-black tree, where the key is
the vertex, and the associated value is a list of vertices reachable
from that vertex through an edge (ie, a list of edges).
*/
/** @pred dgraph_new(+ _Graph_)
Create a new directed graph. This operation must be performed before
trying to use the graph.
*/
:- reexport(library(rbtrees),
[rb_new/1 as dgraph_new]).
:- use_module(library(rbtrees),
[rb_new/1,
rb_empty/1,
rb_lookup/3,
rb_apply/4,
rb_insert/4,
rb_visit/2,
rb_keys/2,
rb_delete/3,
rb_map/3,
rb_clone/3,
ord_list_to_rbtree/2]).
:- use_module(library(ordsets),
[ord_insert/3,
ord_union/3,
ord_subtract/3,
ord_del_element/3,
ord_memberchk/2]).
:- use_module(library(wdgraphs),
[dgraph_to_wdgraph/2,
wdgraph_min_path/5,
wdgraph_max_path/5,
wdgraph_min_paths/3]).
/** @pred dgraph_add_edge(+ _Graph_, + _N1_, + _N2_, - _NewGraph_)
Unify _NewGraph_ with a new graph obtained by adding the edge
_N1_- _N2_ to the graph _Graph_.
*/
dgraph_add_edge(Vs0,V1,V2,Vs2) :-
dgraph_new_edge(V1,V2,Vs0,Vs1),
dgraph_add_vertex(Vs1,V2,Vs2).
/** @pred dgraph_add_edges(+ _Graph_, + _Edges_, - _NewGraph_)
Unify _NewGraph_ with a new graph obtained by adding the list of
edges _Edges_ to the graph _Graph_.
*/
dgraph_add_edges(V0, Edges, VF) :-
rb_empty(V0), !,
sort(Edges,SortedEdges),
all_vertices_in_edges(SortedEdges,Vertices),
sort(Vertices,SortedVertices),
edges2graphl(SortedVertices, SortedEdges, GraphL),
ord_list_to_rbtree(GraphL, VF).
dgraph_add_edges(G0, Edges, GF) :-
sort(Edges,SortedEdges),
all_vertices_in_edges(SortedEdges,Vertices),
sort(Vertices,SortedVertices),
dgraph_add_edges(SortedVertices,SortedEdges, G0, GF).
all_vertices_in_edges([],[]).
all_vertices_in_edges([V1-V2|Edges],[V1,V2|Vertices]) :-
all_vertices_in_edges(Edges,Vertices).
edges2graphl([], [], []).
edges2graphl([V|Vertices], [VV-V1|SortedEdges], [V-[V1|Children]|GraphL]) :-
V == VV, !,
get_extra_children(SortedEdges,VV,Children,RemEdges),
edges2graphl(Vertices, RemEdges, GraphL).
edges2graphl([V|Vertices], SortedEdges, [V-[]|GraphL]) :-
edges2graphl(Vertices, SortedEdges, GraphL).
dgraph_add_edges([],[]) --> [].
dgraph_add_edges([V|Vs],[V0-V1|Es]) --> { V == V0 }, !,
{ get_extra_children(Es,V,Children,REs) },
dgraph_update_vertex(V,[V1|Children]),
dgraph_add_edges(Vs,REs).
dgraph_add_edges([V|Vs],Es) --> !,
dgraph_update_vertex(V,[]),
dgraph_add_edges(Vs,Es).
get_extra_children([V-C|Es],VV,[C|Children],REs) :- V == VV, !,
get_extra_children(Es,VV,Children,REs).
get_extra_children(Es,_,[],Es).
dgraph_update_vertex(V,Children, Vs0, Vs) :-
rb_apply(Vs0, V, add_edges(Children), Vs), !.
dgraph_update_vertex(V,Children, Vs0, Vs) :-
rb_insert(Vs0,V,Children,Vs).
add_edges(E0,E1,E) :-
ord_union(E0,E1,E).
dgraph_new_edge(V1,V2,Vs0,Vs) :-
rb_apply(Vs0, V1, insert_edge(V2), Vs), !.
dgraph_new_edge(V1,V2,Vs0,Vs) :-
rb_insert(Vs0,V1,[V2],Vs).
insert_edge(V2, Children0, Children) :-
ord_insert(Children0,V2,Children).
/** @pred dgraph_add_vertices(+ _Graph_, + _Vertices_, - _NewGraph_)
Unify _NewGraph_ with a new graph obtained by adding the list of
vertices _Vertices_ to the graph _Graph_.
*/
dgraph_add_vertices(G, [], G).
dgraph_add_vertices(G0, [V|Vs], GF) :-
dgraph_add_vertex(G0, V, G1),
dgraph_add_vertices(G1, Vs, GF).
/** @pred dgraph_add_vertex(+ _Graph_, + _Vertex_, - _NewGraph_)
Unify _NewGraph_ with a new graph obtained by adding
vertex _Vertex_ to the graph _Graph_.
*/
dgraph_add_vertex(Vs0, V, Vs0) :-
rb_lookup(V,_,Vs0), !.
dgraph_add_vertex(Vs0, V, Vs) :-
rb_insert(Vs0, V, [], Vs).
/** @pred dgraph_edges(+ _Graph_, - _Edges_)
Unify _Edges_ with all edges appearing in graph
_Graph_.
*/
dgraph_edges(Vs,Edges) :-
rb_visit(Vs,L0),
cvt2edges(L0,Edges).
/** @pred dgraph_vertices(+ _Graph_, - _Vertices_)
Unify _Vertices_ with all vertices appearing in graph
_Graph_.
*/
dgraph_vertices(Vs,Vertices) :-
rb_keys(Vs,Vertices).
cvt2edges([],[]).
cvt2edges([V-Children|L0],Edges) :-
children2edges(Children,V,Edges,Edges0),
cvt2edges(L0,Edges0).
children2edges([],_,Edges,Edges).
children2edges([Child|L0],V,[V-Child|EdgesF],Edges0) :-
children2edges(L0,V,EdgesF,Edges0).
/** @pred dgraph_neighbours(+ _Vertex_, + _Graph_, - _Vertices_)
Unify _Vertices_ with the list of neighbours of vertex _Vertex_
in _Graph_.
*/
dgraph_neighbours(V,Vertices,Children) :-
rb_lookup(V,Children,Vertices).
/** @pred dgraph_neighbors(+ _Vertex_, + _Graph_, - _Vertices_)
Unify _Vertices_ with the list of neighbors of vertex _Vertex_
in _Graph_. If the vertice is not in the graph fail.
*/
dgraph_neighbors(V,Vertices,Children) :-
rb_lookup(V,Children,Vertices).
add_vertices(Graph, [], Graph).
add_vertices(Graph, [V|Vertices], NewGraph) :-
rb_insert(Graph, V, [], IntGraph),
add_vertices(IntGraph, Vertices, NewGraph).
/** @pred dgraph_complement(+ _Graph_, - _NewGraph_)
Unify _NewGraph_ with the graph complementary to _Graph_.
*/
dgraph_complement(Vs0,VsF) :-
dgraph_vertices(Vs0,Vertices),
rb_map(Vs0,complement(Vertices),VsF).
complement(Vs,Children,NewChildren) :-
ord_subtract(Vs,Children,NewChildren).
/** @pred dgraph_del_edge(+ _Graph_, + _N1_, + _N2_, - _NewGraph_)
Succeeds if _NewGraph_ unifies with a new graph obtained by
removing the edge _N1_- _N2_ from the graph _Graph_. Notice
that no vertices are deleted.
*/
dgraph_del_edge(Vs0,V1,V2,Vs1) :-
rb_apply(Vs0, V1, delete_edge(V2), Vs1).
/** @pred dgraph_del_edges(+ _Graph_, + _Edges_, - _NewGraph_)
Unify _NewGraph_ with a new graph obtained by removing the list of
edges _Edges_ from the graph _Graph_. Notice that no vertices
are deleted.
*/
dgraph_del_edges(G0, Edges, Gf) :-
sort(Edges,SortedEdges),
continue_del_edges(SortedEdges, G0, Gf).
continue_del_edges([]) --> [].
continue_del_edges([V-V1|Es]) --> !,
{ get_extra_children(Es,V,Children,REs) },
contract_vertex(V,[V1|Children]),
continue_del_edges(REs).
contract_vertex(V,Children, Vs0, Vs) :-
rb_apply(Vs0, V, del_edges(Children), Vs).
del_edges(ToRemove,E0,E) :-
ord_subtract(E0,ToRemove,E).
/** @pred dgraph_del_vertex(+ _Graph_, + _Vertex_, - _NewGraph_)
Unify _NewGraph_ with a new graph obtained by deleting vertex
_Vertex_ and all the edges that start from or go to _Vertex_ to
the graph _Graph_.
*/
dgraph_del_vertex(Vs0, V, Vsf) :-
rb_delete(Vs0, V, Vs1),
rb_map(Vs1, delete_edge(V), Vsf).
delete_edge(Edges0, V, Edges) :-
ord_del_element(Edges0, V, Edges).
/** @pred dgraph_del_vertices(+ _Graph_, + _Vertices_, - _NewGraph_)
Unify _NewGraph_ with a new graph obtained by deleting the list of
vertices _Vertices_ and all the edges that start from or go to a
vertex in _Vertices_ to the graph _Graph_.
*/
dgraph_del_vertices(G0, Vs, GF) :-
sort(Vs,SortedVs),
delete_all(SortedVs, G0, G1),
delete_remaining_edges(SortedVs, G1, GF).
% it would be nice to be able to delete a set of elements from an RB tree
% but I don't how to do it yet.
delete_all([]) --> [].
delete_all([V|Vs],Vs0,Vsf) :-
rb_delete(Vs0, V, Vsi),
delete_all(Vs,Vsi,Vsf).
delete_remaining_edges(SortedVs,Vs0,Vsf) :-
rb_map(Vs0, del_edges(SortedVs), Vsf).
/** @pred dgraph_transpose(+ _Graph_, - _Transpose_)
Unify _NewGraph_ with a new graph obtained from _Graph_ by
replacing all edges of the form _V1-V2_ by edges of the form
_V2-V1_.
*/
dgraph_transpose(Graph, TGraph) :-
rb_visit(Graph, Edges),
transpose(Edges, Nodes, TEdges, []),
dgraph_new(G0),
% make sure we have all vertices, even if they are unconnected.
dgraph_add_vertices(G0, Nodes, G1),
dgraph_add_edges(G1, TEdges, TGraph).
transpose([], []) --> [].
transpose([V-Edges|MoreVs], [V|Vs]) -->
transpose_edges(Edges, V),
transpose(MoreVs, Vs).
transpose_edges([], _V) --> [].
transpose_edges(E.Edges, V) -->
[E-V],
transpose_edges(Edges, V).
dgraph_compose(T1,T2,CT) :-
rb_visit(T1,Nodes),
compose(Nodes,T2,NewNodes),
dgraph_new(CT0),
dgraph_add_edges(CT0,NewNodes,CT).
compose([],_,[]).
compose([V-Children|Nodes],T2,NewNodes) :-
compose2(Children,V,T2,NewNodes,NewNodes0),
compose(Nodes,T2,NewNodes0).
compose2([],_,_,NewNodes,NewNodes).
compose2([C|Children],V,T2,NewNodes,NewNodes0) :-
rb_lookup(C, GrandChildren, T2),
compose3(GrandChildren, V, NewNodes,NewNodesI),
compose2(Children,V,T2,NewNodesI,NewNodes0).
compose3([], _, NewNodes, NewNodes).
compose3([GC|GrandChildren], V, [V-GC|NewNodes], NewNodes0) :-
compose3(GrandChildren, V, NewNodes, NewNodes0).
/** @pred dgraph_transitive_closure(+ _Graph_, - _Closure_)
Unify _Closure_ with the transitive closure of graph _Graph_.
*/
dgraph_transitive_closure(G,Closure) :-
dgraph_edges(G,Edges),
continue_closure(Edges,G,Closure).
continue_closure([], Closure, Closure) :- !.
continue_closure(Edges, G, Closure) :-
transit_graph(Edges,G,NewEdges),
dgraph_add_edges(G, NewEdges, GN),
continue_closure(NewEdges, GN, Closure).
transit_graph([],_,[]).
transit_graph([V-V1|Edges],G,NewEdges) :-
rb_lookup(V1, GrandChildren, G),
transit_graph2(GrandChildren, V, G, NewEdges, MoreEdges),
transit_graph(Edges, G, MoreEdges).
transit_graph2([], _, _, NewEdges, NewEdges).
transit_graph2([GC|GrandChildren], V, G, NewEdges, MoreEdges) :-
is_edge(V,GC,G), !,
transit_graph2(GrandChildren, V, G, NewEdges, MoreEdges).
transit_graph2([GC|GrandChildren], V, G, [V-GC|NewEdges], MoreEdges) :-
transit_graph2(GrandChildren, V, G, NewEdges, MoreEdges).
is_edge(V1,V2,G) :-
rb_lookup(V1,Children,G),
ord_memberchk(V2, Children).
/** @pred dgraph_symmetric_closure(+ _Graph_, - _Closure_)
Unify _Closure_ with the symmetric closure of graph _Graph_,
that is, if _Closure_ contains an edge _U-V_ it must also
contain the edge _V-U_.
*/
dgraph_symmetric_closure(G,S) :-
dgraph_edges(G, Edges),
invert_edges(Edges, InvertedEdges),
dgraph_add_edges(G, InvertedEdges, S).
invert_edges([], []).
invert_edges([V1-V2|Edges], [V2-V1|InvertedEdges]) :-
invert_edges(Edges, InvertedEdges).
/** @pred dgraph_top_sort(+ _Graph_, - _Vertices_)
Unify _Vertices_ with the topological sort of graph _Graph_.
*/
dgraph_top_sort(G, Q) :-
dgraph_top_sort(G, Q, []).
/** @pred dgraph_top_sort(+ _Graph_, - _Vertices_, ? _Vertices0_)
Unify the difference list _Vertices_- _Vertices0_ with the
topological sort of graph _Graph_.
*/
dgraph_top_sort(G, Q, RQ0) :-
% O(E)
rb_visit(G, Vs),
% O(E)
invert_and_link(Vs, Links, UnsortedInvertedEdges, AllVs, Q),
% O(V)
rb_clone(G, LinkedG, Links),
% O(Elog(E))
sort(UnsortedInvertedEdges, InvertedEdges),
% O(E)
dgraph_vertices(G, AllVs),
start_queue(AllVs, InvertedEdges, Q, RQ),
continue_queue(Q, LinkedG, RQ, RQ0).
invert_and_link([], [], [], [], []).
invert_and_link([V-Vs|Edges], [V-NVs|ExtraEdges], UnsortedInvertedEdges, [V|AllVs],[_|Q]) :-
inv_links(Vs, NVs, V, UnsortedInvertedEdges, UnsortedInvertedEdges0),
invert_and_link(Edges, ExtraEdges, UnsortedInvertedEdges0, AllVs, Q).
inv_links([],[],_,UnsortedInvertedEdges,UnsortedInvertedEdges).
inv_links([V2|Vs],[l(V2,A,B,S,E)|VLnks],V1,[V2-e(A,B,S,E)|UnsortedInvertedEdges],UnsortedInvertedEdges0) :-
inv_links(Vs,VLnks,V1,UnsortedInvertedEdges,UnsortedInvertedEdges0).
dup([], []).
dup([_|AllVs], [_|Q]) :-
dup(AllVs, Q).
start_queue([], [], RQ, RQ).
start_queue([V|AllVs], [VV-e(S,B,S,E)|InvertedEdges], Q, RQ) :- V == VV, !,
link_edges(InvertedEdges, VV, B, S, E, RemainingEdges),
start_queue(AllVs, RemainingEdges, Q, RQ).
start_queue([V|AllVs], InvertedEdges, [V|Q], RQ) :-
start_queue(AllVs, InvertedEdges, Q, RQ).
link_edges([V-e(A,B,S,E)|InvertedEdges], VV, A, S, E, RemEdges) :- V == VV, !,
link_edges(InvertedEdges, VV, B, S, E, RemEdges).
link_edges(RemEdges, _, A, _, A, RemEdges).
continue_queue([], _, RQ0, RQ0).
continue_queue([V|Q], LinkedG, RQ, RQ0) :-
rb_lookup(V, Links, LinkedG),
close_links(Links, RQ, RQI),
% not clear whether I should deleted V from LinkedG
continue_queue(Q, LinkedG, RQI, RQ0).
close_links([], RQ, RQ).
close_links([l(V,A,A,S,E)|Links], RQ, RQ0) :-
( S == E -> RQ = [V| RQ1] ; RQ = RQ1),
close_links(Links, RQ1, RQ0).
/** @pred ugraph_to_dgraph( + _UGraph_, - _Graph_)
Unify _Graph_ with the directed graph obtain from _UGraph_,
represented in the form used in the _ugraphs_ unweighted graphs
library.
*/
ugraph_to_dgraph(UG, DG) :-
ord_list_to_rbtree(UG, DG).
/** @pred dgraph_to_ugraph(+ _Graph_, - _UGraph_)
Unify _UGraph_ with the representation used by the _ugraphs_
unweighted graphs library, that is, a list of the form
_V-Neighbors_, where _V_ is a node and _Neighbors_ the nodes
children.
*/
dgraph_to_ugraph(DG, UG) :-
rb_visit(DG, UG).
/** @pred dgraph_edge(+ _N1_, + _N2_, + _Graph_)
Edge _N1_- _N2_ is an edge in directed graph _Graph_.
*/
dgraph_edge(N1, N2, G) :-
rb_lookup(N1, Ns, G),
ord_memberchk(N2, Ns).
/** @pred dgraph_min_path(+ _V1_, + _V1_, + _Graph_, - _Path_, ? _Costt_)
Unify the list _Path_ with the minimal cost path between nodes
_N1_ and _N2_ in graph _Graph_. Path _Path_ has cost
_Cost_.
*/
dgraph_min_path(V1, V2, Graph, Path, Cost) :-
dgraph_to_wdgraph(Graph, WGraph),
wdgraph_min_path(V1, V2, WGraph, Path, Cost).
/** @pred dgraph_max_path(+ _V1_, + _V1_, + _Graph_, - _Path_, ? _Costt_)
Unify the list _Path_ with the maximal cost path between nodes
_N1_ and _N2_ in graph _Graph_. Path _Path_ has cost
_Cost_.
*/
dgraph_max_path(V1, V2, Graph, Path, Cost) :-
dgraph_to_wdgraph(Graph, WGraph),
wdgraph_max_path(V1, V2, WGraph, Path, Cost).
/** @pred dgraph_min_paths(+ _V1_, + _Graph_, - _Paths_)
Unify the list _Paths_ with the minimal cost paths from node
_N1_ to the nodes in graph _Graph_.
*/
dgraph_min_paths(V1, Graph, Paths) :-
dgraph_to_wdgraph(Graph, WGraph),
wdgraph_min_paths(V1, WGraph, Paths).
/** @pred dgraph_path(+ _Vertex_, + _Vertex1_, + _Graph_, ? _Path_)
The path _Path_ is a path starting at vertex _Vertex_ in graph
_Graph_ and ending at path _Vertex2_.
*/
dgraph_path(V1, V2, Graph, Path) :-
rb_new(E0),
rb_lookup(V1, Children, Graph),
dgraph_path_children(Children, V2, E0, Graph, Path).
dgraph_path_children([V1|_], V2, _E1, _Graph, []) :- V1 == V2.
dgraph_path_children([V1|_], V2, E1, Graph, [V1|Path]) :-
V2 \== V1,
\+ rb_lookup(V1, _, E0),
rb_insert(E0, V2, [], E1),
rb_lookup(V1, Children, Graph),
dgraph_path_children(Children, V2, E1, Graph, Path).
dgraph_path_children([_|Children], V2, E1, Graph, Path) :-
dgraph_path_children(Children, V2, E1, Graph, Path).
do_path([], _, _, []).
do_path([C|Children], G, SoFar, Path) :-
do_children([C|Children], G, SoFar, Path).
do_children([V|_], G, SoFar, [V|Path]) :-
rb_lookup(V, Children, G),
ord_subtract(Children, SoFar, Ch),
ord_insert(SoFar, V, NextSoFar),
do_path(Ch, G, NextSoFar, Path).
do_children([_|Children], G, SoFar, Path) :-
do_children(Children, G, SoFar, Path).
/** @pred dgraph_path(+ _Vertex_, + _Graph_, ? _Path_)
The path _Path_ is a path starting at vertex _Vertex_ in graph
_Graph_.
*/
dgraph_path(V, G, [V|P]) :-
rb_lookup(V, Children, G),
ord_del_element(Children, V, Ch),
do_path(Ch, G, [V], P).
/** @pred dgraph_isomorphic(+ _Vs_, + _NewVs_, + _G0_, - _GF_)
Unify the list _GF_ with the graph isomorphic to _G0_ where
vertices in _Vs_ map to vertices in _NewVs_.
*/
dgraph_isomorphic(Vs, Vs2, G1, G2) :-
rb_new(Map0),
mapping(Vs,Vs2,Map0,Map),
dgraph_edges(G1,Edges),
translate_edges(Edges,Map,TEdges),
dgraph_new(G20),
dgraph_add_vertices(Vs2,G20,G21),
dgraph_add_edges(G21,TEdges,G2).
mapping([],[],Map,Map).
mapping([V1|Vs],[V2|Vs2],Map0,Map) :-
rb_insert(Map0,V1,V2,MapI),
mapping(Vs,Vs2,MapI,Map).
translate_edges([],_,[]).
translate_edges([V1-V2|Edges],Map,[NV1-NV2|TEdges]) :-
rb_lookup(V1,NV1,Map),
rb_lookup(V2,NV2,Map),
translate_edges(Edges,Map,TEdges).
/** @pred dgraph_reachable(+ _Vertex_, + _Graph_, ? _Edges_)
The path _Path_ is a path starting at vertex _Vertex_ in graph
_Graph_.
*/
dgraph_reachable(V, G, Edges) :-
rb_lookup(V, Children, G),
ord_list_to_rbtree([V-[]],Done0),
reachable(Children, Done0, _, G, Edges, []).
reachable([], Done, Done, _, Edges, Edges).
reachable([V|Vertices], Done0, DoneF, G, EdgesF, Edges0) :-
rb_lookup(V,_, Done0), !,
reachable(Vertices, Done0, DoneF, G, EdgesF, Edges0).
reachable([V|Vertices], Done0, DoneF, G, [V|EdgesF], Edges0) :-
rb_lookup(V, Kids, G),
rb_insert(Done0, V, [], Done1),
reachable(Kids, Done1, DoneI, G, EdgesF, EdgesI),
reachable(Vertices, DoneI, DoneF, G, EdgesI, Edges0).
/** @pred dgraph_leaves(+ _Graph_, ? _Vertices_)
The vertices _Vertices_ have no outgoing edge in graph
_Graph_.
*/
dgraph_leaves(Graph, Vertices) :-
rb_visit(Graph, Pairs),
vertices_without_children(Pairs, Vertices).
vertices_without_children([], []).
vertices_without_children((V-[]).Pairs, V.Vertices) :-
vertices_without_children(Pairs, Vertices).
vertices_without_children(_V-[_|_].Pairs, Vertices) :-
vertices_without_children(Pairs, Vertices).
%% @}/** @} */

View File

@@ -1,242 +0,0 @@
/**
* @file exo_interval.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date 2013
*
* @brief This file implements a very simple interval solver
* designed to interact with the exo
* data-base.
* It assumes simple queries and a contiguous interval,
* and does not really expect to do non-trivial
* constraint propagation and solving.
*
*
*/
:- module(exo_interval,
[max/2,
min/2,
any/2,
max/1,
min/1,
maximum/1,
minimum/1,
any/1,
(#<)/2,
(#>)/2,
(#=<)/2,
(#>=)/2,
(#=)/2,
op(700, xfx, (#>)),
op(700, xfx, (#<)),
op(700, xfx, (#>=)),
op(700, xfx, (#=<)),
op(700, xfx, (#=))]).
/**
@defgroup exo_interval Exo Intervals
@ingroup library
@{
This package assumes you use exo-compilation, that is, that you loaded
the pedicate using the `exo` option to load_files/2, In this
case, YAP includes a package for improved search on intervals of
integers.
The package is activated by `udi` declarations that state what is
the argument of interest:
~~~~~{.prolog}
:- udi(diagnoses(exo_interval,?,?)).
:- load_files(db, [consult(exo)]).
~~~~~
It is designed to optimise the following type of queries:
~~~~~{.prolog}
?- max(X, diagnoses(X, 9, Y), X).
?- min(X, diagnoses(X, 9, 36211117), X).
?- X #< Y, min(X, diagnoses(X, 9, 36211117), X ), diagnoses(Y, 9, _).
~~~~~
The first argument gives the time, the second the patient, and the
third the condition code. The first query should find the last time
the patient 9 had any code reported, the second looks for the first
report of code 36211117, and the last searches for reports after this
one. All queries run in constant or log(n) time.
*/
/** @pred max( _X_, _Vs_)
First Argument is the greatest element of a list.
+ lex_order( _Vs_)
All elements must be ordered.
The following predicates control search:
*/
/** @pred max(+ _Expression_)
Maximizes _Expression_ within the current constraint store. This is
the same as computing the supremum and equating the expression to that
supremum.
*/
/** @pred min( _X_, _Vs_)
First Argument is the least element of a list.
*/
/** @pred min(+ _Expression_)
Minimizes _Expression_ within the current constraint store. This is
the same as computing the infimum and equation the expression to that
infimum.
*/
:- meta_predicate max(?,0), min(?,0), any(?,0).
max(X, G) :-
insert_atts(X, i(_,_,max)),
call(G).
min(X, G) :-
insert_atts(X, i(_,_,min)),
call(G).
max(X) :-
insert_atts(X, i(_,_,max)).
maximum(X) :-
insert_atts(X, i(_,_,maximum)).
any(X) :-
insert_atts(X, i(_,_,any)).
min(X) :-
insert_atts(X, i(_,_,min)).
minimum(X) :-
insert_atts(X, i(_,_,minimum)).
least(X) :-
insert_atts(X, i(_,_,least)).
X #> Y :-
( var(X) -> insert_atts(X, i(Y,_,_))
;
( var(Y) -> insert_atts(Y, i(_,X,_) ) ;
true
)
;
var(Y) -> insert_atts(Y, i(_,X,_))
;
X > Y
).
X #>= Y :-
( var(X) -> insert_atts(X, i(Y-1,_,_))
;
X >= Y
).
X #< Y :-
( var(X) -> insert_atts(X, i(_,Y,_))
;
X < Y
).
X #=< Y :-
( var(X) -> insert_atts(X, i(Y+1,_,_))
;
X =< Y
).
X #= Y :-
( var(X) -> insert_atts(X, i(Y-1,Y+1,_)) ;
X =:= Y
).
attribute_goals(X) -->
{ get_attr(X, exo_interval, Op) },
( { Op = max } -> [max(X)] ;
{ Op = min } -> [min(X)] ;
{ Op = '>'(Y) } -> [X #> Y] ;
{ Op = '<'(Y) } -> [X #< Y] ;
{ Op = range(A,B,C) } ->
range_min(A,X),
range_max(B,X),
range_op(C, X)
).
range_min(Y, _X) -->
{ var(Y) }, !,
[].
range_min(Y, X) -->
[X #> Y].
range_max(Y, _X) -->
{ var(Y) }, !,
[].
range_max(Y, X) -->
[X #< Y].
range_op(Y, _X) -->
{ var(Y) }, !,
[].
range_op(Y, X) -->
{ Op =.. [Y, X] },
[Op].
insert_atts(V, Att) :-
( nonvar(V) ->
throw( error(uninstantion_error(V), exo_interval) )
; attvar(V) ->
get_attr(V, exo_interval, Att0),
expand_atts(Att, Att0, NAtt)
;
NAtt = Att
),
put_attr(V, exo_interval, NAtt).
expand_atts(i(A1, B1, C1), i(A2, B2, C2), i(A3,B3,C3)) :-
expand_min(A1, A2, A3),
expand_max(B1, B2, B3),
expand_op(C1, C2, C3).
expand_min(A1, A2, A3) :-
(var(A1) -> A3 = A2;
var(A2) -> A3 = A1;
ground(A1), ground(A2) -> A3 is max(A1,A2) ;
A3 = max(A1,A2)
).
expand_max(A1, A2, A3) :-
(var(A1) -> A3 = A2;
var(A2) -> A3 = A1;
ground(A1), ground(A2) -> A3 is min(A1,A2) ;
A3 = min(A1,A2)
).
expand_op(A1, A2, A3) :-
(var(A1) -> A3 = A2;
var(A2) -> A3 = A1;
A1 == A2 -> A3 = A1;
A1 == unique -> A3 = unique;
A2 == unique -> A3 = unique;
A2 == min, A1 = max -> A3 = unique;
A1 == min, A2 = max -> A3 = unique;
A1 == min -> A3 = min; A2 == min -> A3 = min;
A1 == max -> A3 = max; A2 == max -> A3 = max;
A3 = any
).
%% @}

View File

@@ -1,165 +0,0 @@
/**
* @file expand_macros.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 15:16:12 2015
*
* @brief utilities that perform macro expansion for maplist/2 and
* friends.
*
*
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%
%% preprocessing for meta-calls
%%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module( expand_macros,
[compile_aux/2,
pred_name/4,
transformation_id/1,
allowed_expansion/1,
allowed_module/2] ).
:- use_module(library(lists), [append/3]).
:- use_module(library(charsio), [format_to_chars/3, read_from_chars/2]).
:- use_module(library(error), [must_be/2]).
:- use_module(library(occurs), [sub_term/2]).
:- multifile allowed_module/2.
:- dynamic number_of_expansions/1.
number_of_expansions(0).
%%%%%%%%%%%%%%%%%%%%
% utilities
%%%%%%%%%%%%%%%%%%%%
compile_aux([Clause|Clauses], Module) :-
% compile the predicate declaration if needed
(
Clause = (Head :- _)
;
Clause = Head
),
!,
functor(Head, F, N),
( current_predicate(Module:F/N)
->
true
;
% format'*** Creating auxiliary predicate ~q~n', [F/N]),
% checklist(portray_clause, [Clause|Clauses]),
compile_term([Clause|Clauses], Module)
).
compile_term([], _).
compile_term([Clause|Clauses], Module) :-
assert_static(Module:Clause),
compile_term(Clauses, Module).
append_args(Term, Args, NewTerm) :-
Term =.. [Meta|OldArgs],
append(OldArgs, Args, GoalArgs),
NewTerm =.. [Meta|GoalArgs].
aux_preds(Module:Meta, MetaVars, Pred, PredVars, Proto, _, OModule) :- !,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Module, OModule).
aux_preds(Meta, MetaVars, Pred, PredVars, Proto, Module, Module) :-
Meta =.. [F|Args],
aux_args(Args, MetaVars, PredArgs, PredVars, ProtoArgs),
Pred =.. [F|PredArgs],
Proto =.. [F|ProtoArgs].
aux_args([], [], [], [], []).
aux_args([Arg|Args], MVars, [Arg|PArgs], PVars, [Arg|ProtoArgs]) :-
ground(Arg), !,
aux_args(Args, MVars, PArgs, PVars, ProtoArgs).
aux_args([Arg|Args], [Arg|MVars], [PVar|PArgs], [PVar|PVars], ['_'|ProtoArgs]) :-
aux_args(Args, MVars, PArgs, PVars, ProtoArgs).
pred_name(Macro, Arity, _ , Name) :-
transformation_id(Id),
atomic_concat(['$$$__Auxiliary_predicate__ for',Macro,'/',Arity,' ',Id], Name).
transformation_id(Id) :-
retract(number_of_expansions(Id)),
Id1 is Id+1,
assert(number_of_expansions(Id1)).
harmless_dcgexception(instantiation_error). % ex: phrase(([1],x:X,[3]),L)
harmless_dcgexception(type_error(callable,_)). % ex: phrase(27,L)
allowed_expansion(QExpand) :-
strip_module(QExpand, Mod, Pred),
goal_expansion_allowed(Pred, Mod).
goal_expansion_allowed(Pred, Mod) :-
allowed_module(Pred,Mod),
once( prolog_load_context(_, _) ), % make sure we are compiling.
allowed_module(checklist(_,_),expand_macros).
allowed_module(checklist(_,_),apply_macros).
allowed_module(checklist(_,_),maplist).
allowed_module(maplist(_,_),expand_macros).
allowed_module(maplist(_,_),apply_macros).
allowed_module(maplist(_,_),maplist).
allowed_module(maplist(_,_,_),expand_macros).
allowed_module(maplist(_,_,_),apply_macros).
allowed_module(maplist(_,_,_),maplist).
allowed_module(maplist(_,_,_,_),expand_macros).
allowed_module(maplist(_,_,_,_),apply_macros).
allowed_module(maplist(_,_,_,_),maplist).
allowed_module(maplist(_,_,_,_,_),expand_macros).
allowed_module(maplist(_,_,_,_,_),apply_macros).
allowed_module(maplist(_,_,_,_,_),maplist).
allowed_module(maplist(_,_,_,_,_,_),expand_macros).
allowed_module(maplist(_,_,_,_,_,_),apply_macros).
allowed_module(maplist(_,_,_,_,_,_),maplist).
allowed_module(selectlist(_,_,_),expand_macros).
allowed_module(selectlist(_,_,_),apply_macros).
allowed_module(selectlist(_,_,_),maplist).
allowed_module(include(_,_,_),expand_macros).
allowed_module(include(_,_,_),apply_macros).
allowed_module(include(_,_,_),maplist).
allowed_module(exclude(_,_,_),expand_macros).
allowed_module(exclude(_,_,_),apply_macros).
allowed_module(exclude(_,_,_),maplist).
allowed_module(partition(_,_,_,_),expand_macros).
allowed_module(partition(_,_,_,_),apply_macros).
allowed_module(partition(_,_,_,_),maplist).
allowed_module(partition(_,_,_,_,_),expand_macros).
allowed_module(partition(_,_,_,_,_),apply_macros).
allowed_module(partition(_,_,_,_,_),maplist).
allowed_module(convlist(_,_,_),expand_macros).
allowed_module(convlist(_,_,_),apply_macros).
allowed_module(convlist(_,_,_),maplist).
allowed_module(sumlist(_,_,_,_),expand_macros).
allowed_module(sumlist(_,_,_,_),apply_macros).
allowed_module(sumlist(_,_,_,_),maplist).
allowed_module(mapargs(_,_,_),expand_macros).
allowed_module(mapargs(_,_,_),apply_macros).
allowed_module(mapargs(_,_,_),maplist).
allowed_module(sumargs(_,_,_,_),expand_macros).
allowed_module(sumargs(_,_,_,_),apply_macros).
allowed_module(sumargs(_,_,_,_),maplist).
allowed_module(mapnodes(_,_,_),expand_macros).
allowed_module(mapnodes(_,_,_),apply_macros).
allowed_module(mapnodes(_,_,_),maplist).
allowed_module(checknodes(_,_),expand_macros).
allowed_module(checknodes(_,_),apply_macros).
allowed_module(checknodes(_,_),maplist).
allowed_module(sumnodes(_,_,_,_),expand_macros).
allowed_module(sumnodes(_,_,_,_),apply_macros).
allowed_module(sumnodes(_,_,_,_),maplist).

View File

@@ -1,589 +0,0 @@
%%% -*- Mode: Prolog; -*-
/**
* @file library/flags.yap
* @author Theofrastos Mantadelis, Bernd Gutmann, Paulo Moura
* @date Tue Nov 17 15:18:02 2015
*
* @brief Flag Manipulation in Prolog
*
*
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Flags was developed at Katholieke Universiteit Leuven
%
% Copyright 2010
% Katholieke Universiteit Leuven
%
% Contributions to this file:
% Author: Theofrastos Mantadelis
% Sugestions: Bernd Gutmann, Paulo Moura
% $Date: 2011-02-15 13:33:01 +0100 (Tue, 15 Feb 2011) $
% $Revision: 15 $
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Artistic License 2.0
%
% Copyright (c) 2000-2006, The Perl Foundation.
%
% Everyone is permitted to copy and distribute verbatim copies of this
% license document, but changing it is not allowed. Preamble
%
% This license establishes the terms under which a given free software
% Package may be copied, modified, distributed, and/or
% redistributed. The intent is that the Copyright Holder maintains some
% artistic control over the development of that Package while still
% keeping the Package available as open source and free software.
%
% You are always permitted to make arrangements wholly outside of this
% license directly with the Copyright Holder of a given Package. If the
% terms of this license do not permit the full use that you propose to
% make of the Package, you should contact the Copyright Holder and seek
% a different licensing arrangement. Definitions
%
% "Copyright Holder" means the individual(s) or organization(s) named in
% the copyright notice for the entire Package.
%
% "Contributor" means any party that has contributed code or other
% material to the Package, in accordance with the Copyright Holder's
% procedures.
%
% "You" and "your" means any person who would like to copy, distribute,
% or modify the Package.
%
% "Package" means the collection of files distributed by the Copyright
% Holder, and derivatives of that collection and/or of those files. A
% given Package may consist of either the Standard Version, or a
% Modified Version.
%
% "Distribute" means providing a copy of the Package or making it
% accessible to anyone else, or in the case of a company or
% organization, to others outside of your company or organization.
%
% "Distributor Fee" means any fee that you charge for Distributing this
% Package or providing support for this Package to another party. It
% does not mean licensing fees.
%
% "Standard Version" refers to the Package if it has not been modified,
% or has been modified only in ways explicitly requested by the
% Copyright Holder.
%
% "Modified Version" means the Package, if it has been changed, and such
% changes were not explicitly requested by the Copyright Holder.
%
% "Original License" means this Artistic License as Distributed with the
% Standard Version of the Package, in its current version or as it may
% be modified by The Perl Foundation in the future.
%
% "Source" form means the source code, documentation source, and
% configuration files for the Package.
%
% "Compiled" form means the compiled bytecode, object code, binary, or
% any other form resulting from mechanical transformation or translation
% of the Source form.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Permission for Use and Modification Without Distribution
%
% (1) You are permitted to use the Standard Version and create and use
% Modified Versions for any purpose without restriction, provided that
% you do not Distribute the Modified Version.
%
% Permissions for Redistribution of the Standard Version
%
% (2) You may Distribute verbatim copies of the Source form of the
% Standard Version of this Package in any medium without restriction,
% either gratis or for a Distributor Fee, provided that you duplicate
% all of the original copyright notices and associated disclaimers. At
% your discretion, such verbatim copies may or may not include a
% Compiled form of the Package.
%
% (3) You may apply any bug fixes, portability changes, and other
% modifications made available from the Copyright Holder. The resulting
% Package will still be considered the Standard Version, and as such
% will be subject to the Original License.
%
% Distribution of Modified Versions of the Package as Source
%
% (4) You may Distribute your Modified Version as Source (either gratis
% or for a Distributor Fee, and with or without a Compiled form of the
% Modified Version) provided that you clearly document how it differs
% from the Standard Version, including, but not limited to, documenting
% any non-standard features, executables, or modules, and provided that
% you do at least ONE of the following:
%
% (a) make the Modified Version available to the Copyright Holder of the
% Standard Version, under the Original License, so that the Copyright
% Holder may include your modifications in the Standard Version. (b)
% ensure that installation of your Modified Version does not prevent the
% user installing or running the Standard Version. In addition, the
% modified Version must bear a name that is different from the name of
% the Standard Version. (c) allow anyone who receives a copy of the
% Modified Version to make the Source form of the Modified Version
% available to others under (i) the Original License or (ii) a license
% that permits the licensee to freely copy, modify and redistribute the
% Modified Version using the same licensing terms that apply to the copy
% that the licensee received, and requires that the Source form of the
% Modified Version, and of any works derived from it, be made freely
% available in that license fees are prohibited but Distributor Fees are
% allowed.
%
% Distribution of Compiled Forms of the Standard Version or
% Modified Versions without the Source
%
% (5) You may Distribute Compiled forms of the Standard Version without
% the Source, provided that you include complete instructions on how to
% get the Source of the Standard Version. Such instructions must be
% valid at the time of your distribution. If these instructions, at any
% time while you are carrying out such distribution, become invalid, you
% must provide new instructions on demand or cease further
% distribution. If you provide valid instructions or cease distribution
% within thirty days after you become aware that the instructions are
% invalid, then you do not forfeit any of your rights under this
% license.
%
% (6) You may Distribute a Modified Version in Compiled form without the
% Source, provided that you comply with Section 4 with respect to the
% Source of the Modified Version.
%
% Aggregating or Linking the Package
%
% (7) You may aggregate the Package (either the Standard Version or
% Modified Version) with other packages and Distribute the resulting
% aggregation provided that you do not charge a licensing fee for the
% Package. Distributor Fees are permitted, and licensing fees for other
% components in the aggregation are permitted. The terms of this license
% apply to the use and Distribution of the Standard or Modified Versions
% as included in the aggregation.
%
% (8) You are permitted to link Modified and Standard Versions with
% other works, to embed the Package in a larger work of your own, or to
% build stand-alone binary or bytecode versions of applications that
% include the Package, and Distribute the result without restriction,
% provided the result does not expose a direct interface to the Package.
%
% Items That are Not Considered Part of a Modified Version
%
% (9) Works (including, but not limited to, modules and scripts) that
% merely extend or make use of the Package, do not, by themselves, cause
% the Package to be a Modified Version. In addition, such works are not
% considered parts of the Package itself, and are not subject to the
% terms of this license.
%
% General Provisions
%
% (10) Any use, modification, and distribution of the Standard or
% Modified Versions is governed by this Artistic License. By using,
% modifying or distributing the Package, you accept this license. Do not
% use, modify, or distribute the Package, if you do not accept this
% license.
%
% (11) If your Modified Version has been derived from a Modified Version
% made by someone other than you, you are nevertheless required to
% ensure that your Modified Version complies with the requirements of
% this license.
%
% (12) This license does not grant you the right to use any trademark,
% service mark, tradename, or logo of the Copyright Holder.
%
% (13) This license includes the non-exclusive, worldwide,
% free-of-charge patent license to make, have made, use, offer to sell,
% sell, import and otherwise transfer the Package with respect to any
% patent claims licensable by the Copyright Holder that are necessarily
% infringed by the Package. If you institute patent litigation
% (including a cross-claim or counterclaim) against any party alleging
% that the Package constitutes direct or contributory patent
% infringement, then this Artistic License to you shall terminate on the
% date that such litigation is filed.
%
% (14) Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT
% HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED
% WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A
% PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT
% PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT
% HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT,
% INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE
% OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- module(flags, [flag_define/2,
flag_define/5,
flag_define/7,
flag_set/2,
flag_set/3,
flag_unsafe_set/2,
flag_get/2,
flags_reset/0,
flags_reset/1,
flags_save/1,
flags_load/1,
flag_groups/1,
flag_group_chk/1,
flag_help/0,
flags_print/0,
defined_flag/7]).
/**
* @defgroup flags Flag Manipulation in Prolog
* @ingroup library
*
* Routines to manipulate flags: they allow defining, set,
* resetting.
* @{
*/
:- use_module(library(lists), [append/3, memberchk/2, member/2]).
:- style_check(all).
:- yap_flag(unknown, error).
:- dynamic(['$defined_flag$'/7, '$store_flag_value$'/2]).
:- meta_predicate(flag_define(+, +, +, ?, ?, ?, :)).
:- meta_predicate(flag_define(+, :)).
:- meta_predicate(validate(+, :, ?, +)).
:- multifile(flags_type_definition/3).
flag_define(FlagName, InputOptions):-
strip_module(InputOptions, Module, UserOptions),
Defaults = [flag_group(general), flag_type(nonvar), default_value(true), description(FlagName), access(read_write), handler(true)],
append(UserOptions, Defaults, Options),
memberchk(flag_group(FlagGroup), Options),
memberchk(flag_type(FlagType), Options),
memberchk(default_value(DefaultValue), Options),
memberchk(description(Description), Options),
memberchk(access(Access), Options),
memberchk(handler(Handler), Options),
flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler).
flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description):-
flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, read_write, true).
flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, MHandler):-
strip_module(MHandler, Module, Handler),
nonvar(FlagName),
nonvar(FlagGroup),
nonvar(FlagType),
nonvar(Access),
nonvar(Handler), !,
(\+ atom(FlagName) ->
throw(error(type_error(atom, FlagName), message('Flag name needs to be an atom.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler))))
; \+ atom(FlagGroup) ->
throw(error(type_error(atom, FlagGroup), message('Flag group needs to be an atom.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler))))
; \+ flag_type(FlagType) ->
throw(error(domain_error(flag_type, FlagType), message('Unknown flag type.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Module:Handler))))
; \+ validate_type(FlagType) ->
throw(error(evaluation_error(type_validation), message('Validation of flag type failed, check custom domain.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler))))
; '$defined_flag$'(FlagName, _FlagGroup, _FlagType, _DefaultValue, _Description, _Access, _Handler) ->
throw(error(permission_error(create, flag, FlagName), message('Re-defining a flag is not allowed.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler))))
; \+ memberchk(Access, [read_write, read_only, hidden, hidden_read_only]),
throw(error(domain_error(access, Access), message('Wrong access attribute, available are: read_write, read_only, hidden, hidden_read_only.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler))))
; \+ callable(Handler) -> % the Handler comes from: strip_module(MHandler, Module, Handler)
throw(error(type_error(callable, Handler), message('Flag handler needs to be callable.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler))))
;
validate(FlagType, Module:Handler, DefaultValue, FlagName),
assertz('$defined_flag$'(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Module:Handler)),
assertz('$store_flag_value$'(FlagName, DefaultValue)),
(Handler == true ->
true
;
call(Module:Handler, stored, DefaultValue)
)
).
flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler):-
throw(error(instantiation_error, message('Flag name, group, type, access and handler need to be instantiated.', flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler)))).
flag_groups(FlagGroups):-
all(FlagGroup, ('$defined_flag$'(_FlagName, FlagGroup, _FlagType, _DefaultValue, _Description, Access, _Handler), Access \== hidden, Access \== hidden_read_only), FlagGroups).
flag_group_chk(FlagGroup):-
nonvar(FlagGroup),
'$defined_flag$'(_FlagName, FlagGroup, _FlagType, _DefaultValue, _Description, _Access, _Handler), !.
flag_type(Type):-
flags_type_definition(Type, _, _).
% flags_type_definition(TypeName, TypeHandler, TypeValidator).
flags_type_definition(nonvar, nonvar, true).
flags_type_definition(atom, atom, true).
flags_type_definition(atomic, atomic, true).
flags_type_definition(integer, integer, true).
flags_type_definition(float, float, true).
flags_type_definition(number, number, true).
flags_type_definition(ground, ground, true).
flags_type_definition(compound, compound, true).
flags_type_definition(is_list, is_list, true).
flags_type_definition(callable, callable, true).
flags_type_definition(in_interval(Type, Interval), in_interval(Type, Interval), in_interval(Type, Interval)).
flags_type_definition(integer_in_interval(Interval), in_interval(integer, Interval), in_interval(integer, Interval)).
flags_type_definition(positive_integer, in_interval(integer, (0, (+inf))), true).
flags_type_definition(non_negative_integer, in_interval(integer, ([0], (+inf))), true).
flags_type_definition(negative_integer, in_interval(integer, ((-inf), 0)), true).
flags_type_definition(float_in_interval(Interval), in_interval(float, Interval), in_interval(float, Interval)).
flags_type_definition(positive_float, in_interval(float, (0.0, (+inf))), true).
flags_type_definition(non_negative_float, in_interval(float, ([0.0], (+inf))), true).
flags_type_definition(negative_float, in_interval(float, ((-inf), 0.0)), true).
flags_type_definition(number_in_interval(Interval), in_interval(number, Interval), in_interval(number, Interval)).
flags_type_definition(positive_number, in_interval(number, (0.0, (+inf))), true).
flags_type_definition(non_negative_number, in_interval(number, ([0.0], (+inf))), true).
flags_type_definition(negative_number, in_interval(number, ((-inf), 0.0)), true).
flags_type_definition(in_domain(Domain), in_domain(Domain), in_domain(Domain)).
flags_type_definition(boolean, in_domain([true, false]), true).
flags_type_definition(switch, in_domain([on, off]), true).
in_domain(Domain):-
ground(Domain),
is_list(Domain).
in_domain(Domain, Value):-
ground(Value),
memberchk(Value, Domain).
in_interval(Type, Interval):-
is_list(Interval), !,
Interval \== [],
in_interval_conj(Type, Interval).
in_interval(Type, Interval):-
in_interval_single(Type, Interval).
in_interval_conj(_Type, []).
in_interval_conj(Type, [Interval|Rest]):-
in_interval_single(Type, Interval),
in_interval_conj(Type, Rest).
in_interval_single(Type, ([Min], [Max])):-
!, call(Type, Min),
call(Type, Max),
Min =< Max.
in_interval_single(Type, ([Min], Max)):-
!, call(Type, Min),
type_or_inf(Type, Max),
Min < Max.
in_interval_single(Type, (Min, [Max])):-
!, type_or_inf(Type, Min),
call(Type, Max),
Min < Max.
in_interval_single(Type, (Min, Max)):-
type_or_inf(Type, Min),
type_or_inf(Type, Max),
Min < Max,
Max - Min > 0.0.
type_or_inf(Type, Value):-
nonvar(Type), nonvar(Value),
Value == (+inf), !.
type_or_inf(Type, Value):-
nonvar(Type), nonvar(Value),
Value == (-inf), !.
type_or_inf(Type, Value):- call(Type, Value).
in_interval(Type, [Interval|_Rest], Value):-
in_interval(Type, Interval, Value), !.
in_interval(Type, [_Interval|Rest], Value):-
in_interval(Type, Rest, Value).
in_interval(Type, ([Min], [Max]), Value):-
!, call(Type, Value),
Value >= Min,
Value =< Max.
in_interval(Type, ([Min], Max), Value):-
!, call(Type, Value),
Value >= Min,
Value < Max.
in_interval(Type, (Min, [Max]), Value):-
!, call(Type, Value),
Value > Min,
Value =< Max.
in_interval(Type, (Min, Max), Value):-
call(Type, Value),
Value > Min,
Value < Max.
validate_type(Type):-
flags_type_definition(Type, _, TypeValidater),
call(TypeValidater).
validate(FlagType, Handler, Value, FlagName):-
strip_module(Handler, _Module, true),
!, flags_type_definition(FlagType, FlagValidator, _),
(call(FlagValidator, Value) ->
true
;
throw(error(validation_error(FlagType, Value), message('Validation of value fails.', validate(FlagType, Value, FlagName))))
).
validate(FlagType, Handler, Value, FlagName):-
flags_type_definition(FlagType, FlagValidator, _),
((call(Handler, validating, Value), (call(FlagValidator, Value); call(Handler, validate, Value))) ->
call(Handler, validated, Value)
;
throw(error(validation_error(FlagType, Value), message('Validation of value fails.', validate(FlagType, Handler, Value, FlagName))))
).
flag_set(FlagName, FlagValue):-
flag_set(FlagName, _OldValue, FlagValue).
flag_set(FlagName, OldValue, FlagValue):-
atom(FlagName),
'$defined_flag$'(FlagName, _FlagGroup, FlagType, _DefaultValue, _Description, Access, Module:Handler), !,
(Access \== read_only, Access \== hidden_read_only ->
validate(FlagType, Module:Handler, FlagValue, FlagName),
retract('$store_flag_value$'(FlagName, OldValue)),
assertz('$store_flag_value$'(FlagName, FlagValue)),
(Handler == true ->
true
;
call(Module:Handler, stored, FlagValue)
)
;
throw(error(permission_error(set, flag, FlagName), message('Setting the flag value is not allowed.',flag_set(FlagName, OldValue, FlagValue))))
).
flag_set(FlagName, OldValue, FlagValue):-
throw(error(existence_error(flag, FlagName), message('The flag is not defined.', flag_set(FlagName, OldValue, FlagValue)))).
flag_unsafe_set(FlagName, FlagValue):-
retract('$store_flag_value$'(FlagName, _)),
assertz('$store_flag_value$'(FlagName, FlagValue)).
flag_get(FlagName, FlagValue):-
\+ '$store_flag_value$'(FlagName, _),
throw(error(existence_error(flag, FlagName), message('The flag is not defined.', flag_get(FlagName, FlagValue)))).
flag_get(FlagName, FlagValue):-
'$store_flag_value$'(FlagName, FlagValue).
flags_reset:-
retractall('$store_flag_value$'(_, _)),
'$defined_flag$'(FlagName, _FlagGroup, _FlagType, DefaultValue, _Description, _Access, Module:Handler),
assertz('$store_flag_value$'(FlagName, DefaultValue)),
(Handler == true ->
true
;
call(Module:Handler, stored, DefaultValue)
),
fail.
flags_reset.
flags_reset(FlagGroup):-
'$defined_flag$'(FlagName, FlagGroup, _FlagType, DefaultValue, _Description, _Access, Module:Handler),
retractall('$store_flag_value$'(FlagName, _)),
assertz('$store_flag_value$'(FlagName, DefaultValue)),
(Handler == true ->
true
;
call(Module:Handler, stored, DefaultValue)
),
fail.
flags_reset(_).
flags_save(FileName):-
tell(FileName),
catch(('$store_flag_value$'(FlagName, Value),
write_canonical('$store_flag_value$'(FlagName, Value)),
write('.'), nl),
Exception, clean_and_throw(told, Exception)),
fail.
flags_save(_FileName):-
told.
flags_load(FileName):-
see(FileName),
catch((read('$store_flag_value$'(FlagName, Value)),
flag_set(FlagName, Value)),
Exception, clean_and_throw(seen, Exception)),
fail.
flags_load(_FileName):-
seen.
clean_and_throw(Action, Exception):-
Action,
throw(Exception).
flag_help:-
format('This is a short tutorial for the flags library.~nExported predicates:~n'),
format(' flag_define/5 : defines a new flag without a handler~n'),
format(' flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description)~n'),
format(' flag_define/6 : defines a new flag with a handler~n'),
format(' flag_define(FlagName, FlagGroup, FlagType, DefaultValue, Description, Handler)~n'),
format(' FlagName : the name of the flag~n'),
format(' FlagGroup : the name of the flag group~n'),
format(' FlagType : the type of the flag available types are:~n'),
flag_help_types,
format(' DefaultValue : the default value for the flag~n'),
format(' Description : a flag description~n'),
format(' Handler : a handler~n'),
flags:flag_help_handler,
format(' flag_groups/1 : returns all the flag groups in a list~n'),
format(' flag_group_chk/1 : checks if a group exists~n'),
format(' flag_set/2 : sets the value of a flag~n'),
format(' flag_get/2 : gets the value of a flag~n'),
format(' flag_store/2 : sets the value of a flag ignoring all tests and handlers~n'),
format(' flag_reset/0 : resets all flags to their default value~n'),
format(' flag_reset/1 : resets all flags of a group to their default value~n'),
format(' flag_help/0 : this screen~n'),
format(' flags_print/0 : shows the current flags/values~n').
flag_help_types:-
flag_type(FlagType),
format(' ~w~n', [FlagType]),
fail.
flag_help_types.
flag_help_handler:-
format(' Handler important notes:~n'),
format(' Conjuction: external_handler(validating, Value):-...~n'),
format(' Disjunction: external_handler(validate, Value):-...~n'),
format(' After: external_handler(validated, Value):-...~n'),
format(' After set: external_handler(stored, Value):-...~n'),
format(' this is implemented as (validating,(original;validated))~n'),
format(' validating|original|validate|result~n'),
format(' true | true | true | true~n'),
format(' true | true | fail | true~n'),
format(' true | fail | true | true~n'),
format(' true | fail | fail | fail~n'),
format(' fail | true | true | fail~n'),
format(' fail | true | fail | fail~n'),
format(' fail | fail | true | fail~n'),
format(' fail | fail | fail | fail~n'),
format(' Default behaviour is validating->true, validate->fail~n'),
format(' To completly replace original set validate->true~n'),
format(' To add new values to original set validating->true~n'),
format(' To remove values from original set validate->fail~n'),
format(' Example definition with a handler:~n'),
format(' flag_define(myflag, mygroup, in_interval(integer, [(-5, 5),([15],[25])]), 0, description, my_handler).~n'),
format(' my_handler(validate, Value):-Value is 10.~n'),
format(' my_handler(validating, Value).~n'),
format(' my_handler(validated, Value).~n'),
format(' my_handler(stored, Value).~n'),
format(' This has defined a flag that accepts integers (-5,5)v[15,25].~n'),
format(' The handler adds the value 10 in those.~n').
flags_print:-
flag_groups(Groups),
forall(member(Group, Groups), flags_print(Group)).
flags_print(Group):-
format(' ~w:~n~w~38+ ~w~19+ ~w~10+ ~w~10+~n', [Group, 'Description', 'Domain', 'Flag', 'Value']),
fail.
flags_print(FlagGroup):-
'$defined_flag$'(FlagName, FlagGroup, FlagType, _DefaultValue, Description, Access, _Handler),
Access \== hidden, Access \== hidden_read_only,
flag_get(FlagName, Value),
format('~w~38+ ~w~19+ ~w~10+ ~q~10+~n', [Description, FlagType, FlagName, Value]),
fail.
flags_print(_).
defined_flag(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler):-
'$defined_flag$'(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler),
Access \== hidden, Access \== hidden_read_only.
defined_flag(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler):-
nonvar(FlagName), nonvar(FlagGroup),
'$defined_flag$'(FlagName, FlagGroup, FlagType, DefaultValue, Description, Access, Handler).
%% @}

View File

@@ -1,44 +0,0 @@
/**
* @file gensym.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 18:37:13 2015
*
* @brief Generate a new atom.
*
*
*/
:- module(gensym, [
gensym/2,
reset_gensym/1,
reset_gensym/0
]).
/**
* @defgroup gensym Generate a new symbol.
* @ingroup library
*
* Predicates to create new atoms based on the prefix _Atom_.
* They use a counter, stored as a
* dynamic predicate, to construct the atom's suffix.
*
*/
:- dynamic gensym_key/2.
gensym(Atom, New) :-
retract(gensym_key(Atom,Id)), !,
atomic_concat(Atom,Id,New),
NId is Id+1,
assert(gensym_key(Atom,NId)).
gensym(Atom, New) :-
atomic_concat(Atom,1,New),
assert(gensym_key(Atom,2)).
reset_gensym(Atom) :-
retract(gensym_key(Atom,_)).
reset_gensym :-
retractall(gensym_key(_,_)).

View File

@@ -1,70 +0,0 @@
/**
* @file library/hacks.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 19:00:25 2015
*
* @brief Prolog hacking
*
*
*/
:- module(yap_hacks, [
current_choicepoint/1,
cut_by/1,
cut_at/1,
current_choicepoints/1,
choicepoint/7,
current_continuations/1,
continuation/4,
stack_dump/0,
stack_dump/1,
enable_interrupts/0,
disable_interrupts/0,
virtual_alarm/3,
fully_strip_module/3,
context_variables/1
]).
/**
* @defgroup yap_hacks YAP hacking
* @ingroup library
*
* Manipulate the Prolog stacks, including setting and resetting
* choice-points.
*
*/
stack_dump :-
stack_dump(-1).
stack_dump(Max) :-
current_choicepoints(CPs),
current_continuations([Env|Envs]),
continuation(Env,_,ContP,_),
length(CPs, LCPs),
length(Envs, LEnvs),
format(user_error,'~n~n~tStack Dump~t~40+~n~nAddress~tChoiceP~16+ Cur/Next Clause Goal~n',[LCPs,LEnvs]),
'$hacks':display_stack_info(CPs, Envs, Max, ContP, StackInfo, []),
run_formats(StackInfo, user_error).
run_formats([], _).
run_formats([Com-Args|StackInfo], Stream) :-
format(Stream, Com, Args),
run_formats(StackInfo, user_error).
virtual_alarm(Interval, Goal, Left) :-
Interval == 0, !,
virtual_alarm(0, 0, Left0, _),
on_signal(sig_vtalarm, _, Goal),
Left = Left0.
virtual_alarm(Interval, Goal, Left) :-
integer(Interval), !,
on_signal(sig_vtalarm, _, Goal),
virtual_alarm(Interval, 0, Left, _).
virtual_alarm(Interval.USecs, Goal, Left.LUSecs) :-
on_signal(sig_vtalarm, _, Goal),
virtual_alarm(Interval, USecs, Left, LUSecs).
fully_strip_module(T,M,S) :-
'$hacks':fully_strip_module(T,M,S).

View File

@@ -1,283 +0,0 @@
/**
* @file heaps.yap
* @author R.A.O'Keefe, included as an YAP library by Vitor Santos Costa, 1999.
* @date 29 November 1983
*
* @brief Implement heaps in Prolog.
*
*
*/
:- module(heaps,[
add_to_heap/4, % Heap x Key x Datum -> Heap
get_from_heap/4, % Heap -> Key x Datum x Heap
empty_heap/1, % Heap
heap_size/2, % Heap -> Size
heap_to_list/2, % Heap -> List
list_to_heap/2, % List -> Heap
min_of_heap/3, % Heap -> Key x Datum
min_of_heap/5 % Heap -> (Key x Datum) x (Key x Datum)
]).
/** @defgroup heaps Heaps
@ingroup library
@{
A heap is a labelled binary tree where the key of each node is less than
or equal to the keys of its sons. The point of a heap is that we can
keep on adding new elements to the heap and we can keep on taking out
the minimum element. If there are N elements total, the total time is
O(NlgN). If you know all the elements in advance, you are better off
doing a merge-sort, but this file is for when you want to do say a
best-first search, and have no idea when you start how many elements
there will be, let alone what they are.
The following heap manipulation routines are available once included
with the `use_module(library(heaps))` command.
- add_to_heap/4
- empty_heap/1
- get_from_heap/4
- heap_size/2
- heap_to_list/2
- list_to_heap/2
- min_of_heap/3
- min_of_heap/5
A heap is a labelled binary tree where the key of each node is less
than or equal to the keys of its sons. The point of a heap is that
we can keep on adding new elements to the heap and we can keep on
taking out the minimum element. If there are N elements total, the
total time is O(NlgN). If you know all the elements in advance, you
are better off doing a merge-sort, but this file is for when you want
to do say a best-first search, and have no idea when you start how
many elements there will be, let alone what they are.
A heap is represented as a triple t(N, Free, Tree) where N is the
number of elements in the tree, Free is a list of integers which
specifies unused positions in the tree, and Tree is a tree made of
t terms for empty subtrees and
t(Key,Datum,Lson,Rson) terms for the rest
The nodes of the tree are notionally numbered like this:
1
2 3
4 6 5 7
8 12 10 14 9 13 11 15
.. .. .. .. .. .. .. .. .. .. .. .. .. .. .. ..
The idea is that if the maximum number of elements that have been in
the heap so far is M, and the tree currently has K elements, the tree
is some subtreee of the tree of this form having exactly M elements,
and the Free list is a list of K-M integers saying which of the
positions in the M-element tree are currently unoccupied. This free
list is needed to ensure that the cost of passing N elements through
the heap is O(NlgM) instead of O(NlgN). For M say 100 and N say 10^4
this means a factor of two. The cost of the free list is slight.
The storage cost of a heap in a copying Prolog (which Dec-10 Prolog is
not) is 2K+3M words.
*/
/*
:- mode
add_to_heap(+, +, +, -),
add_to_heap(+, +, +, +, -),
add_to_heap(+, +, +, +, +, +, -, -),
sort2(+, +, +, +, -, -, -, -),
get_from_heap(+, ?, ?, -),
repair_heap(+, +, +, -),
heap_size(+, ?),
heap_to_list(+, -),
heap_tree_to_list(+, -),
heap_tree_to_list(+, +, -),
list_to_heap(+, -),
list_to_heap(+, +, +, -),
min_of_heap(+, ?, ?),
min_of_heap(+, ?, ?, ?, ?),
min_of_heap(+, +, ?, ?).
*/
%% @pred add_to_heap(OldHeap, Key, Datum, NewHeap)
%
% inserts the new Key-Datum pair into the heap. The insertion is
% not stable, that is, if you insert several pairs with the same
% Key it is not defined which of them will come out first, and it
% is possible for any of them to come out first depending on the
% history of the heap. If you need a stable heap, you could add
% a counter to the heap and include the counter at the time of
% insertion in the key. If the free list is empty, the tree will
% be grown, otherwise one of the empty slots will be re-used. (I
% use imperative programming language, but the heap code is as
% pure as the trees code, you can create any number of variants
% starting from the same heap, and they will share what common
% structure they can without interfering with each other.)
add_to_heap(t(M,[],OldTree), Key, Datum, t(N,[],NewTree)) :- !,
N is M+1,
add_to_heap(N, Key, Datum, OldTree, NewTree).
add_to_heap(t(M,[H|T],OldTree), Key, Datum, t(N,T,NewTree)) :-
N is M+1,
add_to_heap(H, Key, Datum, OldTree, NewTree).
add_to_heap(1, Key, Datum, _, t(Key,Datum,t,t)) :- !.
add_to_heap(N, Key, Datum, t(K1,D1,L1,R1), t(K2,D2,L2,R2)) :-
E is N mod 2,
M is N//2,
% M > 0, % only called from list_to_heap/4,add_to_heap/4
sort2(Key, Datum, K1, D1, K2, D2, K3, D3),
add_to_heap(E, M, K3, D3, L1, R1, L2, R2).
add_to_heap(0, N, Key, Datum, L1, R, L2, R) :- !,
add_to_heap(N, Key, Datum, L1, L2).
add_to_heap(1, N, Key, Datum, L, R1, L, R2) :- !,
add_to_heap(N, Key, Datum, R1, R2).
sort2(Key1, Datum1, Key2, Datum2, Key1, Datum1, Key2, Datum2) :-
Key1 @< Key2,
!.
sort2(Key1, Datum1, Key2, Datum2, Key2, Datum2, Key1, Datum1).
%% @pred @pred get_from_heap(+ _Heap_,- _key_,- _Datum_,- _Heap_)
%
% returns the Key-Datum pair in OldHeap with the smallest Key, and
% also a New Heap which is the Old Heap with that pair deleted.
% The easy part is picking off the smallest element. The hard part
% is repairing the heap structure. repair_heap/4 takes a pair of
% heaps and returns a new heap built from their elements, and the
% position number of the gap in the new tree. Note that repair_heap
% is *not* tail-recursive.
get_from_heap(t(N,Free,t(Key,Datum,L,R)), Key, Datum, t(M,[Hole|Free],Tree)) :-
M is N-1,
repair_heap(L, R, Tree, Hole).
repair_heap(t(K1,D1,L1,R1), t(K2,D2,L2,R2), t(K2,D2,t(K1,D1,L1,R1),R3), N) :-
K2 @< K1,
!,
repair_heap(L2, R2, R3, M),
N is 2*M+1.
repair_heap(t(K1,D1,L1,R1), t(K2,D2,L2,R2), t(K1,D1,L3,t(K2,D2,L2,R2)), N) :- !,
repair_heap(L1, R1, L3, M),
N is 2*M.
repair_heap(t(K1,D1,L1,R1), t, t(K1,D1,L3,t), N) :- !,
repair_heap(L1, R1, L3, M),
N is 2*M.
repair_heap(t, t(K2,D2,L2,R2), t(K2,D2,t,R3), N) :- !,
repair_heap(L2, R2, R3, M),
N is 2*M+1.
repair_heap(t, t, t, 1) :- !.
%% @pred heap_size(+ _Heap_, - _Size_)
%
% reports the number of elements currently in the heap.
heap_size(t(Size,_,_), Size).
%% @pred heap_to_list(+ _Heap_, - _List_)
%
% returns the current set of Key-Datum pairs in the Heap as a
% List, sorted into ascending order of Keys. This is included
% simply because I think every data structure foo ought to have
% a foo_to_list and list_to_foo relation (where, of course, it
% makes sense!) so that conversion between arbitrary data
% structures is as easy as possible. This predicate is basically
% just a merge sort, where we can exploit the fact that the tops
% of the subtrees are smaller than their descendants.
heap_to_list(t(_,_,Tree), List) :-
heap_tree_to_list(Tree, List).
heap_tree_to_list(t, []) :- !.
heap_tree_to_list(t(Key,Datum,Lson,Rson), [Key-Datum|Merged]) :-
heap_tree_to_list(Lson, Llist),
heap_tree_to_list(Rson, Rlist),
heap_tree_to_list(Llist, Rlist, Merged).
heap_tree_to_list([H1|T1], [H2|T2], [H2|T3]) :-
H2 @< H1,
!,
heap_tree_to_list([H1|T1], T2, T3).
heap_tree_to_list([H1|T1], T2, [H1|T3]) :- !,
heap_tree_to_list(T1, T2, T3).
heap_tree_to_list([], T, T) :- !.
heap_tree_to_list(T, [], T).
%% @pred list_to_heap(+ _List_, - _Heap_)
%
% takes a list of Key-Datum pairs (such as keysort could be used to
% sort) and forms them into a heap. We could do that a wee bit
% faster by keysorting the list and building the tree directly, but
% this algorithm makes it obvious that the result is a heap, and
% could be adapted for use when the ordering predicate is not @<
% and hence keysort is inapplicable.
list_to_heap(List, Heap) :-
list_to_heap(List, 0, t, Heap).
list_to_heap([], N, Tree, t(N,[],Tree)) :- !.
list_to_heap([Key-Datum|Rest], M, OldTree, Heap) :-
N is M+1,
add_to_heap(N, Key, Datum, OldTree, MidTree),
list_to_heap(Rest, N, MidTree, Heap).
%% @pred min_of_heap(Heap, Key, Datum)
%
% returns the Key-Datum pair at the top of the heap (which is of
% course the pair with the smallest Key), but does not remove it
% from the heap. It fails if the heap is empty.
/** @pred min_of_heap(+ _Heap_, - _Key_, - _Datum_)
Returns the Key-Datum pair at the top of the heap (which is of course
the pair with the smallest Key), but does not remove it from the heap.
*/
min_of_heap(t(_,_,t(Key,Datum,_,_)), Key, Datum).
%% @pred @pred min_of_heap(+ _Heap_, - _Key1_, - _Datum1_, -_Key2_, - _Datum2_)
%
% returns the smallest (Key1) and second smallest (Key2) pairs in
% the heap, without deleting them. It fails if the heap does not
% have at least two elements.
min_of_heap(t(_,_,t(Key1,Datum1,Lson,Rson)), Key1, Datum1, Key2, Datum2) :-
min_of_heap(Lson, Rson, Key2, Datum2).
min_of_heap(t(Ka,_Da,_,_), t(Kb,Db,_,_), Kb, Db) :-
Kb @< Ka, !.
min_of_heap(t(Ka,Da,_,_), _, Ka, Da).
min_of_heap(t, t(Kb,Db,_,_), Kb, Db).
/** @pred empty_heap(? _Heap_)
Succeeds if _Heap_ is an empty heap.
*/
empty_heap(t(0,[],t)).
/** @} */

View File

@@ -1,49 +0,0 @@
/**
* @file itries.yap
* @author Ricardo Rocha
* @date
*
* @brief Tries module for ILP
*
*
*/
/*********************************
File: itries.yap
Author: Ricardo Rocha
Comments: Tries module for ILP
version: $ID$
*********************************/
:- module(itries, [
itrie_open/1,
itrie_close/1,
itrie_close_all/0,
itrie_mode/2,
itrie_timestamp/2,
itrie_put_entry/2,
itrie_update_entry/2,
itrie_check_entry/3,
itrie_get_entry/2,
itrie_get_data/2,
itrie_traverse/2,
itrie_remove_entry/1,
itrie_remove_subtree/1,
itrie_add/2,
itrie_subtract/2,
itrie_join/2,
itrie_intersect/2,
itrie_count_join/3,
itrie_count_intersect/3,
itrie_save/2,
itrie_save_as_trie/2,
itrie_load/2,
itrie_save2stream/2,
itrie_loadFromstream/2,
itrie_stats/4,
itrie_max_stats/4,
itrie_usage/4,
itrie_print/1
]).
:- load_foreign_files([itries], [], init_itries).

View File

@@ -1,221 +0,0 @@
% Author: Nuno A. Fonseca
% Date: 2006-06-01
% $Id: lam_mpi.yap,v 1.1 2006-06-04 18:43:38 nunofonseca Exp $
:- module(lam_mpi, [
mpi_init/0,
mpi_finalize/0,
mpi_comm_size/1,
mpi_comm_rank/1,
mpi_version/2,
mpi_send/3,
mpi_isend/4,
mpi_recv/3,
mpi_irecv/3,
mpi_wait/2,
mpi_wait_recv/3,
mpi_test/2,
mpi_test_recv/3,
mpi_bcast/2,
mpi_ibcast2/2,
mpi_ibcast2/3,
mpi_bcast2/2,
mpi_bcast2/3,
mpi_barrier/0,
mpi_msg_buffer_size/2,
mpi_msg_size/2,
mpi_gc/0,
mpi_default_buffer_size/2
]).
/**
* @defgroup lam_mpi MPI Interface
* @ingroup library
@{
This library provides a set of utilities for interfacing with LAM MPI.
The following routines are available once included with the
`use_module(library(lam_mpi))` command. The yap should be
invoked using the LAM mpiexec or mpirun commands (see LAM manual for
more details).
*/
/** @pred mpi_barrier
Collective communication predicate. Performs a barrier
synchronization among all processes. Note that a collective
communication means that all processes call the same predicate. To be
able to use a regular `mpi_recv` to receive the messages, one
should use `mpi_bcast2`.
*/
/** @pred mpi_bcast2(+ _Root_, ? _Data_)
Broadcasts the message _Data_ from the process with rank _Root_
to all other processes.
*/
/** @pred mpi_comm_rank(- _Rank_)
Unifies _Rank_ with the rank of the current process in the MPI environment.
*/
/** @pred mpi_comm_size(- _Size_)
Unifies _Size_ with the number of processes in the MPI environment.
*/
/** @pred mpi_finalize
Terminates the MPI execution environment. Every process must call this predicate before exiting.
*/
/** @pred mpi_gc
Attempts to perform garbage collection with all the open handles
associated with send and non-blocking broadcasts. For each handle it
tests it and the message has been delivered the handle and the buffer
are released.
*/
/** @pred mpi_init
Sets up the mpi environment. This predicate should be called before any other MPI predicate.
*/
/** @pred mpi_irecv(? _Source_,? _Tag_,- _Handle_)
Non-blocking communication predicate. The predicate returns an
_Handle_ for a message that will be received from processor with
rank _Source_ and tag _Tag_. Note that the predicate succeeds
immediately, even if no message has been received. The predicate
`mpi_wait_recv` should be used to obtain the data associated to
the handle.
*/
/** @pred mpi_isend(+ _Data_,+ _Dest_,+ _Tag_,- _Handle_)
Non blocking communication predicate. The message in _Data_, with
tag _Tag_, is sent whenever possible to the processor with rank
_Dest_. An _Handle_ to the message is returned to be used to
check for the status of the message, using the `mpi_wait` or
`mpi_test` predicates. Until `mpi_wait` is called, the
memory allocated for the buffer containing the message is not
released.
*/
/** @pred mpi_msg_size( _Msg_, - _MsgSize_)
Unify _MsgSize_ with the number of bytes YAP would need to send the
message _Msg_.
*/
/** @pred mpi_recv(? _Source_,? _Tag_,- _Data_)
Blocking communication predicate. The predicate blocks until a message
is received from processor with rank _Source_ and tag _Tag_.
The message is placed in _Data_.
*/
/** @pred mpi_send(+ _Data_,+ _Dest_,+ _Tag_)
Blocking communication predicate. The message in _Data_, with tag
_Tag_, is sent immediately to the processor with rank _Dest_.
The predicate succeeds after the message being sent.
*/
/** @pred mpi_test(? _Handle_,- _Status_)
Provides information regarding the handle _Handle_, ie., if a
communication operation has been completed. If the operation
associate with _Hanlde_ has been completed the predicate succeeds
with the completion status in _Status_, otherwise it fails.
*/
/** @pred mpi_test_recv(? _Handle_,- _Status_,- _Data_)
Provides information regarding a handle. If the message associated
with handle _Hanlde_ is buffered then the predicate succeeds
unifying _Status_ with the status of the message and _Data_
with the message itself. Otherwise, the predicate fails.
*/
/** @pred mpi_version(- _Major_,- _Minor_)
Unifies _Major_ and _Minor_ with, respectively, the major and minor version of the MPI.
*/
/** @pred mpi_wait(? _Handle_,- _Status_)
Completes a non-blocking operation. If the operation was a
`mpi_send`, the predicate blocks until the message is buffered
or sent by the runtime system. At this point the send buffer is
released. If the operation was a `mpi_recv`, it waits until the
message is copied to the receive buffer. _Status_ is unified with
the status of the message.
*/
/** @pred mpi_wait_recv(? _Handle_,- _Status_,- _Data_)
Completes a non-blocking receive operation. The predicate blocks until
a message associated with handle _Hanlde_ is buffered. The
predicate succeeds unifying _Status_ with the status of the
message and _Data_ with the message itself.
*/
:- load_foreign_files([yap_mpi], [], init_mpi).
mpi_msg_size(Term, Size) :-
terms:export_term(Term, Buf, Size),
terms:kill_exported_term(Buf).
/** @} */

View File

@@ -1,217 +0,0 @@
/**
* @file heaps.yap
* @author Ulrich Neumerkel
* @date 2009
*
* @brief Lambda expressions in Prolog.
*
*
*/
/*
Author:
E-mail: ulrich@complang.tuwien.ac.at
Copyright (C): 2009 Ulrich Neumerkel. All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
1. Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
THIS SOFTWARE IS PROVIDED BY Ulrich Neumerkel ``AS IS'' AND ANY
EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Ulrich Neumerkel OR
CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
The views and conclusions contained in the software and documentation
are those of the authors and should not be interpreted as representing
official policies, either expressed or implied, of Ulrich Neumerkel.
*/
:- module(lambda, [
(^)/3, (^)/4, (^)/5, (^)/6, (^)/7, (^)/8, (^)/9,
(\)/1, (\)/2, (\)/3, (\)/4, (\)/5, (\)/6, (\)/7,
(+\)/2, (+\)/3, (+\)/4, (+\)/5, (+\)/6, (+\)/7,
op(201,xfx,+\)]).
/**
@defgroup Lambda expressions
@ingroup library
This library provides lambda expressions to simplify higher order
programming based on call/N.
Lambda expressions are represented by ordinary Prolog terms.
There are two kinds of lambda expressions:
~~~~
Free+\X1^X2^ ..^XN^Goal
\X1^X2^ ..^XN^Goal
~~~~
The second is a shorthand for t+\X1^X2^..^XN^Goal
+ _Xi_ are the parameters.
+ _Goal_ is a goal or continuation. Syntax note: Operators within Goal
require parentheses due to the low precedence of the ^ operator.
+ _Free_ contains variables that are valid outside the scope of the lambda
expression. They are thus free variables within.
All other variables of Goal are considered local variables. They must
not appear outside the lambda expression. This restriction is
currently not checked. Violations may lead to unexpected bindings.
In the following example the parentheses around X>3 are necessary.
~~~~~
?- use_module(library(lambda)).
?- use_module(library(apply)).
?- maplist(\X^(X>3),[4,5,9]).
true.
~~~~~
In the following _X_ is a variable that is shared by both instances of
the lambda expression. The second query illustrates the cooperation of
continuations and lambdas. The lambda expression is in this case a
continuation expecting a further argument.
~~~~~
?- Xs = [A,B], maplist(X+\Y^dif(X,Y), Xs).
Xs = [A, B],
dif(X, A),
dif(X, B).
?- Xs = [A,B], maplist(X+\dif(X), Xs).
Xs = [A, B],
dif(X, A),
dif(X, B).
~~~~~
The following queries are all equivalent. To see this, use
the fact f(x,y).
~~~~~
?- call(f,A1,A2).
?- call(\X^f(X),A1,A2).
?- call(\X^Y^f(X,Y), A1,A2).
?- call(\X^(X+\Y^f(X,Y)), A1,A2).
?- call(call(f, A1),A2).
?- call(f(A1),A2).
?- f(A1,A2).
A1 = x,
A2 = y.
~~~~~
Further discussions
http://www.complang.tuwien.ac.at/ulrich/Prolog-inedit/ISO-Hiord
@tbd Static expansion similar to apply_macros.
@author Ulrich Neumerkel
*/
:- meta_predicate no_hat_call(0).
:- meta_predicate
^(?,0,?),
^(?,1,?,?),
^(?,2,?,?,?),
^(?,3,?,?,?,?),
^(?,4,?,?,?,?,?).
^(V1,Goal,V1) :-
no_hat_call(Goal).
^(V1,Goal,V1,V2) :-
call(Goal,V2).
^(V1,Goal,V1,V2,V3) :-
call(Goal,V2,V3).
^(V1,Goal,V1,V2,V3,V4) :-
call(Goal,V2,V3,V4).
^(V1,Goal,V1,V2,V3,V4,V5) :-
call(Goal,V2,V3,V4,V5).
^(V1,Goal,V1,V2,V3,V4,V5,V6) :-
call(Goal,V2,V3,V4,V5,V6).
^(V1,Goal,V1,V2,V3,V4,V5,V6,V7) :-
call(Goal,V2,V3,V4,V5,V6,V7).
:- meta_predicate
\(0),
\(1,?),
\(2,?,?),
\(3,?,?,?),
\(4,?,?,?,?),
\(5,?,?,?,?,?),
\(6,?,?,?,?,?,?).
\(FC) :-
copy_term_nat(FC,C),no_hat_call(C).
\(FC,V1) :-
copy_term_nat(FC,C),call(C,V1).
\(FC,V1,V2) :-
copy_term_nat(FC,C),call(C,V1,V2).
\(FC,V1,V2,V3) :-
copy_term_nat(FC,C),call(C,V1,V2,V3).
\(FC,V1,V2,V3,V4) :-
copy_term_nat(FC,C),call(C,V1,V2,V3,V4).
\(FC,V1,V2,V3,V4,V5) :-
copy_term_nat(FC,C),call(C,V1,V2,V3,V4,V5).
\(FC,V1,V2,V3,V4,V5,V6) :-
copy_term_nat(FC,C),call(C,V1,V2,V3,V4,V5,V6).
:- meta_predicate
+\(?,0),
+\(?,1,?),
+\(?,2,?,?),
+\(?,3,?,?,?),
+\(?,4,?,?,?,?),
+\(?,5,?,?,?,?,?),
+\(?,6,?,?,?,?,?,?).
+\(GV,FC) :-
copy_term_nat(GV+FC,GV+C),no_hat_call(C).
+\(GV,FC,V1) :-
copy_term_nat(GV+FC,GV+C),call(C,V1).
+\(GV,FC,V1,V2) :-
copy_term_nat(GV+FC,GV+C),call(C,V1,V2).
+\(GV,FC,V1,V2,V3) :-
copy_term_nat(GV+FC,GV+C),call(C,V1,V2,V3).
+\(GV,FC,V1,V2,V3,V4) :-
copy_term_nat(GV+FC,GV+C),call(C,V1,V2,V3,V4).
+\(GV,FC,V1,V2,V3,V4,V5) :-
copy_term_nat(GV+FC,GV+C),call(C,V1,V2,V3,V4,V5).
+\(GV,FC,V1,V2,V3,V4,V5,V6) :-
copy_term_nat(GV+FC,GV+C),call(C,V1,V2,V3,V4,V5,V6).
%% no_hat_call(:Goal)
%
% Like call, but issues an error for a goal (^)/2. Such goals are
% likely the result of an insufficient number of arguments.
no_hat_call(MGoal) :-
strip_module(MGoal, _, Goal),
( nonvar(Goal),
Goal = (_^_)
-> throw(error(existence_error(lambda_parameters,Goal),_))
; call(MGoal)
).
% I would like to replace this by:
% V1^Goal :- throw(error(existence_error(lambda_parameters,V1^Goal),_)).

View File

@@ -1,527 +0,0 @@
/**
* @file lineutils.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 22:02:22 2015
*
* @brief line text processing.
*
*
*/
:- module(lineutils,
[search_for/2,
search_for/3,
scan_natural/3,
scan_integer/3,
natural/3,
integer/3,
blank/3,
split/2,
split/3,
split/4,
split/5,
split_unquoted/3,
fields/2,
fields/3,
glue/3,
copy_line/2,
filter/3,
file_filter/3,
file_select/2,
file_filter_with_initialization/5,
file_filter_with_start_end/5,
file_filter_with_initialization/5 as file_filter_with_init,
process/2
]).
/** @defgroup line_utils Line Manipulation Utilities
@ingroup library
@{
This package provides a set of useful predicates to manipulate
sequences of characters codes, usually first read in as a line. It is
available by loading the
~~~~
:- use_module(library(lineutils)).
~~~~
*/
:- meta_predicate
filter(+,+,2),
file_filter(+,+,2),
file_filter_with_initialization(+,+,2,+,:),
file_filter_with_start_end(+,+,2,2,2),
process(+,1).
:- use_module(library(lists),
[member/2,
append/3]).
:- use_module(library(readutil),
[read_line_to_codes/2]).
/**
@pred search_for(+ _Char_,+ _Line_)
Search for a character _Char_ in the list of codes _Line_.
*/
search_for(C,L) :-
search_for(C, L, []).
search_for(C) --> [C], !.
search_for(C) --> [_],
search_for(C).
/** @pred scan_integer(? _Int_,+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for an integer _Nat_, either a
positive, zero, or negative integer, and unify _RestOfLine_ with
the remainder of the line.
*/
scan_integer(N) -->
"-", !,
scan_natural(0, N0),
N is -N0.
scan_integer(N) -->
scan_natural(0, N).
/** @pred integer(? _Int_,+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for an integer _Nat_, either a
positive, zero, or negative integer, and unify _RestOfLine_ with
the remainder of the line.
*/
integer(N) -->
"-", !,
natural(0, N0),
N is -N0.
integer(N) -->
natural(0, N).
/** @pred scan_natural(? _Nat_,+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for a natural number _Nat_, zero
or a positive integer, and unify _RestOfLine_ with the remainder
of the line.
*/
scan_natural(N) -->
scan_natural(0, N).
scan_natural(N0,N) -->
[C],
{C >= 0'0, C =< 0'9 }, !,
{ N1 is N0*10+(C-0'0) }, %'
get_natural(N1,N).
scan_natural(N,N) --> [].
/** @pred natural(? _Nat_,+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for a natural number _Nat_, zero
or a positive integer, and unify _RestOfLine_ with the remainder
of the line.
*/
natural(N) -->
natural(0, N).
natural(N0,N) -->
[C],
{C >= 0'0, C =< 0'9 }, !,
{ N1 is N0*10+(C-0'0) }, %'
get_natural(N1,N).
natural(N,N) --> [].
/** @pred skip_whitespace(+ _Line_,+ _RestOfLine_)
Scan the list of codes _Line_ for white space, namely for tabbing and space characters.
*/
skip_whitespace([0' |Blanks]) -->
" ",
skip_whitespace( Blanks ).
skip_whitespace([0' |Blanks]) -->
" ",
skip_whitespace( Blanks ).
skip_whitespace( [] ) -->
!.
/** @pred blank(+ _Line_,+ _RestOfLine_)
The list of codes _Line_ is formed by white space, namely by tabbing and space characters.
*/
blank([0' |Blanks]) -->
" ",
blank( Blanks ).
blank([0' |Blanks]) -->
" ",
blank( Blanks ).
blank( [] ) -->
[].
/** @pred split(+ _Line_,- _Split_)
Unify _Words_ with a set of strings obtained from _Line_ by
using the blank characters as separators.
*/
split(String, Strings) :-
split_at_blank(" ", Strings, String, []).
/** @pred split(+ _Line_,+ _Separators_,- _Split_)
Unify _Words_ with a set of strings obtained from _Line_ by
using the character codes in _Separators_ as separators. As an
example, consider:
~~~~~{.prolog}
?- split("Hello * I am free"," *",S).
S = ["Hello","I","am","free"] ?
no
~~~~~
*/
split(String, SplitCodes, Strings) :-
split_at_blank(SplitCodes, Strings, String, []).
split_at_blank(SplitCodes, More) -->
[C],
{ member(C, SplitCodes) }, !,
split_at_blank(SplitCodes, More).
split_at_blank(SplitCodes, [[C|New]| More]) -->
[C], !,
split_(SplitCodes, New, More).
split_at_blank(_, []) --> [].
split_(SplitCodes, [], More) -->
[C],
{ member(C, SplitCodes) }, !,
split_at_blank(SplitCodes, More).
split_(SplitCodes, [C|New], Set) -->
[C], !,
split_(SplitCodes, New, Set).
split_(_, [], []) --> [].
split(Text, SplitCodes, DoubleQs, SingleQs, Strings) :-
split_element(SplitCodes, DoubleQs, SingleQs, Strings, Text, []).
split_element(SplitCodes, DoubleQs, SingleQs, Strings) -->
[C],
!,
split_element(SplitCodes, DoubleQs, SingleQs, Strings, C).
split_element(_SplitCodes, _DoubleQs, _SingleQs, []) --> !.
split_element(_SplitCodes, _DoubleQs, _SingleQs, [[]]) --> [].
split_element(SplitCodes, DoubleQs, SingleQs, Strings, C) -->
{ member( C, SingleQs ) },
!,
[C2],
{ Strings = [[C2|String]|More] },
split_element(SplitCodes, DoubleQs, SingleQs, [String| More]).
split_element(SplitCodes, DoubleQs, SingleQs, [[]|Strings], C) -->
{ member( C, SplitCodes ) },
!,
split_element(SplitCodes, DoubleQs, SingleQs, Strings).
split_element(SplitCodes, DoubleQs, SingleQs, Strings, C) -->
{ member( C, DoubleQs ) } ,
!,
split_within(SplitCodes, C-DoubleQs, SingleQs, Strings).
split_element(SplitCodes, DoubleQs, SingleQs, [[C|String]|Strings], C) -->
split_element(SplitCodes, DoubleQs, SingleQs, [String|Strings]).
split_within(SplitCodes, DoubleQs, SingleQs, Strings) -->
[C],
split_within(SplitCodes, DoubleQs, SingleQs, Strings, C).
split_within(SplitCodes, DoubleQs, SingleQs, Strings, C) -->
{ member( C, SingleQs ) },
!,
[C2],
{ Strings = [[C2|String]|More] },
split_within(SplitCodes, DoubleQs, SingleQs, [String| More]).
split_within(SplitCodes, DoubleQs, C-SingleQs, Strings, C) -->
!,
split_element(SplitCodes, DoubleQs, SingleQs, Strings).
split_within(SplitCodes, DoubleQs, SingleQs, [[C|String]|Strings], C) -->
split_within(SplitCodes, DoubleQs, SingleQs, [String|Strings]).
/** @pred split_unquoted(+ _Line_,+ _Separators_,- _Split_)
Unify _Words_ with a set of strings obtained from _Line_ by
using the character codes in _Separators_ as separators, but treat text wi
thin double quotes as a single unit. As an
example, consider:
~~~~~{.prolog}
?- split("Hello * I \"am free\""," *",S).
S = ["Hello","I","am free"] ?
no
~~~~~
*/
split_unquoted(String, SplitCodes, Strings) :-
split_unquoted_at_blank(SplitCodes, Strings, String, []).
split_unquoted_at_blank(SplitCodes, [[0'"|New]|More]) --> %0'"
"\"",
split_quoted(New, More),
split_unquoted_at_blank(SplitCodes, More).
split_unquoted_at_blank(SplitCodes, More) -->
[C],
{ member(C, SplitCodes) }, !,
split_unquoted_at_blank(SplitCodes, More).
split_unquoted_at_blank(SplitCodes, [[C|New]| More]) -->
[C], !,
split_unquoted(SplitCodes, New, More).
split_unquoted_at_blank(_, []) --> [].
split_unquoted(SplitCodes, [], More) -->
[C],
{ member(C, SplitCodes) }, !,
split_unquoted_at_blank(SplitCodes, More).
split_unquoted(SplitCodes, [C|New], Set) -->
[C], !,
split_unquoted(SplitCodes, New, Set).
split_unquoted(_, [], []) --> [].
/** @pred split_quoted(+ _Line_,+ _Separators_, GroupQuotes, SingleQuotes, - _Split_)
Unify _Words_ with a set of strings obtained from _Line_ by
using the character codes in _Separators_ as separators, but treat text within quotes as a single unit. As an
example, consider:
~~~~~{.prolog}
?- split_quoted("Hello * I \"am free\""," *",S).
S = ["Hello","I","am free"] ?
no
~~~~~
*/
split_quoted( [0'"], _More) --> %0'"
"\"".
split_quoted( [0'\\ ,C|New], More) -->
%0'"
"\\",
[C],
split_quoted(New, More).
split_quoted( [C|New], More) --> %0'"
[C],
split_quoted(New, More).
/** @pred fields(+ _Line_,- _Split_)
Unify _Words_ with a set of strings obtained from _Line_ by
using the blank characters as field separators.
*/
fields(String, Strings) :-
fields(" ", Strings, String, []).
/** @pred fields(+ _Line_,+ _Separators_,- _Split_)
Unify _Words_ with a set of strings obtained from _Line_ by
using the character codes in _Separators_ as separators for
fields. If two separators occur in a row, the field is considered
empty. As an example, consider:
~~~~~{.prolog}
?- fields("Hello I am free"," *",S).
S = ["Hello","","I","am","","free"] ?
~~~~~
*/
fields(String, FieldsCodes, Strings) :-
dofields(FieldsCodes, First, More, String, []),
(
First = [], More = []
->
Strings = []
;
Strings = [First|More]
).
dofields(FieldsCodes, [], New.More) -->
[C],
{ member(C, FieldsCodes) }, !,
dofields(FieldsCodes, New, More).
dofields(FieldsCodes, [C|New], Set) -->
[C], !,
dofields(FieldsCodes, New, Set).
dofields(_, [], []) --> [].
/** @pred glue(+ _Words_,+ _Separator_,- _Line_)
Unify _Line_ with string obtained by glueing _Words_ with
the character code _Separator_.
*/
glue([], _, []).
glue([A], _, A) :- !.
glue([H|T], [B|_], Merged) :-
append(H, [B|Rest], Merged),
glue(T, [B], Rest).
/** @pred copy_line(+ _StreamInput_,+ _StreamOutput_)
Copy a line from _StreamInput_ to _StreamOutput_.
*/
copy_line(StreamInp, StreamOut) :-
read_line_to_codes(StreamInp, Line),
format(StreamOut, '~s~n', [Line]).
/** @pred filter(+ _StreamInp_, + _StreamOut_, + _Goal_)
For every line _LineIn_ in stream _StreamInp_, execute
`call(Goal,LineIn,LineOut)`, and output _LineOut_ to
stream _StreamOut_. If `call(Goal,LineIn,LineOut)` fails,
nothing will be output but execution continues with the next
line. As an example, consider a procedure to select the second and
fifth field of a CSV table :
~~~~~{.prolog}
select(Sep, In, Out) :-
fields(In, Sep, [_,F2,_,_,F5|_]),
fields(Out,Sep, [F2,F5]).
select :-
filter(",",
~~~~~
*/
filter(StreamInp, StreamOut, Command) :-
repeat,
read_line_to_codes(StreamInp, Line),
(
Line == end_of_file
->
!
;
call(Command, Line, NewLine),
ground(NewLine),
format(StreamOut, '~s~n', [NewLine]),
fail
).
/** @pred process(+ _StreamInp_, + _Goal_) is meta
For every line _LineIn_ in stream _StreamInp_, call
`call(Goal,LineIn)`.
*/
process(StreamInp, Command) :-
repeat,
read_line_to_codes(StreamInp, Line),
(
Line == end_of_file
->
!
;
call(Command, Line),
fail
).
/**
* @pred file_filter(+ _FileIn_, + _FileOut_, + _Goal_) is meta
*
* @param _FileIn_ File to process
* @param _FileOut_ Output file, often user_error
* @param _Goal_ to be metacalled, receives FileIn and FileOut as
* extra arguments
*
* @return succeeds
For every line _LineIn_ in file _FileIn_, execute
`call(Goal,LineIn,LineOut)`, and output _LineOut_ to file
_FileOut_.
The input stream is accessible through the alias `filter_input`, and
the output stream is accessible through `filter_output`.
*/
file_filter(Inp, Out, Command) :-
open(Inp, read, StreamInp, [alias(filter_input)]),
open(Out, write, StreamOut),
filter(StreamInp, StreamOut, Command),
close(StreamInp),
close(StreamOut).
/** @pred file_filter_with_initialization(+ _FileIn_, + _FileOut_, + _Goal_, + _FormatCommand_, + _Arguments_)
Same as file_filter/3, but before starting the filter execute
`format/3` on the output stream, using _FormatCommand_ and
_Arguments_.
*/
file_filter_with_initialization(Inp, Out, Command, FormatString, Parameters) :-
open(Inp, read, StreamInp, [alias(filter_input)]),
open(Out, write, StreamOut, [alias(filter_output)]),
format(StreamOut, FormatString, Parameters),
filter(StreamInp, StreamOut, Command),
close(StreamInp),
close(StreamOut).
/** @pred file_filter_with_start_end(+ FileIn, + FileOut, + Goal, + StartGoal, + EndGoal)
Same as file_filter/3, but before starting the filter execute
_StartGoal_, and call _ENdGoal_ as an epilog.
The input stream are always accessible through `filter_output` and `filter_input`.
*/
file_filter_with_start_end(Inp, Out, Command, StartGoal, EndGoal) :-
open(Inp, read, StreamInp, [alias(filter_input)]),
open(Out, write, StreamOut, [alias(filter_output)]),
call( StartGoal, StreamInp, StreamOut ),
filter(StreamInp, StreamOut, Command),
call( EndGoal, StreamInp, StreamOut ),
close(StreamInp),
close(StreamOut).
/**
* @pred file_select(+ _FileIn_, + _Goal_) is meta
*
* @param _FileIn_ File to process
* @param _Goal_ to be metacalled, receives FileIn as
* extra arguments
*
* @return bindings to arguments of _Goal_.
For every line _LineIn_ in file _FileIn_, execute
`call(`Goal,LineIn)`.
The input stream is accessible through the alias `filter_input`, and
the output stream is accessible through `filter_output`.
*/
file_select(Inp, Command) :-
( retract(alias(F)) -> true ; F = '' ),
atom_concat(filter_input, F, Alias),
open(Inp, read, StreamInp, [Alias]),
atom_concat('_', F, NF),
assert( alias(NF) ),
repeat,
read_line_to_codes(StreamInp, Line),
(
Line == end_of_file
->
close(StreamInp),
retract(alias(NF)),
assert(alias(F)),
!,
atom_concat(filter_input, F, Alias),
fail
;
call(Command, Line)
).
/**
@}
*/

View File

@@ -1,50 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: listing.yap *
* Last rev: *
* mods: *
* comments: listing a prolog program *
* *
*************************************************************************/
/**
* @file library/listing.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 22:03:59 2015
*
* @brief Emulate SWI Prolog's listing.
*
*
*/
:- module(swi_listing,
[ listing/0,
listing/1,
portray_clause/1, % +Clause
portray_clause/2, % +Stream, +Clause
portray_clause/3 % +Stream, +Clause, +Options
]).
/*
* @defgroup swi_listing SWI Prolog listing emulation
* @ingroup library
emulates listing.pl, but just the interface for now.
*/
:- meta_predicate portray_clause( +, + , : ).
portray_clause(Stream, Term, M:Options) :-
portray_clause( Stream, Term ).

View File

@@ -1,630 +0,0 @@
/**
* @file library/lists.yap
* @author Bob Welham, Lawrence Byrd, and R. A. O'Keefe. Contributions from Vitor Santos Costa, Jan Wielemaker and others.
* @date 1999
*
* @addtogroup lists The Prolog Library
*
* @ingroup library
*
* @{
*
* @brief List Manipulation Predicates
*
*
*/
% This file has been included as an YAP library by Vitor Santos Costa, 1999
:- module(lists,
[
append/3,
append/2,
delete/3,
intersection/3,
flatten/2,
last/2,
list_concat/2,
max_list/2,
list_to_set/2,
member/2,
memberchk/2,
min_list/2,
nextto/3,
nth/3,
nth/4,
nth0/3,
nth0/4,
nth1/3,
nth1/4,
numlist/3,
permutation/2,
prefix/2,
remove_duplicates/2,
reverse/2,
same_length/2,
select/3,
selectchk/3,
sublist/2,
substitute/4,
subtract/3,
suffix/2,
sum_list/2,
sum_list/3,
sumlist/2
]).
/** @defgroup lists List Manipulation
@ingroup library
@{
The following list manipulation routines are available once included
with the `use_module(library(lists))` command.
*/
/** @pred list_concat(+ _Lists_,? _List_)
True when _Lists_ is a list of lists and _List_ is the
concatenation of _Lists_.
*/
/** @pred max_list(? _Numbers_, ? _Max_)
True when _Numbers_ is a list of numbers, and _Max_ is the maximum.
*/
/** @pred min_list(? _Numbers_, ? _Min_)
True when _Numbers_ is a list of numbers, and _Min_ is the minimum.
*/
/** @pred nth(? _N_, ? _List_, ? _Elem_)
The same as nth1/3.
*/
/** @pred nth(? _N_, ? _List_, ? _Elem_, ? _Rest_)
Same as `nth1/4`.
*/
/** @pred nth0(? _N_, ? _List_, ? _Elem_)
True when _Elem_ is the Nth member of _List_,
counting the first as element 0. (That is, throw away the first
N elements and unify _Elem_ with the next.) It can only be used to
select a particular element given the list and index. For that
task it is more efficient than member/2
*/
/** @pred nth0(? _N_, ? _List_, ? _Elem_, ? _Rest_)
Unifies _Elem_ with the Nth element of _List_,
counting from 0, and _Rest_ with the other elements. It can be used
to select the Nth element of _List_ (yielding _Elem_ and _Rest_), or to
insert _Elem_ before the Nth (counting from 1) element of _Rest_, when
it yields _List_, e.g. `nth0(2, List, c, [a,b,d,e])` unifies List with
`[a,b,c,d,e]`. `nth/4` is the same except that it counts from 1. `nth0/4`
can be used to insert _Elem_ after the Nth element of _Rest_.
*/
/** @pred nth1(+ _Index_,? _List_,? _Elem_)
Succeeds when the _Index_-th element of _List_ unifies with
_Elem_. Counting starts at 1.
Set environment variable. _Name_ and _Value_ should be
instantiated to atoms or integers. The environment variable will be
passed to `shell/[0-2]` and can be requested using `getenv/2`.
They also influence expand_file_name/2.
*/
/** @pred nth1(? _N_, ? _List_, ? _Elem_)
The same as nth0/3, except that it counts from
1, that is `nth(1, [H|_], H)`.
*/
/** @pred nth1(? _N_, ? _List_, ? _Elem_, ? _Rest_)
Unifies _Elem_ with the Nth element of _List_, counting from 1,
and _Rest_ with the other elements. It can be used to select the
Nth element of _List_ (yielding _Elem_ and _Rest_), or to
insert _Elem_ before the Nth (counting from 1) element of
_Rest_, when it yields _List_, e.g. `nth(3, List, c, [a,b,d,e])` unifies List with `[a,b,c,d,e]`. `nth/4`
can be used to insert _Elem_ after the Nth element of _Rest_.
*/
/** @pred numlist(+ _Low_, + _High_, + _List_)
If _Low_ and _High_ are integers with _Low_ =<
_High_, unify _List_ to a list `[Low, Low+1, ...High]`. See
also between/3.
*/
/** @pred permutation(+ _List_,? _Perm_)
True when _List_ and _Perm_ are permutations of each other.
*/
/** @pred remove_duplicates(+ _List_, ? _Pruned_)
Removes duplicated elements from _List_. Beware: if the _List_ has
non-ground elements, the result may surprise you.
*/
/** @pred same_length(? _List1_, ? _List2_)
True when _List1_ and _List2_ are both lists and have the same number
of elements. No relation between the values of their elements is
implied.
Modes `same_length(-,+)` and `same_length(+,-)` generate either list given
the other; mode `same_length(-,-)` generates two lists of the same length,
in which case the arguments will be bound to lists of length 0, 1, 2, ...
*/
%% @pred append(? _Lists_,? _Combined_)
%
% Concatenate a list of lists. Is true if Lists is a list of
% lists, and List is the concatenation of these lists.
%
% @param ListOfLists must be a list of -possibly- partial lists
append(ListOfLists, List) :-
% must_be(list, ListOfLists),
append_(ListOfLists, List).
append_([], []).
append_([L], L).
append_([L1,L2], L) :-
append(L1,L2,L).
append_([L1,L2|[L3|LL]], L) :-
append(L1,L2,LI),
append_([LI|[L3|LL]],L).
/** @pred last(+ _List_,? _Last_)
True when _List_ is a list and _Last_ is identical to its last element.
d(_, [X], L).
*/
last([H|List], Last) :-
last(List, H, Last).
last([], Last, Last).
last([H|List], _, Last) :-
last(List, H, Last).
% nextto(X, Y, List)
% is true when X and Y appear side-by-side in List. It could be written as
% nextto(X, Y, List) :- append(_, [X,Y,_], List).
% It may be used to enumerate successive pairs from the list.
nextto(X,Y, [X,Y|_]).
nextto(X,Y, [_|List]) :-
nextto(X,Y, List).
% nth0(?N, +List, ?Elem) is true when Elem is the Nth member of List,
% counting the first as element 0. (That is, throw away the first
% N elements and unify Elem with the next.) It can only be used to
% select a particular element given the list and index. For that
% task it is more efficient than nmember.
% nth(+N, +List, ?Elem) is the same as nth0, except that it counts from
% 1, that is nth(1, [H|_], H).
nth0(V, In, Element) :- var(V), !,
generate_nth(0, V, In, Element).
nth0(0, [Head|_], Head) :- !.
nth0(N, [_|Tail], Elem) :-
M is N-1,
find_nth0(M, Tail, Elem).
find_nth0(0, [Head|_], Head) :- !.
find_nth0(N, [_|Tail], Elem) :-
M is N-1,
find_nth0(M, Tail, Elem).
nth1(V, In, Element) :- var(V), !,
generate_nth(1, V, In, Element).
nth1(1, [Head|_], Head) :- !.
nth1(N, [_|Tail], Elem) :-
nonvar(N), !,
M is N-1, % should be succ(M, N)
find_nth(M, Tail, Elem).
nth(V, In, Element) :- var(V), !,
generate_nth(1, V, In, Element).
nth(1, [Head|_], Head) :- !.
nth(N, [_|Tail], Elem) :-
nonvar(N), !,
M is N-1, % should be succ(M, N)
find_nth(M, Tail, Elem).
find_nth(1, [Head|_], Head) :- !.
find_nth(N, [_|Tail], Elem) :-
M is N-1,
find_nth(M, Tail, Elem).
generate_nth(I, I, [Head|_], Head).
generate_nth(I, IN, [_|List], El) :-
I1 is I+1,
generate_nth(I1, IN, List, El).
% nth0(+N, ?List, ?Elem, ?Rest) unifies Elem with the Nth element of List,
% counting from 0, and Rest with the other elements. It can be used
% to select the Nth element of List (yielding Elem and Rest), or to
% insert Elem before the Nth (counting from 1) element of Rest, when
% it yields List, e.g. nth0(2, List, c, [a,b,d,e]) unifies List with
% [a,b,c,d,e]. nth is the same except that it counts from 1. nth
% can be used to insert Elem after the Nth element of Rest.
nth0(V, In, Element, Tail) :- var(V), !,
generate_nth(0, V, In, Element, Tail).
nth0(0, [Head|Tail], Head, Tail) :- !.
nth0(N, [Head|Tail], Elem, [Head|Rest]) :-
M is N-1,
nth0(M, Tail, Elem, Rest).
find_nth0(0, [Head|Tail], Head, Tail) :- !.
find_nth0(N, [Head|Tail], Elem, [Head|Rest]) :-
M is N-1,
find_nth0(M, Tail, Elem, Rest).
nth1(V, In, Element, Tail) :- var(V), !,
generate_nth(1, V, In, Element, Tail).
nth1(1, [Head|Tail], Head, Tail) :- !.
nth1(N, [Head|Tail], Elem, [Head|Rest]) :-
M is N-1,
nth1(M, Tail, Elem, Rest).
nth(V, In, Element, Tail) :- var(V), !,
generate_nth(1, V, In, Element, Tail).
nth(1, [Head|Tail], Head, Tail) :- !.
nth(N, [Head|Tail], Elem, [Head|Rest]) :-
M is N-1,
nth(M, Tail, Elem, Rest).
find_nth(1, [Head|Tail], Head, Tail) :- !.
find_nth(N, [Head|Tail], Elem, [Head|Rest]) :-
M is N-1,
find_nth(M, Tail, Elem, Rest).
generate_nth(I, I, [Head|Tail], Head, Tail).
generate_nth(I, IN, [E|List], El, [E|Tail]) :-
I1 is I+1,
generate_nth(I1, IN, List, El, Tail).
% permutation(List, Perm)
% is true when List and Perm are permutations of each other. Of course,
% if you just want to test that, the best way is to keysort/2 the two
% lists and see if the results are the same. Or you could use list_to_bag
% (from BagUtl.Pl) to see if they convert to the same bag. The point of
% perm is to generate permutations. The arguments may be either way round,
% the only effect will be the order in which the permutations are tried.
% Be careful: this is quite efficient, but the number of permutations of an
% N-element list is N!, even for a 7-element list that is 5040.
permutation([], []).
permutation(List, [First|Perm]) :-
select(First, List, Rest), % tries each List element in turn
permutation(Rest, Perm).
% prefix(Part, Whole) iff Part is a leading substring of Whole
prefix([], _).
prefix([Elem | Rest_of_part], [Elem | Rest_of_whole]) :-
prefix(Rest_of_part, Rest_of_whole).
% remove_duplicates(List, Pruned)
% removes duplicated elements from List. Beware: if the List has
% non-ground elements, the result may surprise you.
remove_duplicates([], []).
remove_duplicates([Elem|L], [Elem|NL]) :-
delete(L, Elem, Temp),
remove_duplicates(Temp, NL).
% reverse(List, Reversed)
% is true when List and Reversed are lists with the same elements
% but in opposite orders. rev/2 is a synonym for reverse/2.
reverse(List, Reversed) :-
reverse(List, [], Reversed).
reverse([], Reversed, Reversed).
reverse([Head|Tail], Sofar, Reversed) :-
reverse(Tail, [Head|Sofar], Reversed).
% same_length(?List1, ?List2)
% is true when List1 and List2 are both lists and have the same number
% of elements. No relation between the values of their elements is
% implied.
% Modes same_length(-,+) and same_length(+,-) generate either list given
% the other; mode same_length(-,-) generates two lists of the same length,
% in which case the arguments will be bound to lists of length 0, 1, 2, ...
same_length([], []).
same_length([_|List1], [_|List2]) :-
same_length(List1, List2).
/** @pred selectchk(? _Element_, ? _List_, ? _Residue_)
Semi-deterministic selection from a list. Steadfast: defines as
~~~~~{.prolog}
selectchk(Elem, List, Residue) :-
select(Elem, List, Rest0), !,
Rest = Rest0.
~~~~~
*/
selectchk(Elem, List, Rest) :-
select(Elem, List, Rest0), !,
Rest = Rest0.
/** @pred select(? _Element_, ? _List_, ? _Residue_)
True when _Set_ is a list, _Element_ occurs in _List_, and
_Residue_ is everything in _List_ except _Element_ (things
stay in the same order).
*/
select(Element, [Element|Rest], Rest).
select(Element, [Head|Tail], [Head|Rest]) :-
select(Element, Tail, Rest).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% sublist(?Sub, +List) is nondet.
%
% True if all elements of Sub appear in List in the same order.
%
% ALlo, both `append(_,Sublist,S)` and `append(S,_,List)` hold.
sublist(L, L).
sublist(Sub, [H|T]) :-
'$sublist1'(T, H, Sub).
'$sublist1'(Sub, _, Sub).
'$sublist1'([H|T], _, Sub) :-
'$sublist1'(T, H, Sub).
'$sublist1'([H|T], X, [X|Sub]) :-
'$sublist1'(T, H, Sub).
% substitute(X, XList, Y, YList)
% is true when XList and YList only differ in that the elements X in XList
% are replaced by elements Y in the YList.
substitute(X, XList, Y, YList) :-
substitute2(XList, X, Y, YList).
substitute2([], _, _, []).
substitute2([X0|XList], X, Y, [Y|YList]) :-
X == X0, !,
substitute2(XList, X, Y, YList).
substitute2([X0|XList], X, Y, [X0|YList]) :-
substitute2(XList, X, Y, YList).
/** @pred suffix(? _Suffix_, ? _List_)
Holds when `append(_,Suffix,List)` holds.
*/
suffix(Suffix, Suffix).
suffix(Suffix, [_|List]) :-
suffix(Suffix,List).
/** @pred sumlist(? _Numbers_, ? _Total_)
True when _Numbers_ is a list of integers, and _Total_ is their
sum. The same as sum_list/2, please do use sum_list/2
instead.
*/
sumlist(Numbers, Total) :-
sumlist(Numbers, 0, Total).
/** @pred sum_list(? _Numbers_, + _SoFar_, ? _Total_)
True when _Numbers_ is a list of numbers, and _Total_ is the sum of their total plus _SoFar_.
*/
sum_list(Numbers, SoFar, Total) :-
sumlist(Numbers, SoFar, Total).
/** @pred sum_list(? _Numbers_, ? _Total_)
True when _Numbers_ is a list of numbers, and _Total_ is their sum.
*/
sum_list(Numbers, Total) :-
sumlist(Numbers, 0, Total).
sumlist([], Total, Total).
sumlist([Head|Tail], Sofar, Total) :-
Next is Sofar+Head,
sumlist(Tail, Next, Total).
% list_concat(Lists, List)
% is true when Lists is a list of lists, and List is the
% concatenation of these lists.
list_concat([], []).
list_concat([H|T], L) :-
list_concat(H, L, Li),
list_concat(T, Li).
list_concat([], L, L).
list_concat([H|T], [H|Lf], Li) :-
list_concat(T, Lf, Li).
/** @pred flatten(+ _List_, ? _FlattenedList_)
Flatten a list of lists _List_ into a single list
_FlattenedList_.
~~~~~{.prolog}
?- flatten([[1],[2,3],[4,[5,6],7,8]],L).
L = [1,2,3,4,5,6,7,8] ? ;
no
~~~~~
*/
flatten(X,Y) :- flatten_list(X,Y,[]).
flatten_list(V) --> {var(V)}, !, [V].
flatten_list([]) --> !.
flatten_list([H|T]) --> !, flatten_list(H),flatten_list(T).
flatten_list(H) --> [H].
max_list([H|L],Max) :-
max_list(L,H,Max).
max_list([],Max,Max).
max_list([H|L],Max0,Max) :-
(
H > Max0
->
max_list(L,H,Max)
;
max_list(L,Max0,Max)
).
min_list([H|L],Max) :-
min_list(L,H,Max).
min_list([],Max,Max).
min_list([H|L],Max0,Max) :-
(
H < Max0
->
min_list(L, H, Max)
;
min_list(L, Max0, Max)
).
%% numlist(+Low, +High, -List) is semidet.
%
% List is a list [Low, Low+1, ... High]. Fails if High < Low.%
%
% @error type_error(integer, Low)
% @error type_error(integer, High)
numlist(L, U, Ns) :-
must_be(integer, L),
must_be(integer, U),
L =< U,
numlist_(L, U, Ns).
numlist_(U, U, OUT) :- !, OUT = [U].
numlist_(L, U, [L|Ns]) :-
succ(L, L2),
numlist_(L2, U, Ns).
/** @pred intersection(+ _Set1_, + _Set2_, + _Set3_)
Succeeds if _Set3_ unifies with the intersection of _Set1_ and
_Set2_. _Set1_ and _Set2_ are lists without duplicates. They
need not be ordered.
The code was copied from SWI-Prolog's list library.
*/
% copied from SWI lists library.
intersection([], _, []) :- !.
intersection([X|T], L, Intersect) :-
memberchk(X, L), !,
Intersect = [X|R],
intersection(T, L, R).
intersection([_|T], L, R) :-
intersection(T, L, R).
%% subtract(+Set, +Delete, -Result) is det.
%
% Delete all elements from `Set' that occur in `Delete' (a set)
% and unify the result with `Result'. Deletion is based on
% unification using memberchk/2. The complexity is |Delete|*|Set|.
%
% @see ord_subtract/3.
subtract([], _, []) :- !.
subtract([E|T], D, R) :-
memberchk(E, D), !,
subtract(T, D, R).
subtract([H|T], D, [H|R]) :-
subtract(T, D, R).
%% list_to_set(+List, ?Set) is det.
%
% True when Set has the same element as List in the same order.
% The left-most copy of the duplicate is retained. The complexity
% of this operation is |List|^2.
%
% @see sort/2.
list_to_set(List, Set) :-
list_to_set_(List, Set0),
Set = Set0.
list_to_set_([], R) :-
close_list(R).
list_to_set_([H|T], R) :-
memberchk(H, R), !,
list_to_set_(T, R).
close_list([]) :- !.
close_list([_|T]) :-
close_list(T).
%% @}
/** @} */

View File

@@ -1,188 +0,0 @@
/**
* @file log2md.yap
* @author Vitor Santos Costa
*
*
*/
:- op(650,yfx, <-- ),
op(650,yfx, <-* ).
:- module( log2md,
[open_log/1,
log_title/1,
log_section/1,
log_subsection/1,
log_paragraph/1,
log_unit/2,
(<--)/2,
(<-*)/2,
log_goal/1,
log_goal/1 as log_clause,
out/1,
out/2,
outln/1,
outln/2] ).
:- use_module( library( maplist) ).
/**
*
*
* @defgroup Log2MD Log Output of Tests in Markdown format.
*
* @ingroup Regression System Tests
*
* These primitives support writing a user-specified log of execution to an
* output file. The output file can be used for testing or debugging.
*
* Primitives include the ability to write a title, a Prolog clause or
* goal, and hooks for tracing calls. The log_goal/2 can be used to
* start a goal. Arguments of the form `<--/2` and `*->/2` can be used to
* track calls.
*
* The output format is markdown.
*/
open_log(F) :-
open( F, write, _Out, [alias(log)]).
/**
* @pred log_title( +String ) is det
*
* @param [in] S is a Prolog atom or string describing a title.
*
*/
log_title( S ) :-
out( '## Report on ~a~n~n', [S]).
/**
* @pred log_section( +String ) is det
*
* @param [in] S is a Prolog atom or string describing a title.
*
*/
log_section( S ) :-
out( '### Report on ~a~n~n', [S]).
/**
* @pred log_section( +String ) is det
*
* @param [in] S is a Prolog atom or string describing a title.
*
*/
log_subsection( S ) :-
out( '#### Report on ~a~n~n', [S]).
/**
* @pred log_section( +String ) is det
*
* @param [in] S is a Prolog atom or string describing a title.
*
*/
log_paragraph( S ) :-
out( '##### Report on ~a~n~n', [S]).
/**
* @pred log_unit( +String, + Level ) is det
*
* @param [in] _String_ is a Prolog atom or string describing a title
* @param [in] _Level_ is an integer number larager than 1 (do notice that )
*large numbers may be ignored ).
*
*
*/
log_unit( S ) :-
out( '## Report on ~a~n~n', [S]).
/**
* @pred clause( +Term ) is det
*
* @param [in] Term is a Prolog clause or goal that it is going to
* be printed out using portray_clause/2.
*
*/
log_goal( DecoratedClause ) :-
take_decorations(DecoratedClause, Clause),
out( '~~~~~~~~{.prolog}~n'),
portray_clause( user_error , Clause ),
portray_clause( log , Clause ),
out( '~~~~~~~~~n', []).
take_decorations( G, G ) :-
var(G),
!.
take_decorations(_ <-- G, NG ) :-
!,
take_decorations( G, NG ).
take_decorations(_ <-* G, NG ) :-
!,
take_decorations( G, NG ).
take_decorations(G, NG ) :-
G =.. [F|Args],
maplist( take_decorations, Args, NArgs ),
NG =.. [F|NArgs].
:- meta_predicate ( + <-- 0 ),
( + <-* 0 ).
/**
* @pred log_goal( +Tag , :Goal )
*
* @param [in] evaluate goal _Goal_ with output before,
* during and after the goal has been evaluated.
*
*/
A <-* Goal :-
(
outln(A),
log_goal( Goal ),
call( Goal )
*->
out('succeded as~n'), log_goal(Goal)
;
out( 'failed~n'),
fail
).
/**
* @pred `<--`( +Tag , :Goal )
*
* @param [in] output goal _Goal_ before and after being evaluated, but only
* taking the first solution. The _Tag_ must be an atom or a string.
*
*/
Tag <-- Goal :-
(
outln(Tag),
log_goal( Goal ),
call( Goal )
->
out('succeded as~n'),
log_goal(Goal),
fail
;
out(failed)
).
/**
* @pred out(+Format, +Args)
*
* @param [in] format the string given Args . The output is sent to
* user_error and to a stream with alias `log`;
*
*/
out(Format, Args) :-
format( log, Format, Args),
format( user_error, Format, Args).
out(Format) :-
format( log, Format, []),
format( user_error, Format, []).
outln(Format, Args) :-
out(Format, Args), out('~n').
outln(Format) :-
out(Format), out('~n').

View File

@@ -1,384 +0,0 @@
/**
* @file library/mapargs.yap
* @author Lawrence Byrd + Richard A. O'Keefe, VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @author : E. Alphonse from code by Joachim Schimpf, Jan Wielemaker, Vitor Santos Costa
* @date 4 August 1984 and Ken Johnson 11-8-87
*
* @brief Macros to apply a predicate to all sub-terms of a term.
*
*
*/
:- module(mapargs,[ mapargs/2, % :Goal, +S
mapargs/3, % :Goal, +S, -S
mapargs/4, % :Goal, +S, -S1, -S2
mapargs/5, % :Goal, +S, -S1, -S2, -S3
mapargs/6, % :Goal, +S, -S1, -S2, -S3, -S4
sumargs/4,
foldargs/4, % :Pred, +S, ?V0, ?V
foldargs/5, % :Pred, +S, ?S1, ?V0, ?V
foldargs/6, % :Pred, +S, ?S1, ?S2, ?V0, ?V
foldargs/7 % :Pred, +S, ?S1, ?S2, ?S3, ?V0, ?V
]).
/**
* @defgroup mapargs Apply a predicate to all arguments of a term
* @ingroup library
*/
:- use_module(library(maputils)).
:- use_module(library(lists), [append/3]).
:- meta_predicate
mapargs(1,+),
mapargs_args(1,+,+),
mapargs(2,+,-),
mapargs_args(2,+,-,+),
mapargs(3,+,-,-),
mapargs_args(2,+,-,-,+),
mapargs(4,+,-,-,-),
mapargs_args(2,+,-,-,-,+),
mapargs(5,+,-,-,-,-),
mapargs_args(2,+,-,-,-,-,+),
sumargs(3,+,+,-),
sumargs_args(3,+,+,-,+),
foldargs(3, +, +, -),
foldargs(4, +, ?, +, -),
foldargs(5, +, ?, ?, +, -),
foldargs(6, +, ?, ?, ?, +, -).
mapargs(Pred, TermIn) :-
functor(TermIn, _F, N),
mapargs_args(Pred, TermIn, 0, N).
mapargs_args(Pred, TermIn, I, N) :-
( I == N -> true ;
I1 is I+1,
arg(I1, TermIn, InArg),
call(Pred, InArg),
mapargs_args(Pred, TermIn, I1, N) ).
mapargs(Pred, TermIn, TermOut) :-
functor(TermIn, F, N),
functor(TermOut, F, N),
mapargs_args(Pred, TermIn, TermOut, 0, N).
mapargs_args(Pred, TermIn, TermOut, I, N) :-
( I == N -> true ;
I1 is I+1,
arg(I1, TermIn, InArg),
arg(I1, TermOut, OutArg),
call(Pred, InArg, OutArg),
mapargs_args(Pred, TermIn, TermOut, I1, N) ).
mapargs(Pred, TermIn, TermOut1, TermOut2) :-
functor(TermIn, F, N),
functor(TermOut1, F, N),
functor(TermOut2, F, N),
mapargs_args(Pred, TermIn, TermOut1, TermOut2, 0, N).
mapargs_args(Pred, TermIn, TermOut1, TermOut2, I, N) :-
( I == N -> true ;
I1 is I+1,
arg(I1, TermIn, InArg),
arg(I1, TermOut1, OutArg1),
arg(I1, TermOut2, OutArg2),
call(Pred, InArg, OutArg1, OutArg2),
mapargs_args(Pred, TermIn, TermOut1, TermOut2, I1, N) ).
mapargs(Pred, TermIn, TermOut1, TermOut2, TermOut3) :-
functor(TermIn, F, N),
functor(TermOut1, F, N),
functor(TermOut2, F, N),
mapargs_args(Pred, TermIn, TermOut1, TermOut2, TermOut3, 0, N).
mapargs_args(Pred, TermIn, TermOut1, TermOut2, TermOut3, I, N) :-
( I == N -> true ;
I1 is I+1,
arg(I1, TermIn, InArg),
arg(I1, TermOut1, OutArg1),
arg(I1, TermOut2, OutArg2),
arg(I1, TermOut3, OutArg3),
call(Pred, InArg, OutArg1, OutArg2, OutArg3),
mapargs_args(Pred, TermIn, TermOut1, TermOut2, TermOut3, I1, N) ).
mapargs(Pred, TermIn, TermOut1, TermOut2, TermOut3, TermOut4) :-
functor(TermIn, F, N),
functor(TermOut1, F, N),
functor(TermOut2, F, N),
functor(TermOut3, F, N),
functor(TermOut4, F, N),
mapargs_args(Pred, TermIn, TermOut1, TermOut2, TermOut3, TermOut4, 0, N).
mapargs_args(Pred, TermIn, TermOut1, TermOut2, TermOut3, TermOut4, I, N) :-
( I == 0 -> true ;
I1 is I+1,
arg(I1, TermIn, InArg),
arg(I1, TermOut1, OutArg1),
arg(I1, TermOut2, OutArg2),
arg(I1, TermOut3, OutArg3),
arg(I1, TermOut4, OutArg4),
call(Pred, InArg, OutArg1, OutArg2, OutArg3, OutArg4),
mapargs_args(Pred, TermIn, TermOut1, TermOut2, TermOut3, TermOut4, I1, N) ).
sumargs(Pred, Term, A0, A1) :-
functor(Term, _, N),
sumargs(Pred, Term, A0, A1, N).
sumargs_args(_, _, A0, A1, 0) :-
!,
A0 = A1.
sumargs_args(Pred, Term, A1, A3, N) :-
arg(N, Term, Arg),
N1 is N - 1,
call(Pred, Arg, A1, A2),
sumargs_args(Pred, Term, A2, A3, N1).
foldargs(Goal, S, V0, V) :-
functor(S, _, Ar),
foldargs_(Goal, S, V0, V, 0, Ar).
foldargs_(Goal, S, V0, V, I, N) :-
( I == N -> V0 = V ;
I1 is I+1,
arg(I1, S, A),
call(Goal, A, V0, V1),
foldargs_(Goal, S, V1, V, I1, N) ).
foldargs(Goal, S, O1, V0, V) :-
functor(S, N, Ar),
functor(O1, N, Ar),
foldargs_(Goal, S, O1, V0, V, 0, Ar).
foldargs_(Goal, S, O1, V0, V, I, N) :-
( I == N -> V0 = V ;
I1 is I+1,
arg(I1, S, A),
arg(I1, O1, A1),
call(Goal, A, A1, V0, V1),
foldargs_(Goal, S, O1, V1, V, I1, N) ).
foldargs(Goal, S, O1, O2, V0, V) :-
functor(S, N, Ar),
functor(O1, N, Ar),
functor(O2, N, Ar),
foldargs_(Goal, S, O1, O2, V0, V, 0, Ar).
foldargs_(Goal, S, O1, O2, V0, V, I, N) :-
( I == N -> V0 = V ;
I1 is I+1,
arg(I1, S, A),
arg(I1, O1, A1),
arg(I1, O2, A2),
call(Goal, A, A1, A2, V0, V1),
foldargs_(Goal, S, O1, O2, V1, V, I1, N) ).
foldargs(Goal, S, O1, O2, O3, V0, V) :-
functor(S, N, Ar),
functor(O1, N, Ar),
functor(O2, N, Ar),
functor(O3, N, Ar),
foldargs_(Goal, S, O1, O2, O3, V0, V, 0, Ar).
foldargs_(Goal, S, O1, O2, O3, V0, V, I, N) :-
( I == N -> V0 = V ;
I1 is I+1,
arg(I1, S, A),
arg(I1, O1, A1),
arg(I1, O2, A2),
arg(I1, O3, A3),
call(Goal, A, A1, A2, A3, V0, V1),
foldargs_(Goal, S, O1, O2, O3, V1, V, I1, N) ).
goal_expansion(mapargs(Meta, In), (functor(In, _Name, Ar), Mod:Goal)) :-
goal_expansion_allowed,
callable(Meta),
prolog_load_context(module, Mod),
aux_preds(Meta, MetaVars, Pred, PredVars, Proto),
!,
% the new goal
pred_name(mapargs, 1, Proto, GoalName),
append(MetaVars, [In, 0, Ar], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
% the new predicate declaration
append_args(HeadPrefix, [In, I, Ar], RecursionHead),
append_args(Pred, [AIn], Apply),
append_args(HeadPrefix, [In, I1, Ar], RecursiveCall),
compile_aux([
(RecursionHead :- I == 0 -> true ; I1 is I+1, arg(I1, In, AIn), Apply, RecursiveCall )
], Mod).
goal_expansion(mapargs(Meta, In, Out), (functor(In, Name, Ar), functor(Out, Name, Ar), Mod:Goal)) :-
goal_expansion_allowed,
callable(Meta),
prolog_load_context(module, Mod),
aux_preds(Meta, MetaVars, Pred, PredVars, Proto),
!,
% the new goal
pred_name(mapargs, 2, Proto, GoalName),
append(MetaVars, [In, Out, Ar], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
% the new predicate declaration
append_args(HeadPrefix, [In, Out, I], RecursionHead),
append_args(Pred, [AIn, AOut], Apply),
append_args(HeadPrefix, [In, Out, I1], RecursiveCall),
compile_aux([
(RecursionHead :- I == 0 -> true ; arg(I, In, AIn), arg(I, Out, AOut), Apply, I1 is I-1, RecursiveCall )
], Mod).
goal_expansion(mapargs(Meta, In, Out1, Out2), (functor(In, Name, Ar), functor(Out1, Name, Ar), functor(Out2, Name, Ar), Mod:Goal)) :-
goal_expansion_allowed,
callable(Meta),
prolog_load_context(module, Mod),
aux_preds(Meta, MetaVars, Pred, PredVars, Proto),
!,
% the new goal
pred_name(mapargs, 3, Proto, GoalName),
append(MetaVars, [In, Out1, Out2, Ar], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
% the new predicate declaration
append_args(HeadPrefix, [In, Out1, Out2, I], RecursionHead),
append_args(Pred, [AIn, AOut1, AOut2], Apply),
append_args(HeadPrefix, [In, Out1, Out2, I1], RecursiveCall),
compile_aux([
(RecursionHead :- I == 0 -> true ; arg(I, In, AIn), arg(I, Out1, AOut1), arg(I, Out2, AOut2), Apply, I1 is I-1, RecursiveCall )
], Mod).
goal_expansion(mapargs(Meta, In, Out1, Out2, Out3), (functor(In, Name, Ar), functor(Out1, Name, Ar), functor(Out3, Name, Ar), Mod:Goal)) :-
goal_expansion_allowed,
callable(Meta),
prolog_load_context(module, Mod),
aux_preds(Meta, MetaVars, Pred, PredVars, Proto),
!,
% the new goal
pred_name(mapargs, 4, Proto, GoalName),
append(MetaVars, [In, Out1, Out2, Out3, Ar], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
% the new predicate declaration
append_args(HeadPrefix, [In, Out1, Out2, Out3, I], RecursionHead),
append_args(Pred, [AIn, AOut1, AOut2, AOut3], Apply),
append_args(HeadPrefix, [In, Out1, Out2, Out3, I1], RecursiveCall),
compile_aux([
(RecursionHead :- I == 0 -> true ; arg(I, In, AIn), arg(I, Out1, AOut1), arg(I, Out2, AOut2), arg(I, Out3, AOut3), Apply, I1 is I-1, RecursiveCall )
], Mod).
goal_expansion(mapargs(Meta, In, Out1, Out2, Out3, Out4), (functor(In, Name, Ar), functor(Out1, Name, Ar), functor(Out3, Name, Ar), functor(Out4, Name, Ar), Mod:Goal)) :-
goal_expansion_allowed,
callable(Meta),
prolog_load_context(module, Mod),
aux_preds(Meta, MetaVars, Pred, PredVars, Proto),
!,
% the new goal
pred_name(mapargs, 4, Proto, GoalName),
append(MetaVars, [In, Out1, Out2, Out3, Out4, Ar], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
% the new predicate declaration
append_args(HeadPrefix, [In, Out1, Out2, Out3, Out4, I], RecursionHead),
append_args(Pred, [AIn, AOut1, AOut2, AOut3, AOut4], Apply),
append_args(HeadPrefix, [In, Out1, Out2, Out3, Out4, I1], RecursiveCall),
compile_aux([
(RecursionHead :- I == 0 -> true ; arg(I, In, AIn), arg(I, Out1, AOut1), arg(I, Out2, AOut2), arg(I, Out3, AOut3), arg(I, Out4, AOut4), Apply, I1 is I-1, RecursiveCall )
], Mod).
goal_expansion(sumargs(Meta, Term, AccIn, AccOut), Mod:Goal) :-
goal_expansion_allowed,
prolog_load_context(module, Mod),
Goal = (
Term =.. [_|TermArgs],
sumlist(Meta, TermArgs, AccIn, AccOut)
).
goal_expansion(foldargs(Meta, In, Acc0, AccF), (functor(In, _Name, Ar), Mod:Goal)) :-
goal_expansion_allowed,
callable(Meta),
prolog_load_context(module, Mod),
aux_preds(Meta, MetaVars, Pred, PredVars, Proto),
!,
% the new goal
pred_name(foldargs, 1, Proto, GoalName),
append(MetaVars, [In, Acc0, AccF, 0, Ar], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
% the new predicate declaration
append_args(HeadPrefix, [In, VAcc0, VAccF, I, Ar], RecursionHead),
append_args(Pred, [AIn, VAcc0, VAccI], Apply),
append_args(HeadPrefix, [In, VAccI, VAccF, I1, Ar], RecursiveCall),
compile_aux([
(RecursionHead :- I == Ar -> VAcc0 = VAccF ; I1 is I+1, arg(I1, In, AIn), Apply, RecursiveCall )
], Mod).
goal_expansion(foldargs(Meta, In, Out1, Acc0, AccF), (functor(In, Name, Ar), functor(Out1, Name, Ar), Mod:Goal)) :-
goal_expansion_allowed,
callable(Meta),
prolog_load_context(module, Mod),
aux_preds(Meta, MetaVars, Pred, PredVars, Proto),
!,
% the new goal
pred_name(foldargs, 2, Proto, GoalName),
append(MetaVars, [In, Out1, Acc0, AccF, 0, Ar], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
% the new predicate declaration
append_args(HeadPrefix, [In, Out1, VAcc0, VAccF, I, Ar], RecursionHead),
append_args(Pred, [AIn, AOut1, VAcc0, VAccI], Apply),
append_args(HeadPrefix, [In, Out1, VAccI, VAccF, I1, Ar], RecursiveCall),
compile_aux([
(RecursionHead :- I == Ar -> VAcc0 = VAccF ; I1 is I+1, arg(I1, In, AIn), arg(I1, Out1, AOut1), Apply, RecursiveCall )
], Mod).
goal_expansion(foldargs(Meta, In, Out1, Out2, Acc0, AccF), (functor(In, Name, Ar), functor(Out1, Name, Ar), functor(Out2, Name, Ar), Mod:Goal)) :-
goal_expansion_allowed,
callable(Meta),
prolog_load_context(module, Mod),
aux_preds(Meta, MetaVars, Pred, PredVars, Proto),
!,
% the new goal
pred_name(foldargs, 3, Proto, GoalName),
append(MetaVars, [In, Out1, Out2, Acc0, AccF, 0, Ar], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
% the new predicate declaration
append_args(HeadPrefix, [In, Out1, Out2, VAcc0, VAccF, I, Ar], RecursionHead),
append_args(Pred, [AIn, AOut1, AOut2, VAcc0, VAccI], Apply),
append_args(HeadPrefix, [In, Out1, Out2, VAccI, VAccF, I1, Ar], RecursiveCall),
compile_aux([
(RecursionHead :- I == Ar -> VAcc0 = VAccF ; I1 is I+1, arg(I1, In, AIn), arg(I1, Out1, AOut1), arg(I1, Out2, AOut2), Apply, RecursiveCall )
], Mod).
goal_expansion(foldargs(Meta, In, Out1, Out2, Out3, Acc0, AccF), (functor(In, Name, Ar), functor(Out1, Name, Ar), functor(Out2, Name, Ar), functor(Out3, Name, Ar), Mod:Goal)) :-
goal_expansion_allowed,
callable(Meta),
prolog_load_context(module, Mod),
aux_preds(Meta, MetaVars, Pred, PredVars, Proto),
!,
% the new goal
pred_name(foldargs, 4, Proto, GoalName),
append(MetaVars, [In, Out1, Out2, Out3, Acc0, AccF, 0, Ar], GoalArgs),
Goal =.. [GoalName|GoalArgs],
% the new predicate declaration
HeadPrefix =.. [GoalName|PredVars],
% the new predicate declaration
append_args(HeadPrefix, [In, Out1, Out2, Out3, VAcc0, VAccF, I, Ar], RecursionHead),
append_args(Pred, [AIn, AOut1, AOut2, AOut3, VAcc0, VAccI], Apply),
append_args(HeadPrefix, [In, Out1, Out2, Out3, VAccI, VAccF, I1, Ar], RecursiveCall),
compile_aux([
(RecursionHead :- I == Ar -> VAcc0 = VAccF ; I1 is I+1, arg(I1, In, AIn), arg(I1, Out1, AOut1), arg(I1, Out2, AOut2), arg(I1, Out3, AOut3), Apply, RecursiveCall )
], Mod).

File diff suppressed because it is too large Load Diff

View File

@@ -1,106 +0,0 @@
/**
* @file maputils.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 22:48:58 2015
*
* @brief Auxiliary routines for map... libraries
*
*
*/
%%%%%%%%%%%%%%%%%%%%
% map utilities
%%%%%%%%%%%%%%%%%%%%
:- module(maputils,
[compile_aux/2,
goal_expansion_allowed/0,
pred_name/4,
aux_preds/5,
append_args/3]).
/**
* @addtogroup maplist
*
* Auxiliary routines
*
*@{
*/
:- use_module(library(lists), [append/3]).
:- dynamic number_of_expansions/1.
number_of_expansions(0).
%
% compile auxiliary routines for term expansion
%
compile_aux([Clause|Clauses], Module) :-
% compile the predicate declaration if needed
( Clause = (Head :- _)
; Clause = Head ),
!,
functor(Head, F, N),
( current_predicate(Module:F/N)
->
true
;
% format("*** Creating auxiliary predicate ~q~n", [F/N]),
% checklist(portray_clause, [Clause|Clauses]),
compile_term([Clause|Clauses], Module)
).
compile_term([], _).
compile_term([Clause|Clauses], Module) :-
assert_static(Module:Clause),
compile_term(Clauses, Module).
append_args(Term, Args, NewTerm) :-
Term =.. [Meta|OldArgs],
append(OldArgs, Args, GoalArgs),
NewTerm =.. [Meta|GoalArgs].
aux_preds(Meta, _, _, _, _) :-
var(Meta), !,
fail.
aux_preds(_:Meta, MetaVars, Pred, PredVars, Proto) :- !,
aux_preds(Meta, MetaVars, Pred, PredVars, Proto).
aux_preds(Meta, MetaVars, Pred, PredVars, Proto) :-
Meta =.. [F|Args],
aux_args(Args, MetaVars, PredArgs, PredVars, ProtoArgs),
Pred =.. [F|PredArgs],
Proto =.. [F|ProtoArgs].
aux_args([], [], [], [], []).
aux_args([Arg|Args], MVars, [Arg|PArgs], PVars, [Arg|ProtoArgs]) :-
ground(Arg), !,
aux_args(Args, MVars, PArgs, PVars, ProtoArgs).
aux_args([Arg|Args], [Arg|MVars], [PVar|PArgs], [PVar|PVars], ['_'|ProtoArgs]) :-
aux_args(Args, MVars, PArgs, PVars, ProtoArgs).
pred_name(Macro, Arity, _ , Name) :-
prolog_load_context(file, FullFileName),
file_base_name( FullFileName, File ),
prolog_load_context(term_position, Pos),
stream_position_data( line_count, Pos, Line ), !,
transformation_id(Id),
atomic_concat(['$$$ for ',Macro,'/',Arity,', line ',Line,' in ',File,' ',Id], Name).
pred_name(Macro, Arity, _ , Name) :-
transformation_id(Id),
atomic_concat(['$$$__expansion__ for ',Macro,'/',Arity,' ',Id], Name).
transformation_id(Id) :-
retract(number_of_expansions(Id)),
Id1 is Id+1,
assert(number_of_expansions(Id1)).
%% goal_expansion_allowed is semidet.
%
% `True` if we can use
% goal-expansion.
goal_expansion_allowed :-
once( prolog_load_context(_, _) ), % make sure we are compiling.
\+ current_prolog_flag(xref, true).
/**
@}
*/

View File

@@ -1,328 +0,0 @@
/**
* @file matlab.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 22:51:48 2015
*
* @brief YAP Matlab interface.
*
*
*/
:- module(matlab,
[start_matlab/1,
close_matlab/0,
matlab_on/0,
matlab_eval_string/1,
matlab_eval_string/2,
matlab_cells/2,
matlab_cells/3,
matlab_initialized_cells/4,
matlab_zeros/2,
matlab_zeros/3,
matlab_zeros/4,
matlab_matrix/4,
matlab_vector/2,
matlab_vector/3,
matlab_set/4,
matlab_get_variable/2,
matlab_item/3,
matlab_item/4,
matlab_item1/3,
matlab_item1/4,
matlab_sequence/3,
matlab_call/2]).
/** @defgroup matlab MATLAB Package Interface
@ingroup library
@{
The MathWorks MATLAB is a widely used package for array
processing. YAP now includes a straightforward interface to MATLAB. To
actually use it, you need to install YAP calling `configure` with
the `--with-matlab=DIR` option, and you need to call
`use_module(library(lists))` command.
Accessing the matlab dynamic libraries can be complicated. In Linux
machines, to use this interface, you may have to set the environment
variable <tt>LD_LIBRARY_PATH</tt>. Next, follows an example using bash in a
64-bit Linux PC:
~~~~~
export LD_LIBRARY_PATH=''$MATLAB_HOME"/sys/os/glnxa64:''$MATLAB_HOME"/bin/glnxa64:''$LD_LIBRARY_PATH"
~~~~~
where `MATLAB_HOME` is the directory where matlab is installed
at. Please replace `ax64` for `x86` on a 32-bit PC.
*/
/*
@pred start_matlab(+ _Options_)
Start a matlab session. The argument _Options_ may either be the
empty string/atom or the command to call matlab. The command may fail.
*/
/** @pred close_matlab
Stop the current matlab session.
*/
/** @pred matlab_cells(+ _SizeX_, + _SizeY_, ? _Array_)
MATLAB will create an empty array of cells of size _SizeX_ and
_SizeY_, and if _Array_ is bound to an atom, store the array
in the matlab variable with name _Array_. Corresponds to the
MATLAB command `cells`.
*/
/** @pred matlab_cells(+ _Size_, ? _Array_)
MATLAB will create an empty vector of cells of size _Size_, and if
_Array_ is bound to an atom, store the array in the matlab
variable with name _Array_. Corresponds to the MATLAB command `cells`.
*/
/** @pred matlab_eval_string(+ _Command_)
Holds if matlab evaluated successfully the command _Command_.
*/
/** @pred matlab_eval_string(+ _Command_, - _Answer_)
MATLAB will evaluate the command _Command_ and unify _Answer_
with a string reporting the result.
*/
/** @pred matlab_get_variable(+ _MatVar_, - _List_)
Unify MATLAB variable _MatVar_ with the List _List_.
*/
/** @pred matlab_initialized_cells(+ _SizeX_, + _SizeY_, + _List_, ? _Array_)
MATLAB will create an array of cells of size _SizeX_ and
_SizeY_, initialized from the list _List_, and if _Array_
is bound to an atom, store the array in the matlab variable with name
_Array_.
*/
/** @pred matlab_item(+ _MatVar_, + _X_, + _Y_, ? _Val_)
Read or set MATLAB _MatVar_( _X_, _Y_) from/to _Val_. Use
`C` notation for matrix access (ie, starting from 0).
*/
/** @pred matlab_item(+ _MatVar_, + _X_, ? _Val_)
Read or set MATLAB _MatVar_( _X_) from/to _Val_. Use
`C` notation for matrix access (ie, starting from 0).
*/
/** @pred matlab_item1(+ _MatVar_, + _X_, + _Y_, ? _Val_)
Read or set MATLAB _MatVar_( _X_, _Y_) from/to _Val_. Use
MATLAB notation for matrix access (ie, starting from 1).
*/
/** @pred matlab_item1(+ _MatVar_, + _X_, ? _Val_)
Read or set MATLAB _MatVar_( _X_) from/to _Val_. Use
MATLAB notation for matrix access (ie, starting from 1).
*/
/** @pred matlab_matrix(+ _SizeX_, + _SizeY_, + _List_, ? _Array_)
MATLAB will create an array of floats of size _SizeX_ and _SizeY_,
initialized from the list _List_, and if _Array_ is bound to
an atom, store the array in the matlab variable with name _Array_.
*/
/** @pred matlab_on
Holds if a matlab session is on.
*/
/** @pred matlab_sequence(+ _Min_, + _Max_, ? _Array_)
MATLAB will create a sequence going from _Min_ to _Max_, and
if _Array_ is bound to an atom, store the sequence in the matlab
variable with name _Array_.
*/
/** @pred matlab_set(+ _MatVar_, + _X_, + _Y_, + _Value_)
Call MATLAB to set element _MatVar_( _X_, _Y_) to
_Value_. Notice that this command uses the MATLAB array access
convention.
*/
/** @pred matlab_vector(+ _Size_, + _List_, ? _Array_)
MATLAB will create a vector of floats of size _Size_, initialized
from the list _List_, and if _Array_ is bound to an atom,
store the array in the matlab variable with name _Array_.
*/
/** @pred matlab_zeros(+ _SizeX_, + _SizeY_, + _SizeZ_, ? _Array_)
MATLAB will create an array of zeros of size _SizeX_, _SizeY_,
and _SizeZ_. If _Array_ is bound to an atom, store the array
in the matlab variable with name _Array_. Corresponds to the
MATLAB command `zeros`.
*/
/** @pred matlab_zeros(+ _SizeX_, + _SizeY_, ? _Array_)
MATLAB will create an array of zeros of size _SizeX_ and
_SizeY_, and if _Array_ is bound to an atom, store the array
in the matlab variable with name _Array_. Corresponds to the
MATLAB command `zeros`.
*/
/** @pred matlab_zeros(+ _Size_, ? _Array_)
MATLAB will create a vector of zeros of size _Size_, and if
_Array_ is bound to an atom, store the array in the matlab
variable with name _Array_. Corresponds to the MATLAB command
`zeros`.
*/
:- ensure_loaded(library(lists)).
tell_warning :-
print_message(warning,functionality(matlab)).
:- ( catch(load_foreign_files([matlab], ['eng','mx','ut'], init_matlab),_,fail) -> true ; tell_warning).
matlab_eval_sequence(S) :-
atomic_concat(S,S1),
matlab_eval_string(S1).
matlab_eval_sequence(S,O) :-
atomic_concat(S,S1),
matlab_eval_string(S1,O).
matlab_vector( Vec, L) :-
length(Vec, LV),
matlab_vector(LV, Vec, L).
matlab_sequence(Min,Max,L) :-
mksequence(Min,Max,Vector),
Dim is (Max-Min)+1,
matlab_matrix(1,Dim,Vector,L).
mksequence(Min,Min,[Min]) :- !.
mksequence(Min,Max,[Min|Vector]) :-
Min1 is Min+1,
mksequence(Min1,Max,Vector).
matlab_call(S,Out) :-
S=..[Func|Args],
build_args(Args,L0,[]),
process_arg_entry(L0,L),
build_output(Out,Lf,['= ',Func|L]),
atomic_concat(Lf,Command),
matlab_eval_string(Command).
matlab_call(S,Out,Result) :-
S=..[Func|Args],
build_args(Args,L0,[]),
process_arg_entry(L0,L),
build_output(Out,Lf,[' = ',Func|L]),
atomic_concat(Lf,Command),
matlab_eval_string(Command,Result).
build_output(Out,['[ '|L],L0) :-
is_list(Out), !,
build_outputs(Out,L,[']'|L0]).
build_output(Out,Lf,L0) :-
build_arg(Out,Lf,L0).
build_outputs([],L,L).
build_outputs([Out|Outs],[Out,' '|L],L0) :-
build_outputs(Outs,L,L0).
build_args([],L,L).
build_args([Arg],Lf,L0) :- !,
build_arg(Arg,Lf,[')'|L0]).
build_args([Arg|Args],L,L0) :-
build_arg(Arg,L,[', '|L1]),
build_args(Args,L1,L0).
build_arg(V,_,_) :- var(V), !,
throw(error(instantiation_error)).
build_arg(Arg,[Arg|L],L) :- atomic(Arg), !.
build_arg(\S0,['\'',S0,'\''|L],L) :-
atom(S0), !.
build_arg([S1|S2],['['|L],L0) :-
is_list(S2), !,
build_arglist([S1|S2],L,L0).
build_arg([S1|S2],L,L0) :- !,
build_arg(S1,L,['.'|L1]),
build_arg(S2,L1,L0).
build_arg(S1:S2,L,L0) :- !,
build_arg(S1,L,[':'|L1]),
build_arg(S2,L1,L0).
build_arg(F,[N,'{'|L],L0) :- %N({A}) = N{A}
F=..[N,{A}], !,
build_arg(A,L,['}'|L0]).
build_arg(F,[N,'('|L],L0) :-
F=..[N|As],
build_args(As,L,L0).
build_arglist([A],L,L0) :- !,
build_arg(A,L,[' ]'|L0]).
build_arglist([A|As],L,L0) :-
build_arg(A,L,[' ,'|L1]),
build_arglist(As,L1,L0).
build_string([],['\''|L],L).
build_string([S0|S],[C|Lf],L0) :-
char_code(C,S0),
build_string(S,Lf,L0).
process_arg_entry([],[]) :- !.
process_arg_entry(L,['('|L]).
/** @} */

File diff suppressed because it is too large Load Diff

View File

@@ -1,232 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: nb.yap *
* Last rev: 5/12/99 *
* mods: *
* comments: non-backtrackable data-structures *
* *
*************************************************************************/
/**
* @file nb.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 23:18:13 2015
*
* @brief stub for global (non-backtrackable) variables.
*
*
*/
:- module(nb, [
nb_create_accumulator/2,
nb_add_to_accumulator/2,
nb_accumulator_value/2,
nb_queue/1,
nb_queue/2,
nb_queue_close/3,
nb_queue_enqueue/2,
nb_queue_dequeue/2,
nb_queue_peek/2,
nb_queue_empty/1,
nb_queue_size/2,
nb_queue_replace/3,
nb_heap/2,
nb_heap_close/1,
nb_heap_add/3,
nb_heap_del/3,
nb_heap_peek/3,
nb_heap_empty/1,
nb_heap_size/2,
nb_beam/2,
nb_beam_close/1,
nb_beam_add/3,
nb_beam_del/3,
nb_beam_peek/3,
nb_beam_empty/1,
% nb_beam_check/1,
nb_beam_size/2]).
/** @defgroup nb Non-Backtrackable Data Structures
@ingroup library
@{
The following routines implement well-known data-structures using global
non-backtrackable variables (implemented on the Prolog stack). The
data-structures currently supported are Queues, Heaps, and Beam for Beam
search. They are allowed through `library(nb)`.
*/
/** @pred nb_beam(+ _DefaultSize_,- _Beam_)
Create a _Beam_ with default size _DefaultSize_. Note that size
is fixed throughout.
*/
/** @pred nb_beam_add(+ _Beam_, + _Key_, + _Value_)
Add _Key_- _Value_ to the beam _Beam_. The key is sorted on
_Key_ only.
*/
/** @pred nb_beam_close(+ _Beam_)
Close the beam _Beam_: no further elements can be added.
*/
/** @pred nb_beam_del(+ _Beam_, - _Key_, - _Value_)
Remove element _Key_- _Value_ with smallest _Value_ in beam
_Beam_. Fail if the beam is empty.
*/
/** @pred nb_beam_empty(+ _Beam_)
Succeeds if _Beam_ is empty.
*/
/** @pred nb_beam_peek(+ _Beam_, - _Key_, - _Value_))
_Key_- _Value_ is the element with smallest _Key_ in the beam
_Beam_. Fail if the beam is empty.
*/
/** @pred nb_beam_size(+ _Beam_, - _Size_)
Unify _Size_ with the number of elements in the beam _Beam_.
*/
/** @pred nb_heap(+ _DefaultSize_,- _Heap_)
Create a _Heap_ with default size _DefaultSize_. Note that size
will expand as needed.
*/
/** @pred nb_heap_add(+ _Heap_, + _Key_, + _Value_)
Add _Key_- _Value_ to the heap _Heap_. The key is sorted on
_Key_ only.
*/
/** @pred nb_heap_close(+ _Heap_)
Close the heap _Heap_: no further elements can be added.
*/
/** @pred nb_heap_del(+ _Heap_, - _Key_, - _Value_)
Remove element _Key_- _Value_ with smallest _Value_ in heap
_Heap_. Fail if the heap is empty.
*/
/** @pred nb_heap_empty(+ _Heap_)
Succeeds if _Heap_ is empty.
*/
/** @pred nb_heap_peek(+ _Heap_, - _Key_, - _Value_))
_Key_- _Value_ is the element with smallest _Key_ in the heap
_Heap_. Fail if the heap is empty.
*/
/** @pred nb_heap_size(+ _Heap_, - _Size_)
Unify _Size_ with the number of elements in the heap _Heap_.
*/
/** @pred nb_queue(- _Queue_)
Create a _Queue_.
*/
/** @pred nb_queue_close(+ _Queue_, - _Head_, ? _Tail_)
Unify the queue _Queue_ with a difference list
_Head_- _Tail_. The queue will now be empty and no further
elements can be added.
*/
/** @pred nb_queue_dequeue(+ _Queue_, - _Element_)
Remove _Element_ from the front of the queue _Queue_. Fail if
the queue is empty.
*/
/** @pred nb_queue_empty(+ _Queue_)
Succeeds if _Queue_ is empty.
*/
/** @pred nb_queue_enqueue(+ _Queue_, + _Element_)
Add _Element_ to the front of the queue _Queue_.
*/
/** @pred nb_queue_peek(+ _Queue_, - _Element_)
_Element_ is the front of the queue _Queue_. Fail if
the queue is empty.
*/
/** @pred nb_queue_size(+ _Queue_, - _Size_)
Unify _Size_ with the number of elements in the queue _Queue_.
*/
/** @} */

View File

@@ -1,501 +0,0 @@
/**
* @file ordsets.yap
* @author : R.A.O'Keefe
* @date 22 May 1983
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date 1999
* @brief
*
*
*/
% This file has been included as an YAP library by Vitor Santos Costa, 1999
:- module(ordsets, [
list_to_ord_set/2, % List -> Set
merge/3, % OrdList x OrdList -> OrdList
ord_add_element/3, % Set x Elem -> Set
ord_del_element/3, % Set x Elem -> Set
ord_disjoint/2, % Set x Set ->
ord_insert/3, % Set x Elem -> Set
ord_member/2, % Set -> Elem
ord_intersect/2, % Set x Set ->
ord_intersect/3, % Set x Set -> Set
ord_intersection/3, % Set x Set -> Set
ord_intersection/4, % Set x Set -> Set x Set
ord_seteq/2, % Set x Set ->
ord_setproduct/3, % Set x Set -> Set
ord_subset/2, % Set x Set ->
ord_subtract/3, % Set x Set -> Set
ord_symdiff/3, % Set x Set -> Set
ord_union/2, % Set^2 -> Set
ord_union/3, % Set x Set -> Set
ord_union/4, % Set x Set -> Set x Set,
ord_empty/1, % -> Set
ord_memberchk/2 % Element X Set
]).
/** @defgroup ordsets Ordered Sets
* @ingroup library
* @{
The following ordered set manipulation routines are available once
included with the `use_module(library(ordsets))` command. An
ordered set is represented by a list having unique and ordered
elements. Output arguments are guaranteed to be ordered sets, if the
relevant inputs are. This is a slightly patched version of Richard
O'Keefe's original library.
In this module, sets are represented by ordered lists with no
duplicates. Thus {c,r,a,f,t} would be [a,c,f,r,t]. The ordering
is defined by the @< family of term comparison predicates, which
is the ordering used by sort/2 and setof/3.
The benefit of the ordered representation is that the elementary
set operations can be done in time proportional to the Sum of the
argument sizes rather than their Product. Some of the unordered
set routines, such as member/2, length/2, select/3 can be used
unchanged. The main difficulty with the ordered representation is
remembering to use it!
*/
/** @pred ord_add_element(+ _Set1_, + _Element_, ? _Set2_)
Inserting _Element_ in _Set1_ returns _Set2_. It should give
exactly the same result as `merge(Set1, [Element], Set2)`, but a
bit faster, and certainly more clearly. The same as ord_insert/3.
*/
/** @pred ord_del_element(+ _Set1_, + _Element_, ? _Set2_)
Removing _Element_ from _Set1_ returns _Set2_.
*/
/** @pred ord_disjoint(+ _Set1_, + _Set2_)
Holds when the two ordered sets have no element in common.
*/
/** @pred ord_insert(+ _Set1_, + _Element_, ? _Set2_)
Inserting _Element_ in _Set1_ returns _Set2_. It should give
exactly the same result as `merge(Set1, [Element], Set2)`, but a
bit faster, and certainly more clearly. The same as ord_add_element/3.
*/
/** @pred ord_intersect(+ _Set1_, + _Set2_)
Holds when the two ordered sets have at least one element in common.
*/
/** @pred ord_intersection(+ _Set1_, + _Set2_, ? _Intersection_)
Holds when Intersection is the ordered representation of _Set1_
and _Set2_.
*/
/** @pred ord_intersection(+ _Set1_, + _Set2_, ? _Intersection_, ? _Diff_)
Holds when Intersection is the ordered representation of _Set1_
and _Set2_. _Diff_ is the difference between _Set2_ and _Set1_.
*/
/** @pred ord_member(+ _Element_, + _Set_)
Holds when _Element_ is a member of _Set_.
*/
/** @pred ord_seteq(+ _Set1_, + _Set2_)
Holds when the two arguments represent the same set.
*/
/** @pred ord_setproduct(+ _Set1_, + _Set2_, - _Set_)
If Set1 and Set2 are ordered sets, Product will be an ordered
set of x1-x2 pairs.
*/
/** @pred ord_subset(+ _Set1_, + _Set2_)
Holds when every element of the ordered set _Set1_ appears in the
ordered set _Set2_.
*/
/** @pred ord_subtract(+ _Set1_, + _Set2_, ? _Difference_)
Holds when _Difference_ contains all and only the elements of _Set1_
which are not also in _Set2_.
*/
/** @pred ord_symdiff(+ _Set1_, + _Set2_, ? _Difference_)
Holds when _Difference_ is the symmetric difference of _Set1_
and _Set2_.
*/
/** @pred ord_union(+ _Set1_, + _Set2_, ? _Union_)
Holds when _Union_ is the union of _Set1_ and _Set2_.
*/
/** @pred ord_union(+ _Set1_, + _Set2_, ? _Union_, ? _Diff_)
Holds when _Union_ is the union of _Set1_ and _Set2_ and
_Diff_ is the difference.
*/
/** @pred ord_union(+ _Sets_, ? _Union_)
Holds when _Union_ is the union of the lists _Sets_.
*/
/*
:- mode
list_to_ord_set(+, ?),
merge(+, +, -),
ord_disjoint(+, +),
ord_disjoint(+, +, +, +, +),
ord_insert(+, +, ?),
ord_insert(+, +, +, +, ?),
ord_intersect(+, +),
ord_intersect(+, +, +, +, +),
ord_intersect(+, +, ?),
ord_intersect(+, +, +, +, +, ?),
ord_seteq(+, +),
ord_subset(+, +),
ord_subset(+, +, +, +, +),
ord_subtract(+, +, ?),
ord_subtract(+, +, +, +, +, ?),
ord_symdiff(+, +, ?),
ord_symdiff(+, +, +, +, +, ?),
ord_union(+, +, ?),
ord_union(+, +, +, +, +, ?).
*/
%% @pred list_to_ord_set(+List, ?Set)
% is true when Set is the ordered representation of the set represented
% by the unordered representation List. The only reason for giving it
% a name at all is that you may not have realised that sort/2 could be
% used this way.
list_to_ord_set(List, Set) :-
sort(List, Set).
%% @ored merge(+List1, +List2, -Merged)
% is true when Merged is the stable merge of the two given lists.
% If the two lists are not ordered, the merge doesn't mean a great
% deal. Merging is perfectly well defined when the inputs contain
% duplicates, and all copies of an element are preserved in the
% output, e.g. merge("122357", "34568", "12233455678"). Study this
% routine carefully, as it is the basis for all the rest.
merge([Head1|Tail1], [Head2|Tail2], [Head2|Merged]) :-
Head1 @> Head2, !,
merge([Head1|Tail1], Tail2, Merged).
merge([Head1|Tail1], List2, [Head1|Merged]) :-
List2 \== [], !,
merge(Tail1, List2, Merged).
merge([], List2, List2) :- !.
merge(List1, [], List1).
%% @ored ord_disjoint(+Set1, +Set2)
% is true when the two ordered sets have no element in common. If the
% arguments are not ordered, I have no idea what happens.
ord_disjoint([], _) :- !.
ord_disjoint(_, []) :- !.
ord_disjoint([Head1|Tail1], [Head2|Tail2]) :-
compare(Order, Head1, Head2),
ord_disjoint(Order, Head1, Tail1, Head2, Tail2).
ord_disjoint(<, _, Tail1, Head2, Tail2) :-
ord_disjoint(Tail1, [Head2|Tail2]).
ord_disjoint(>, Head1, Tail1, _, Tail2) :-
ord_disjoint([Head1|Tail1], Tail2).
%% @ored ord_insert(+Set1, +Element, ?Set2)
% ord_add_element(+Set1, +Element, ?Set2)
% is the equivalent of add_element for ordered sets. It should give
% exactly the same result as merge(Set1, [Element], Set2), but a bit
% faster, and certainly more clearly.
ord_add_element([], Element, [Element]).
ord_add_element([Head|Tail], Element, Set) :-
compare(Order, Head, Element),
ord_insert(Order, Head, Tail, Element, Set).
ord_insert([], Element, [Element]).
ord_insert([Head|Tail], Element, Set) :-
compare(Order, Head, Element),
ord_insert(Order, Head, Tail, Element, Set).
ord_insert(<, Head, Tail, Element, [Head|Set]) :-
ord_insert(Tail, Element, Set).
ord_insert(=, Head, Tail, _, [Head|Tail]).
ord_insert(>, Head, Tail, Element, [Element,Head|Tail]).
%% @pred ord_intersect(+Set1, +Set2)
% is true when the two ordered sets have at least one element in common.
% Note that the test is == rather than = .
ord_intersect([Head1|Tail1], [Head2|Tail2]) :-
compare(Order, Head1, Head2),
ord_intersect(Order, Head1, Tail1, Head2, Tail2).
ord_intersect(=, _, _, _, _).
ord_intersect(<, _, Tail1, Head2, Tail2) :-
ord_intersect(Tail1, [Head2|Tail2]).
ord_intersect(>, Head1, Tail1, _, Tail2) :-
ord_intersect([Head1|Tail1], Tail2).
ord_intersect(L1, L2, L) :-
ord_intersection(L1, L2, L).
%% @pred ord_intersection(+Set1, +Set2, ?Intersection)
% is true when Intersection is the ordered representation of Set1
% and Set2, provided that Set1 and Set2 are ordered sets.
ord_intersection([], _, []) :- !.
ord_intersection([_|_], [], []) :- !.
ord_intersection([Head1|Tail1], [Head2|Tail2], Intersection) :-
( Head1 == Head2 ->
Intersection = [Head1|Tail],
ord_intersection(Tail1, Tail2, Tail)
;
Head1 @< Head2 ->
ord_intersection(Tail1, [Head2|Tail2], Intersection)
;
ord_intersection([Head1|Tail1], Tail2, Intersection)
).
%% @pred ord_intersection(+Set1, +Set2, ?Intersection, ?Difference)
% is true when Intersection is the ordered representation of Set1
% and Set2, provided that Set1 and Set2 are ordered sets.
ord_intersection([], L, [], L) :- !.
ord_intersection([_|_], [], [], []) :- !.
ord_intersection([Head1|Tail1], [Head2|Tail2], Intersection, Difference) :-
( Head1 == Head2 ->
Intersection = [Head1|Tail],
ord_intersection(Tail1, Tail2, Tail, Difference)
;
Head1 @< Head2 ->
ord_intersection(Tail1, [Head2|Tail2], Intersection, Difference)
;
Difference = [Head2|HDifference],
ord_intersection([Head1|Tail1], Tail2, Intersection, HDifference)
).
% ord_seteq(+Set1, +Set2)
% is true when the two arguments represent the same set. Since they
% are assumed to be ordered representations, they must be identical.
ord_seteq(Set1, Set2) :-
Set1 == Set2.
% ord_subset(+Set1, +Set2)
% is true when every element of the ordered set Set1 appears in the
% ordered set Set2.
ord_subset([], _) :- !.
ord_subset([Head1|Tail1], [Head2|Tail2]) :-
compare(Order, Head1, Head2),
ord_subset(Order, Head1, Tail1, Head2, Tail2).
ord_subset(=, _, Tail1, _, Tail2) :-
ord_subset(Tail1, Tail2).
ord_subset(>, Head1, Tail1, _, Tail2) :-
ord_subset([Head1|Tail1], Tail2).
% ord_subtract(+Set1, +Set2, ?Difference)
% is true when Difference contains all and only the elements of Set1
% which are not also in Set2.
ord_subtract(Set1, [], Set1) :- !.
ord_subtract([], _, []) :- !.
ord_subtract([Head1|Tail1], [Head2|Tail2], Difference) :-
compare(Order, Head1, Head2),
ord_subtract(Order, Head1, Tail1, Head2, Tail2, Difference).
ord_subtract(=, _, Tail1, _, Tail2, Difference) :-
ord_subtract(Tail1, Tail2, Difference).
ord_subtract(<, Head1, Tail1, Head2, Tail2, [Head1|Difference]) :-
ord_subtract(Tail1, [Head2|Tail2], Difference).
ord_subtract(>, Head1, Tail1, _, Tail2, Difference) :-
ord_subtract([Head1|Tail1], Tail2, Difference).
% ord_del_element(+Set1, Element, ?Rest)
% is true when Rest contains the elements of Set1
% except for Set1
ord_del_element([], _, []).
ord_del_element([Head1|Tail1], Head2, Rest) :-
compare(Order, Head1, Head2),
ord_del_element(Order, Head1, Tail1, Head2, Rest).
ord_del_element(=, _, Tail1, _, Tail1).
ord_del_element(<, Head1, Tail1, Head2, [Head1|Difference]) :-
ord_del_element(Tail1, Head2, Difference).
ord_del_element(>, Head1, Tail1, _, [Head1|Tail1]).
%% @pred ord_symdiff(+Set1, +Set2, ?Difference)
% is true when Difference is the symmetric difference of Set1 and Set2.
ord_symdiff(Set1, [], Set1) :- !.
ord_symdiff([], Set2, Set2) :- !.
ord_symdiff([Head1|Tail1], [Head2|Tail2], Difference) :-
compare(Order, Head1, Head2),
ord_symdiff(Order, Head1, Tail1, Head2, Tail2, Difference).
ord_symdiff(=, _, Tail1, _, Tail2, Difference) :-
ord_symdiff(Tail1, Tail2, Difference).
ord_symdiff(<, Head1, Tail1, Head2, Tail2, [Head1|Difference]) :-
ord_symdiff(Tail1, [Head2|Tail2], Difference).
ord_symdiff(>, Head1, Tail1, Head2, Tail2, [Head2|Difference]) :-
ord_symdiff([Head1|Tail1], Tail2, Difference).
% ord_union(+Set1, +Set2, ?Union)
% is true when Union is the union of Set1 and Set2. Note that when
% something occurs in both sets, we want to retain only one copy.
ord_union([S|Set1], [], [S|Set1]).
ord_union([], Set2, Set2).
ord_union([Head1|Tail1], [Head2|Tail2], Union) :-
compare(Order, Head1, Head2),
ord_union(Order, Head1, Tail1, Head2, Tail2, Union).
ord_union(=, Head, Tail1, _, Tail2, [Head|Union]) :-
ord_union(Tail1, Tail2, Union).
ord_union(<, Head1, Tail1, Head2, Tail2, [Head1|Union]) :-
ord_union(Tail1, [Head2|Tail2], Union).
ord_union(>, Head1, Tail1, Head2, Tail2, [Head2|Union]) :-
ord_union([Head1|Tail1], Tail2, Union).
%% @pred ord_union(+Set1, +Set2, ?Union, ?Difference)
% is true when Union is the union of Set1 and Set2 and Difference is the
% difference between Set2 and Set1.
ord_union(Set1, [], Set1, []) :- !.
ord_union([], Set2, Set2, Set2) :- !.
ord_union([Head1|Tail1], [Head2|Tail2], Union, Diff) :-
compare(Order, Head1, Head2),
ord_union(Order, Head1, Tail1, Head2, Tail2, Union, Diff).
ord_union(=, Head, Tail1, _, Tail2, [Head|Union], Diff) :-
ord_union(Tail1, Tail2, Union, Diff).
ord_union(<, Head1, Tail1, Head2, Tail2, [Head1|Union], Diff) :-
ord_union(Tail1, [Head2|Tail2], Union, Diff).
ord_union(>, Head1, Tail1, Head2, Tail2, [Head2|Union], [Head2|Diff]) :-
ord_union([Head1|Tail1], Tail2, Union, Diff).
%% @pred ord_setproduct(+Set1, +Set2, ?Product)
% is in fact identical to setproduct(Set1, Set2, Product).
% If Set1 and Set2 are ordered sets, Product will be an ordered
% set of x1-x2 pairs. Note that we cannot solve for Set1 and
% Set2, because there are infinitely many solutions when
% Product is empty, and may be a large number in other cases.
ord_setproduct([], _, []).
ord_setproduct([H|T], L, Product) :-
ord_setproduct(L, H, Product, Rest),
ord_setproduct(T, L, Rest).
ord_setproduct([], _, L, L).
ord_setproduct([H|T], X, [X-H|TX], TL) :-
ord_setproduct(T, X, TX, TL).
ord_member(El,[H|T]):-
compare(Op,El,H),
ord_member(Op,El,T).
ord_member(=,_,_).
ord_member(>,El,[H|T]) :-
compare(Op,El,H),
ord_member(Op,El,T).
ord_union([], []).
ord_union([Set|Sets], Union) :-
length([Set|Sets], NumberOfSets),
ord_union_all(NumberOfSets, [Set|Sets], Union, []).
ord_union_all(N,Sets0,Union,Sets) :-
( N=:=1 -> Sets0=[Union|Sets]
; N=:=2 -> Sets0=[Set1,Set2|Sets],
ord_union(Set1,Set2,Union)
; A is N>>1,
Z is N-A,
ord_union_all(A, Sets0, X, Sets1),
ord_union_all(Z, Sets1, Y, Sets),
ord_union(X, Y, Union)
).
ord_empty([]).
ord_memberchk(Element, [E|_]) :- E == Element, !.
ord_memberchk(Element, [_|Set]) :-
ord_memberchk(Element, Set).
/** @} */

File diff suppressed because it is too large Load Diff

View File

@@ -1,173 +0,0 @@
%
% Edinburgh IO.
/**
* @file edio.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Wed Jan 20 01:07:02 2016
*
* @brief Input/Output according to the DEC-10 Prolog. PLease consider using the ISO
* standard predicates for new code.
*
*
*/
%
/** @pred see(+ _S_)
If _S_ is a currently opened input stream then it is assumed to be
the current input stream. If _S_ is an atom it is taken as a
filename. If there is no input stream currently associated with it, then
it is opened for input, and the new input stream thus created becomes
the current input stream. If it is not possible to open the file, an
error occurs. If there is a single opened input stream currently
associated with the file, it becomes the current input stream; if there
are more than one in that condition, then one of them is chosen.
When _S_ is a stream not currently opened for input, an error may be
reported, depending on the state of the `file_errors` flag. If
_S_ is neither a stream nor an atom the predicates just fails.
*/
see(user) :- !, set_input(user_input).
see(F) :- var(F), !,
'$do_error'(instantiation_error,see(F)).
see(F) :- current_input(Stream),
'$user_file_name'(Stream,F).
see(F) :- current_stream(_,read,Stream), '$user_file_name'(Stream,F), !,
set_input(Stream).
see(Stream) :- '$stream'(Stream), current_stream(_,read,Stream), !,
set_input(Stream).
see(F) :- open(F,read,Stream), set_input(Stream).
/** @pred seeing(- _S_)
The current input stream is unified with _S_.
*/
seeing(File) :- current_input(Stream),
stream_property(Stream,file_name(NFile)),
(
stream_property(user_input,file_name(NFile))
->
File = user
;
NFile = File
).
/** @pred seen
Closes the current input stream, as opened by see/1. Standard input
stream goes to the original ùser_input`.
*/
seen :- current_input(Stream), close(Stream), set_input(user).
/** @pred tell(+ _S_)
If _S_ is a currently opened stream for output, it becomes the
current output stream. If _S_ is an atom it is taken to be a
filename. If there is no output stream currently associated with it,
then it is opened for output, and the new output stream created becomes
the current output stream. Existing files are clobbered, use append/1 to ext end a file.
If it is not possible to open the file, an
error occurs. If there is a single opened output stream currently
associated with the file, then it becomes the current output stream; if
there are more than one in that condition, one of them is chosen.
Whenever _S_ is a stream not currently opened for output, an error
may be reported, depending on the state of the file_errors flag. The
predicate just fails, if _S_ is neither a stream nor an atom.
*/
tell(user) :- !, set_output(user_output).
tell(F) :- var(F), !,
'$do_error'(instantiation_error,tell(F)).
tell(F) :-
current_output(Stream),
stream_property(Stream,file_name(F)),
!.
tell(F) :-
current_stream(_,write,Stream),
'$user_file_name'(Stream, F), !,
set_output(Stream).
tell(Stream) :-
'$stream'(Stream),
current_stream(_,write,Stream), !,
set_output(Stream).
tell(F) :-
open(F,write,Stream),
set_output(Stream).
/** @pred append(+ _S_)
If _S_ is a currently opened stream for output, it becomes the
current output stream. If _S_ is an atom it is taken to be a
filename. If there is no output stream currently associated with it,
then it is opened for output in *append* mode, that is, by adding new data to the end of the file.
The new output stream created becomes
the current output stream. If it is not possible to open the file, an
error occurs. If there is a single opened output stream currently
associated with the file, then it becomes the current output stream; if
there are more than one in that condition, one of them is chosen.
Whenever _S_ is a stream not currently opened for output, an error
may be reported, depending on the state of the file_errors flag. The
predicate just fails, if _S_ is neither a stream nor an atom.
*/
tell(user) :- !, set_output(user_output).
tell(F) :- var(F), !,
'$do_error'(instantiation_error,tell(F)).
tell(F) :-
current_output(Stream),
stream_property(Stream,file_name(F)),
!.
tell(F) :-
current_stream(_,write,Stream),
'$user_file_name'(Stream, F), !,
set_output(Stream).
tell(Stream) :-
'$stream'(Stream),
current_stream(_,write,Stream), !,
set_output(Stream).
tell(F) :-
open(F,write,Stream),
set_output(Stream).
/** @pred telling(- _S_)
The current output stream is unified with _S_.
*/
telling(File) :-
current_output(Stream),
stream_property(Stream,file_name(NFile)),
( stream_property(user_output,file_name(NFile)) -> File = user ; File = NFile ).
/** @pred told
Closes the current output stream, and the user's terminal becomes again
the current output stream. It is important to remember to close streams
after having finished using them, as the maximum number of
simultaneously opened streams is 17.
*/
told :- current_output(Stream),
!,
set_output(user_output),
close(Stream).

View File

@@ -1,561 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-2014 *
* *
*************************************************************************/
/**
@file absf.yap
@author L.Damas, V.S.Costa
@defgroup AbsoluteFileName File Name Resolution
@ingroup builtins
Support for file name resolution through absolute_file_name/3 and
friends. These utility built-ins describe a list of directories that
are used by load_files/2 to search. They include pre-compiled paths
plus user-defined directories, directories based on environment
variables and registry information to search for files.
@{
*/
:- system_module( absf, [absolute_file_name/2,
absolute_file_name/3,
add_to_path/1,
add_to_path/2,
path/1,
remove_from_path/1], ['$full_filename'/3,
'$system_library_directories'/2]).
:- use_system_module( '$_boot', ['$system_catch'/4]).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_lists', [member/2]).
/**
@pred absolute_file_name( -File:atom, +Path:atom, +Options:list) is nondet
_Options_ is a list of options to guide the conversion:
- extensions(+ _ListOfExtensions_)
List of file-name suffixes to add to try adding to the file. The
Default is the empty suffix, `''`. For each extension,
absolute_file_name/3 will first add the extension and then verify
the conditions imposed by the other options. If the condition
fails, the next extension of the list is tried. Extensions may
be specified both with dot, as `.ext`, or without, as plain
`ext`.
- relative_to(+ _FileOrDir_ )
Resolve the path relative to the given directory or directory the
holding the given file. Without this option, paths are resolved
relative to the working directory (see working_directory/2) or,
if _Spec_ is atomic and absolute_file_name/3 is executed
in a directive, it uses the current source-file as reference.
- access(+ _Mode_ )
Imposes the condition access_file( _File_ , _Mode_ ). _Mode_ is one of `read`, `write`, `append`, `exist` or
`none` (default).
See also access_file/2.
- file_type(+ _Type_ )
Defines suffixes matching one of several pre-specified type of files. Default mapping is as follows:
1. `txt` implies `[ '' ]`,
2. `prolog` implies `['.yap', '.pl', '.prolog', '']`,
3. `executable` implies `['.so', ',dylib', '.dll']` depending on the Operating system,
4. `qly` implies `['.qly', '']`,
5. `directory` implies `['']`,
6. The file-type `source` is an alias for `prolog` designed to support compatibility with SICStus Prolog. See also prolog_file_type/2.
Notice that this predicate only
returns non-directories, unless the option `file_type(directory)` is
specified, or unless `access(none)`.
- file_errors(`fail`/`error`)
If `error` (default), throw `existence_error` exception
if the file cannot be found. If `fail`, stay silent.
- solutions(`first`/`all`)
If `first` (default), commit to the first solution. Otherwise
absolute_file_name will enumerate all solutions via backtracking.
- expand(`true`/`false`)
If `true` (default is `false`) and _Spec_ is atomic, call
expand_file_name/2 followed by member/2 on _Spec_ before
proceeding. This is originally a SWI-Prolog extension, but
whereas SWI-Prolog implements its own conventions, YAP uses the
shell's `glob` primitive.
Notice that in `glob` mode YAP will fail if it cannot find a matching file, as `glob`
implicitely tests for existence when checking for patterns.
- glob(`Pattern`)
If _Pattern_ is atomic, add the pattern as a suffix to the current expansion, and call
expand_file_name/2 followed by member/2 on the result. This is originally a SICStus Prolog exception.
Both `glob` and `expand` rely on the same underlying
mechanism. YAP gives preference to `glob`.
- verbose_file_search(`true`/`false`)
If `true` (default is `false`) output messages during
search. This is often helpful when debugging. Corresponds to the
SWI-Prolog flag `verbose_file_search` (also available in YAP).
Compatibility considerations to common argument-order in ISO as well
as SICStus absolute_file_name/3 forced us to be flexible here.
If the last argument is a list and the second not, the arguments are
swapped, thus the call
~~~~~~~~~~~~
?- absolute_file_name( 'pl/absf.yap', [], Path)
~~~~~~~~~~~~
is valid as well.
*/
absolute_file_name(File,TrueFileName,Opts) :-
( var(TrueFileName) ->
true ;
atom(TrueFileName), TrueFileName \= []
),
!,
absolute_file_name(File,Opts,TrueFileName).
absolute_file_name(File,Opts,TrueFileName) :-
'$absolute_file_name'(File,Opts,TrueFileName,absolute_file_name(File,Opts,TrueFileName)).
/**
@pred absolute_file_name(+Name:atom,+Path:atom) is nondet
Converts the given file specification into an absolute path, using default options. See absolute_file_name/3 for details on the options.
*/
absolute_file_name(V,Out) :- var(V),
!, % absolute_file_name needs commenting.
'$do_error'(instantiation_error, absolute_file_name(V, Out)).
absolute_file_name(user,user) :- !.
absolute_file_name(File0,File) :-
'$absolute_file_name'(File0,[access(none),file_type(txt),file_errors(fail),solutions(first)],File,absolute_file_name(File0,File)).
'$full_filename'(F0, F, G) :-
'$absolute_file_name'(F0,[access(read),
file_type(prolog),
file_errors(fail),
solutions(first),
expand(true)],F,G).
'$absolute_file_name'(File,LOpts,TrueFileName, G) :-
% must_be_of_type( atom, File ),
( var(File) -> instantiation_error(File) ; true),
abs_file_parameters(LOpts,Opts),
current_prolog_flag(open_expands_filename, OldF),
current_prolog_flag( fileerrors, PreviousFileErrors ),
current_prolog_flag( verbose_file_search, PreviousVerbose ),
get_abs_file_parameter( verbose_file_search, Opts,Verbose ),
get_abs_file_parameter( expand, Opts, Expand ),
set_prolog_flag( verbose_file_search, Verbose ),
get_abs_file_parameter( file_errors, Opts, FErrors ),
get_abs_file_parameter( solutions, Opts, First ),
( FErrors == fail -> FileErrors = false ; FileErrors = true ),
set_prolog_flag( fileerrors, FileErrors ),
set_prolog_flag(file_name_variables, Expand),
'$absf_trace'(File),
'$absf_trace_options'(LOpts),
HasSol = t(no),
(
% look for solutions
'$find_in_path'(File, Opts,TrueFileName),
( (First == first -> ! ; nb_setarg(1, HasSol, yes) ),
set_prolog_flag( fileerrors, PreviousFileErrors ),
set_prolog_flag( open_expands_filename, OldF),
set_prolog_flag( verbose_file_search, PreviousVerbose ),
'$absf_trace'(' |------- found ~a', [TrueFileName])
;
set_prolog_flag( fileerrors, FileErrors ),
set_prolog_flag( verbose_file_search, Verbose ),
set_prolog_flag( file_name_variables, Expand ),
'$absf_trace'(' |------- restarted search for ~a', [File]),
fail
)
;
% finished
% stop_low_level_trace,
'$absf_trace'(' !------- failed.', []),
set_prolog_flag( fileerrors, PreviousFileErrors ),
set_prolog_flag( verbose_file_search, PreviousVerbose ),
set_prolog_flag(file_name_variables, OldF),
% check if no solution
arg(1,HasSol,no),
FileErrors = error,
'$do_error'(existence_error(file,File),G)
).
% This sequence must be followed:
% user and user_input are special;
% library(F) must check library_directories
% T(F) must check file_search_path
% all must try search in path
'$find_in_path'(user,_,user_input) :- !.
'$find_in_path'(user_input,_,user_input) :- !.
'$find_in_path'(user_output,_,user_ouput) :- !.
'$find_in_path'(user_error,_,user_error) :- !.
'$find_in_path'(Name, Opts, File) :-
% ( atom(Name) -> true ; start_low_level_trace ),
get_abs_file_parameter( file_type, Opts, Type ),
get_abs_file_parameter( access, Opts, Access ),
get_abs_file_parameter( expand, Opts, Expand ),
'$absf_trace'('start with ~w', [Name]),
'$core_file_name'(Name, Opts, CorePath, []),
'$absf_trace'(' after name/library unfolding: ~w', [Name]),
'$variable_expansion'(CorePath, Opts,ExpandedPath),
'$absf_trace'(' after environment variable expansion: ~s', [ExpandedPath]),
'$prefix'(ExpandedPath, Opts, Path , []),
'$absf_trace'(' after prefix expansion: ~s', [Path]),
atom_codes( APath, Path ),
(
Expand = true
->
expand_file_name( APath, EPaths),
'$absf_trace'(' after shell globbing: ~w', [EPaths]),
lists:member(EPath, EPaths)
;
EPath = APath
),
real_path( EPath, File),
'$absf_trace'(' after canonical path name: ~a', [File]),
'$check_file'( File, Type, Access ),
'$absf_trace'(' after testing ~a for ~a and ~a', [File,Type,Access]).
% allow paths in File Name
'$core_file_name'(Name, Opts) -->
'$file_name'(Name, Opts, E),
'$suffix'(E, Opts),
'$glob'(Opts).
%
% handle library(lists) or foreign(jpl)
%
'$file_name'(Name, Opts, E) -->
{ Name =.. [Lib, P0] },
!,
{ user:file_search_path(Lib, IDirs) },
{ '$paths'(IDirs, Dir ) },
'$absf_trace'(' ~w first', [Dir]),
'$file_name'(Dir, Opts, _),
'$dir',
{ '$absf_trace'(' ~w next', [P0]) },
'$cat_file_name'(P0, E).
'$file_name'(Name, Opts, E) -->
'$cat_file_name'(Name, E ).
/*
(
{
get_abs_file_parameter( file_type, Opts, Lib ),
nonvar(Lib)
}
->
{ user:file_search_path(Lib, IDirs) },
{ '$paths'(IDirs, Dir ) },
'$absf_trace'(' ~w first', [Dir]),
'$file_name'(Dir, Opts, _),
'$dir',
{ '$absf_trace'(' ~w next', [P0]) }
;
[]
).
*/
'$cat_file_name'(A/B, E ) -->
'$cat_file_name'(A, _),
'$dir',
'$cat_file_name'(B, E).
'$cat_file_name'(File, F) -->
{ atom(File), atom_codes(File, F) },
!,
F.
'$cat_file_name'(File, S) -->
{string(File), string_to_codes(File, S) },
!,
S.
'$variable_expansion'( Path, Opts, APath ) :-
get_abs_file_parameter( expand, Opts, true ),
!,
'$expand_file_name'( Path, APath ).
'$variable_expansion'( Path, _, Path ).
'$var'(S) -->
"{", !, '$id'(S), "}".
'$var'(S) -->
'$id'(S).
'$drive'(C) -->
'$id'(C),
":\\\\".
'$id'([C|S]) --> [C],
{ C >= "a", C =< "z" ; C >= "A", C =< "Z" ;
C >= "0", C =< "9" ; C =:= "_" },
!,
'$id'(S).
'$id'([]) --> [].
% always verify if a directory
'$check_file'(F, directory, _) :-
!,
exists_directory(F).
'$check_file'(_F, _Type, none) :- !.
'$check_file'(F, _Type, exist) :-
'$access_file'(F, exist). % if it has a type cannot be a directory..
'$check_file'(F, _Type, Access) :-
'$access_file'(F, Access),
\+ exists_directory(F). % if it has a type cannot be a directory..
'$suffix'(Last, _Opts) -->
{ lists:append(_, [0'.|Alphas], Last), '$id'(Alphas, _, [] ) },
'$absf_trace'(' suffix in ~s', [Last]),
!.
'$suffix'(_, Opts) -->
{
(
get_abs_file_parameter( extensions, Opts, Exts ),
Exts \= []
->
lists:member(Ext, Exts),
'$absf_trace'(' trying suffix ~a from ~w', [Ext,Exts])
;
get_abs_file_parameter( file_type, Opts, Type ),
( Type == source -> NType = prolog ; NType = Type ),
user:prolog_file_type(Ext, NType)
),
'$absf_trace'(' trying suffix ~a from type ~a', [Ext, NType]),
atom_codes(Ext, Cs)
},
'$add_suffix'(Cs).
'$suffix'(_,_Opts) -->
'$absf_trace'(' try no suffix', []).
'$add_suffix'(Cs) -->
{ Cs = [0'. |_Codes] }
->
Cs
;
".", Cs.
'$glob'(Opts) -->
{
get_abs_file_parameter( glob, Opts, G ),
G \= '',
atom_codes( G, Gs )
},
!,
'$dir',
Gs.
'$glob'(_Opts) -->
[].
'$enumerate_glob'(_File1, [ExpFile], ExpFile) :-
!.
'$enumerate_glob'(_File1, ExpFiles, ExpFile) :-
lists:member(ExpFile, ExpFiles),
file_base_name( ExpFile, Base ),
Base \= '.',
Base \='..'.
'$prefix'( CorePath, _Opts) -->
{ is_absolute_file_name( CorePath ) },
!,
CorePath.
'$prefix'( CorePath, Opts) -->
{ get_abs_file_parameter( relative_to, Opts, Prefix ),
Prefix \= '',
'$absf_trace'(' relative_to ~a', [Prefix]),
sub_atom(Prefix, _, 1, 0, Last),
atom_codes(Prefix, S)
},
!,
S,
'$dir'(Last),
CorePath.
'$prefix'( CorePath, _) -->
{
recorded('$path',Prefix,_),
'$absf_trace'(' try YAP path database ~a', [Prefix]),
sub_atom(Prefix, _, _, 1, Last),
atom_codes(Prefix, S) },
S,
'$dir'(Last),
CorePath.
'$prefix'(CorePath, _ ) -->
'$absf_trace'(' empty prefix', []),
CorePath.
'$dir' --> { current_prolog_flag(windows, true) },
"\\",
!.
'$dir' --> "/".
'$dir'('/') --> !.
'$dir'('\\') --> { current_prolog_flag(windows, true) },
!.
'$dir'(_) --> '$dir'.
%
%
%
'$system_library_directories'(library, Dir) :-
user:library_directory( Dir ).
% '$split_by_sep'(0, 0, Dirs, Dir).
'$system_library_directories'(foreign, Dir) :-
user:foreign_directory( Dir ).
% compatibility with old versions
%
% search the current directory first.
'$system_library_directories'(commons, Dir) :-
user:commons_directory( Dir ).
% enumerate all paths separated by a path_separator.
'$paths'(Cs, C) :-
atom(Cs),
( current_prolog_flag(windows, true) -> Sep = ';' ; Sep = ':' ),
sub_atom(Cs, N0, 1, N, Sep),
!,
(
sub_atom(Cs,0,N0,_,C)
;
sub_atom(Cs,_,N,0,RC),
'$paths'(RC, C)
).
'$paths'(S, S).
'$absf_trace'(Msg, Args ) -->
{ current_prolog_flag( verbose_file_search, true ) },
{ print_message( informational, absolute_file_path( Msg, Args ) ) },
!.
'$absf_trace'(_Msg, _Args ) --> [].
'$absf_trace'(Msg, Args ) :-
current_prolog_flag( verbose_file_search, true ),
print_message( informational, absolute_file_path( Msg, Args ) ),
!.
'$absf_trace'(_Msg, _Args ).
'$absf_trace'( File ) :-
current_prolog_flag( verbose_file_search, true ),
print_message( informational, absolute_file_path( File ) ),
!.
'$absf_trace'( _File ).
'$absf_trace_options'(Args ) :-
current_prolog_flag( verbose_file_search, true ),
print_message( informational, arguments( Args ) ),
!.
'$absf_trace_options'( _Args ).
/** @pred prolog_file_name( +File, -PrologFileaNme)
Unify _PrologFileName_ with the Prolog file associated to _File_.
*/
prolog_file_name(File, PrologFileName) :-
var(File), !,
'$do_error'(instantiation_error, prolog_file_name(File, PrologFileName)).
prolog_file_name(user, Out) :- !, Out = user.
prolog_file_name(File, PrologFileName) :-
atom(File), !,
system:true_file_name(File, PrologFileName).
prolog_file_name(File, PrologFileName) :-
'$do_error'(type_error(atom,File), prolog_file_name(File, PrologFileName)).
/**
@pred path(-Directories:list) is det,deprecated
YAP specific procedure that returns a list of user-defined directories
in the library search-path.We suggest using user:file_search_path/2 for
compatibility with other Prologs.
*/
path(Path) :-
findall(X,'$in_path'(X),Path).
'$in_path'(X) :-
recorded('$path',Path,_),
atom_codes(Path,S),
( S = "" -> X = '.' ;
atom_codes(X,S) ).
/**
@pred add_to_path(+Directory:atom) is det,deprecated
YAP-specific predicate to include directory in library search path.
We suggest using user:file_search_path/2 for
compatibility with other Prologs.
*/
add_to_path(New) :-
add_to_path(New,last).
/**
@pred add_to_path(+Directory:atom, +Position:atom) is det,deprecated
YAP-specific predicate to include directory in front or back of
library search path. We suggest using user:file_search_path/2 for
compatibility with other Prologs and more extensive functionality.
*/
add_to_path(New,Pos) :-
atom(New), !,
'$check_path'(New,Str),
atom_codes(Path,Str),
'$add_to_path'(Path,Pos).
'$add_to_path'(New,_) :-
recorded('$path',New,R),
erase(R),
fail.
'$add_to_path'(New,last) :-
!,
recordz('$path',New,_).
'$add_to_path'(New,first) :-
recorda('$path',New,_).
/** @pred remove_from_path(+Directory:atom) is det,deprecated
@}
*/
remove_from_path(New) :- '$check_path'(New,Path),
recorded('$path',Path,R), erase(R).
'$check_path'(At,SAt) :- atom(At), !, atom_codes(At,S), '$check_path'(S,SAt).
'$check_path'([],[]).
'$check_path'([Ch],[Ch]) :- '$dir_separator'(Ch), !.
'$check_path'([Ch],[Ch,A]) :- !, integer(Ch), '$dir_separator'(A).
'$check_path'([N|S],[N|SN]) :- integer(N), '$check_path'(S,SN).

View File

@@ -1,364 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: arith.yap *
* Last rev: *
* mods: *
* comments: arithmetical optimization *
* *
*************************************************************************/
% the default mode is on
%% @file arith.yap
:- system_module( '$_arith', [compile_expressions/0,
expand_exprs/2,
plus/3,
succ/2], ['$c_built_in'/3]).
:- private( [do_c_built_in/3,
do_c_built_metacall/3,
expand_expr/3,
expand_expr/5,
expand_expr/6] ).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_modules', ['$clean_cuts'/2]).
/** @defgroup CompilerAnalysis Internal Clause Rewriting
@ingroup YAPCompilerSettings
YAP supports several clause optimisation mechanisms, that
are designed to improve execution of arithmetic
and term construction built-ins. In other words, during the
compilation process a clause is rewritten twice:
1. first, perform user-defined goal_expansion as described
in the predicates goal_expansion/1 and goal_expansion/2.
2. Perform expansion of some built-ins like:
+ pruning operators, like ->/2 and *->/2
+ arithmetic, including early evaluation of constant expressions
+ specialise versions for some built-ins, if we are aware of the
run-time execution mode
The user has some control over this process, through some
built-ins and through execution flsgs.
*/
%% @{
/** @pred expand_exprs(- _O_,+ _N_)
Control term expansion during compilation.
Enables low-level optimizations. It reports the current state by
unifying _O_ with the previous state. It then puts YAP in state _N_
(`on` or `off`)/ _On_ is equivalent to compile_expressions/0 and `off`
is equivalent to do_not_compile_expressions/0.
This predicate is useful when debugging, to ensure execution close to the original source.
*/
expand_exprs(Old,New) :-
(get_value('$c_arith',true) ->
Old = on ;
Old = off ),
'$set_arith_expan'(New).
'$set_arith_expan'(on) :- set_value('$c_arith',true).
'$set_arith_expan'(off) :- set_value('$c_arith',[]).
/** @pred compile_expressions
After a call to this predicate, arithmetical expressions will be compiled.
(see example below). This is the default behavior.
*/
compile_expressions :- set_value('$c_arith',true).
/** @pred do_not_compile_expressions
After a call to this predicate, arithmetical expressions will not be compiled.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
?- source, do_not_compile_expressions.
yes
?- [user].
| p(X) :- X is 2 * (3 + 8).
| :- end_of_file.
?- compile_expressions.
yes
?- [user].
| q(X) :- X is 2 * (3 + 8).
| :- end_of_file.
:- listing.
p(A):-
A is 2 * (3 + 8).
q(A):-
A is 22.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
*/
do_not_compile_expressions :- set_value('$c_arith',[]).
'$c_built_in'(IN, M, H, OUT) :-
get_value('$c_arith',true), !,
do_c_built_in(IN, M, H, OUT).
'$c_built_in'(IN, _, _H, IN).
do_c_built_in(G, M, H, OUT) :- var(G), !,
do_c_built_metacall(G, M, H, OUT).
do_c_built_in(Mod:G, _, H, OUT) :-
'$yap_strip_module'(Mod:G, M1, G1),
var(G1), !,
do_c_built_metacall(G1, M1, H, OUT).
do_c_built_in('$do_error'( Error, Goal), M, Head,
(clause_location(Call, Caller),
strip_module(M:Goal,M1,NGoal),
throw(error(Error,
[[g|g(M1:NGoal)],[p|Call],[e|Caller],[h|g(Head)]]
)
)
)
) :- !.
do_c_built_in(X is Y, M, H, P) :-
primitive(X), !,
do_c_built_in(X =:= Y, M, H, P).
do_c_built_in(X is Y, M, H, (P,A=X)) :-
nonvar(X), !,
do_c_built_in(A is Y, M, H, P).
do_c_built_in(X is Y, _, _, P) :-
nonvar(Y), % Don't rewrite variables
!,
(
number(Y) ->
P = ( X = Y); % This case reduces to an unification
expand_expr(Y, P0, X0),
'$drop_is'(X0, X, P0, P)
).
do_c_built_in(phrase(NT,Xs), Mod, H, NTXsNil) :-
'$_arith':do_c_built_in(phrase(NT,Xs,[]), Mod, H, NTXsNil).
do_c_built_in(phrase(NT,Xs0,Xs), Mod, _, NewGoal) :-
'$c_built_in_phrase'(NT, Xs0, Xs, Mod, NewGoal ).
do_c_built_in(Comp0, _, _, R) :- % now, do it for comparisons
'$compop'(Comp0, Op, E, F),
!,
'$compop'(Comp, Op, U, V),
expand_expr(E, P, U),
expand_expr(F, Q, V),
'$do_and'(P, Q, R0),
'$do_and'(R0, Comp, R).
do_c_built_in(P, _M, _H, P).
do_c_built_metacall(G1, Mod, _, '$execute_wo_mod'(G1,Mod)) :-
var(Mod), !.
do_c_built_metacall(G1, Mod, _, '$execute_in_mod'(G1,Mod)) :-
atom(Mod), !.
do_c_built_metacall(G1, Mod, _, call(Mod:G1)).
'$do_and'(true, P, P) :- !.
'$do_and'(P, true, P) :- !.
'$do_and'(P, Q, (P,Q)).
% V is the result of the simplification,
% X the result of the initial expression
% and the last argument is how we are writing this result
'$drop_is'(V, V1, P0, G) :-
var(V),
!, % usual case
V = V1,
P0 = G.
'$drop_is'(V, X, P0, P) :- % atoms
'$do_and'(P0, X is V, P).
% Table of arithmetic comparisons
'$compop'(X < Y, < , X, Y).
'$compop'(X > Y, > , X, Y).
'$compop'(X=< Y,=< , X, Y).
'$compop'(X >=Y, >=, X, Y).
'$compop'(X=:=Y,=:=, X, Y).
'$compop'(X=\=Y,=\=, X, Y).
'$composed_built_in'(V) :- var(V), !,
fail.
'$composed_built_in'(('$current_choice_point'(_),NG,'$$cut_by'(_))) :- !,
'$composed_built_in'(NG).
'$composed_built_in'((_,_)).
'$composed_built_in'((_;_)).
'$composed_built_in'((_|_)).
'$composed_built_in'((_->_)).
'$composed_built_in'(_:G) :-
'$composed_built_in'(G).
'$composed_built_in'(\+G) :-
'$composed_built_in'(G).
'$composed_built_in'(not(G)) :-
'$composed_built_in'(G).
% expanding an expression:
% first argument is the expression not expanded,
% second argument the expanded expression
% third argument unifies with the result from the expression
expand_expr(V, true, V) :-
var(V), !.
expand_expr([T], E, V) :- !,
expand_expr(T, E, V).
expand_expr(String, _E, V) :-
string( String ), !,
string_codes(String, [V]).
expand_expr(A, true, A) :-
atomic(A), !.
expand_expr(T, E, V) :-
T =.. [O, A], !,
expand_expr(A, Q, X),
expand_expr(O, X, V, Q, E).
expand_expr(T, E, V) :-
T =.. [O, A, B], !,
expand_expr(A, Q, X),
expand_expr(B, R, Y),
expand_expr(O, X, Y, V, Q, S),
'$do_and'(R, S, E).
% expanding an expression of the form:
% O is Op(X),
% after having expanded into Q
% and giving as result P (the last argument)
expand_expr(Op, X, O, Q, Q) :-
number(X),
catch(is( O, Op, X),_,fail), !. % do not do error handling at compile time
expand_expr(Op, X, O, Q, P) :-
'$unary_op_as_integer'(Op,IOp),
'$do_and'(Q, is( O, IOp, X), P).
% expanding an expression of the form:
% O is Op(X,Y),
% after having expanded into Q
% and giving as result P (the last argument)
% included is some optimization for:
% incrementing and decrementing,
% the elementar arithmetic operations [+,-,*,//]
expand_expr(Op, X, Y, O, Q, Q) :-
number(X), number(Y),
catch(is( O, Op, X, Y),_,fail), !.
expand_expr(+, X, Y, O, Q, P) :- !,
'$preprocess_args_for_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$plus'(X1,Y1,O), F),
'$do_and'(Q, F, P).
expand_expr(-, X, Y, O, Q, P) :-
var(X), number(Y),
Z is -Y, !,
expand_expr(+, Z, X, O, Q, P).
expand_expr(-, X, Y, O, Q, P) :- !,
'$preprocess_args_for_non_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$minus'(X1,Y1,O), F),
'$do_and'(Q, F, P).
expand_expr(*, X, Y, O, Q, P) :- !,
'$preprocess_args_for_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$times'(X1,Y1,O), F),
'$do_and'(Q, F, P).
expand_expr(//, X, Y, O, Q, P) :-
nonvar(Y), Y == 0, !,
'$binary_op_as_integer'(//,IOp),
'$do_and'(Q, is(O,IOp,X,Y), P).
expand_expr(//, X, Y, O, Q, P) :- !,
'$preprocess_args_for_non_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$div'(X1,Y1,O), F),
'$do_and'(Q, F, P).
expand_expr(/\, X, Y, O, Q, P) :- !,
'$preprocess_args_for_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$and'(X1,Y1,O), F),
'$do_and'(Q, F, P).
expand_expr(\/, X, Y, O, Q, P) :- !,
'$preprocess_args_for_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$or'(X1,Y1,O), F),
'$do_and'(Q, F, P).
expand_expr(<<, X, Y, O, Q, P) :-
var(X), number(Y), Y < 0,
Z is -Y, !,
expand_expr(>>, X, Z, O, Q, P).
expand_expr(<<, X, Y, O, Q, P) :- !,
'$preprocess_args_for_non_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$sll'(X1,Y1,O), F),
'$do_and'(Q, F, P).
expand_expr(>>, X, Y, O, Q, P) :-
var(X), number(Y), Y < 0,
Z is -Y, !,
expand_expr(<<, X, Z, O, Q, P).
expand_expr(>>, X, Y, O, Q, P) :- !,
'$preprocess_args_for_non_commutative'(X, Y, X1, Y1, E),
'$do_and'(E, '$slr'(X1,Y1,O), F),
'$do_and'(Q, F, P).
expand_expr(Op, X, Y, O, Q, P) :-
'$binary_op_as_integer'(Op,IOp),
'$do_and'(Q, is(O,IOp,X,Y), P).
'$preprocess_args_for_commutative'(X, Y, X, Y, true) :-
var(X), var(Y), !.
'$preprocess_args_for_commutative'(X, Y, X, Y, true) :-
var(X), integer(Y), \+ '$bignum'(Y), !.
'$preprocess_args_for_commutative'(X, Y, X, Z, Z = Y) :-
var(X), !.
'$preprocess_args_for_commutative'(X, Y, Y, X, true) :-
integer(X), \+ '$bignum'(X), var(Y), !.
'$preprocess_args_for_commutative'(X, Y, Z, X, Z = Y) :-
integer(X), \+ '$bignum'(X), !.
'$preprocess_args_for_commutative'(X, Y, Z, W, E) :-
'$do_and'(Z = X, Y = W, E).
'$preprocess_args_for_non_commutative'(X, Y, X, Y, true) :-
var(X), var(Y), !.
'$preprocess_args_for_non_commutative'(X, Y, X, Y, true) :-
var(X), integer(Y), \+ '$bignum'(Y), !.
'$preprocess_args_for_non_commutative'(X, Y, X, Z, Z = Y) :-
var(X), !.
'$preprocess_args_for_non_commutative'(X, Y, X, Y, true) :-
integer(X), \+ '$bignum'(X), var(Y), !.
'$preprocess_args_for_non_commutative'(X, Y, X, Z, Z = Y) :-
integer(X), \+ '$bignum'(X), !.
'$preprocess_args_for_non_commutative'(X, Y, Z, W, E) :-
'$do_and'(Z = X, Y = W, E).
'$goal_expansion_allowed'(phrase(NT,_Xs0,_Xs), Mod) :-
callable(NT),
atom(Mod).
%% contains_illegal_dcgnt(+Term) is semidet.
%
% True if Term contains a non-terminal we cannot deal with using
% goal-expansion. The test is too general approximation, but safe.
'$contains_illegal_dcgnt'(NT) :-
functor(NT, _, A),
between(1, A, I),
arg(I, NT, AI),
nonvar(AI),
( AI = ! ; AI = phrase(_,_,_) ), !.
% write(contains_illegal_nt(NT)), % JW: we do not want to write
% nl.
'$harmless_dcgexception'(instantiation_error). % ex: phrase(([1],x:X,[3]),L)
'$harmless_dcgexception'(type_error(callable,_)). % ex: phrase(27,L)
:- set_value('$c_arith',true).
/**
@}
*/

View File

@@ -1,168 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: arithpreds.yap *
* Last rev: *
* mods: *
* comments: arithmetical predicates *
* *
*************************************************************************/
%% @{
/**
@file arithpreds.yap
@addtogroup arithmetic_preds
*/
:- system_module(arithmetic_predicates, [
plus/3,
succ/2], []).
:- use_system_module( '$_errors', ['$do_error'/2]).
/** @pred succ(? _Int1_:int, ? _Int2_:int) is det
*
True if _Int2_ = _Int1_ + 1 and _Int1_ \>= 0. At least
one of the arguments must be instantiated to a natural number. This
predicate raises the domain-error not_less_than_zero if called with
a negative integer. E.g. `succ(X, 0)` fails silently and `succ(X, -1)`
raises a domain-error. The behaviour to deal with natural numbers
only was defined by Richard O'Keefe to support the common
count-down-to-zero in a natural way.
*/
% M and N nonnegative integers, N is the successor of M
succ(M,N) :-
(
var(M)
->
(
integer(N),
N > 0
->
'$plus'(N,-1,M)
;
'$succ_error'(M,N)
)
;
integer(M),
M >= 0
->
(
var(N)
->
'$plus'(M,1,N)
;
integer(N),
N > 0
->
'$plus'(M,1,N)
;
'$succ_error'(M,N)
)
;
'$succ_error'(M,N)
).
'$succ_error'(M,N) :-
var(M),
var(N), !,
'$do_error'(instantiation_error,succ(M,N)).
'$succ_error'(M,N) :-
nonvar(M),
\+ integer(M),
'$do_error'(type_error(integer, M),succ(M,N)).
'$succ_error'(M,N) :-
nonvar(M),
M < 0,
'$do_error'(domain_error(not_less_than_zero, M),succ(M,N)).
'$succ_error'(M,N) :-
nonvar(N),
\+ integer(N),
'$do_error'(type_error(integer, N),succ(M,N)).
'$succ_error'(M,N) :-
nonvar(N),
N < 0,
'$do_error'(domain_error(not_less_than_zero, N),succ(M,N)).
/** @pred plus(? _Int1_:int, ? _Int2_:int, ? _Int3_:int) is det
True if _Int3_ = _Int1_ + _Int2_. At least two of the
three arguments must be instantiated to integers.
@}
*/
plus(X, Y, Z) :-
(
var(X)
->
(
integer(Y), integer(Z)
->
'$minus'(Z,Y,X)
;
'$plus_error'(X,Y,Z)
)
;
integer(X)
->
(
var(Y)
->
(
integer(Z)
->
'$minus'(Z,X,Y)
;
'$plus_error'(X,Y,Z)
)
;
integer(Y)
->
(
integer(Z)
->
'$minus'(Z,Y,X)
;
var(Z)
->
'$plus'(X,Y,Z)
;
'$plus_error'(X,Y,Z)
)
;
'$plus_error'(X,Y,Z)
)
;
'$plus_error'(X,Y,Z)
).
'$plus_error'(X,Y,Z) :-
nonvar(X),
\+ integer(X),
'$do_error'(type_error(integer, X),plus(X,Y,Z)).
'$plus_error'(X,Y,Z) :-
nonvar(Y),
\+ integer(Y),
'$do_error'(type_error(integer, Y),plus(X,Y,Z)).
'$plus_error'(X,Y,Z) :-
nonvar(Z),
\+ integer(Z),
'$do_error'(type_error(integer, Z),plus(X,Y,Z)).
'$plus_error'(X,Y,Z) :-
'$do_error'(instantiation_error,plus(X,Y,Z)).

View File

@@ -1,107 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: arrays.yap *
* Last rev: *
* mods: *
* comments: Array Manipulation *
* *
*************************************************************************/
%% @{
/**
@addtogroup YAPArrays
*/
%
% These are the array built-in predicates. They will only work if
% YAP_ARRAYS is defined in Yap.h
%
/** @pred array(+ _Name_, + _Size_)
Creates a new dynamic array. The _Size_ must evaluate to an
integer. The _Name_ may be either an atom (named array) or an
unbound variable (anonymous array).
Dynamic arrays work as standard compound terms, hence space for the
array is recovered automatically on backtracking.
*/
array(Obj, Size) :-
'$create_array'(Obj, Size).
% arithmetical optimization
'$c_arrays'((P:-Q),(NP:-QF)) :- !,
'$c_arrays_body'(Q, QI),
'$c_arrays_head'(P, NP, QI, QF).
'$c_arrays'(P, NP) :-
'$c_arrays_fact'(P, NP).
'$c_arrays_body'(P, P) :-
var(P), !.
'$c_arrays_body'((P0,Q0), (P,Q)) :- !,
'$c_arrays_body'(P0, P),
'$c_arrays_body'(Q0, Q).
'$c_arrays_body'((P0;Q0), (P;Q)) :- !,
'$c_arrays_body'(P0, P),
'$c_arrays_body'(Q0, Q).
'$c_arrays_body'((P0->Q0), (P->Q)) :- !,
'$c_arrays_body'(P0, P),
'$c_arrays_body'(Q0, Q).
'$c_arrays_body'(P, NP) :- '$c_arrays_lit'(P, NP).
%
% replace references to arrays to references to built-ins.
%
'$c_arrays_lit'(G, GL) :-
'$array_references'(G, NG, VL),
'$add_array_entries'(VL, NG, GL).
'$c_arrays_head'(G, NG, B, NB) :-
'$array_references'(G, NG, VL),
'$add_array_entries'(VL, B, NB).
'$c_arrays_fact'(G, NG) :-
'$array_references'(G, IG, VL),
(VL = [] -> NG = G;
NG = (IG :- NB), '$add_array_entries'(VL, true, NB)).
'$add_array_entries'([], NG, NG).
'$add_array_entries'([Head|Tail], G, (Head, NG)) :-
'$add_array_entries'(Tail, G, NG).
/** @pred static_array_properties(? _Name_, ? _Size_, ? _Type_)
Show the properties size and type of a static array with name
_Name_. Can also be used to enumerate all current
static arrays.
This built-in will silently fail if the there is no static array with
that name.
*/
static_array_properties(Name, Size, Type) :-
atom(Name), !,
'$static_array_properties'(Name, Size, Type).
static_array_properties(Name, Size, Type) :-
var(Name), !,
current_atom(Name),
'$static_array_properties'(Name, Size, Type).
static_array_properties(Name, Size, Type) :-
'$do_error'(type_error(atom,Name),static_array_properties(Name,Size,Type)).
%% @}

View File

@@ -1,211 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-2014 *
* *
*************************************************************************/
/**
* @file atoms.yap
*
*/
:- system_module( '$_atoms', [
atom_concat/2,
string_concat/2,
atomic_list_concat/2,
atomic_list_concat/3,
current_atom/1], []).
:- use_system_module( '$_errors', ['$do_error'/2]).
/**
* @addtogroup Predicates_on_Atoms
*
*/
/** @pred atom_concat(+ As, ? A)
The predicate holds when the first argument is a list of atoms, and the
second unifies with the atom obtained by concatenating all the atoms in
the first list.
*/
atom_concat(Xs,At) :-
( var(At) ->
'$atom_concat'(Xs, At )
;
'$atom_concat_constraints'(Xs, 0, At, Unbound),
'$process_atom_holes'(Unbound)
).
% the constraints are of the form hole: HoleAtom, Begin, Atom, End
'$atom_concat_constraints'([At], 0, At, []) :- !.
'$atom_concat_constraints'([At0], mid(Next, At), At, [hole(At0, Next, At, end)]) :- !.
% just slice first atom
'$atom_concat_constraints'([At0|Xs], 0, At, Unbound) :-
atom(At0), !,
sub_atom(At0, 0, _Sz, L, _Ata ),
sub_atom(At, _, L, 0, Atr ), %remainder
'$atom_concat_constraints'(Xs, 0, Atr, Unbound).
% first hole: Follow says whether we have two holes in a row, At1 will be our atom
'$atom_concat_constraints'([At0|Xs], 0, At, [hole(At0, 0, At, Next)|Unbound]) :-
'$atom_concat_constraints'(Xs, mid(Next,_At1), At, Unbound).
% end of a run
'$atom_concat_constraints'([At0|Xs], mid(end, At1), At, Unbound) :-
atom(At0), !,
sub_atom(At, Next, _Sz, L, At0),
sub_atom(At, 0, Next, Next, At1),
sub_atom(At, _, L, 0, Atr), %remainder
'$atom_concat_constraints'(Xs, 0, Atr, Unbound).
'$atom_concat_constraints'([At0|Xs], mid(Next,At1), At, Next, [hole(At0, Next, At, Follow)|Unbound]) :-
'$atom_concat_constraints'(Xs, mid(Follow, At1), At, Unbound).
'$process_atom_holes'([]).
'$process_atom_holes'([hole(At0, Next, At1, End)|Unbound]) :- End == end, !,
sub_atom(At1, Next, _, 0, At0),
'$process_atom_holes'(Unbound).
'$process_atom_holes'([hole(At0, Next, At1, Follow)|Unbound]) :-
sub_atom(At1, Next, Sz, _Left, At0),
Follow is Next+Sz,
'$process_atom_holes'(Unbound).
/** @pred atomic_list_concat(+ _As_,? _A_)
The predicate holds when the first argument is a list of atomic terms, and
the second unifies with the atom obtained by concatenating all the
atomic terms in the first list. The first argument thus may contain
atoms or numbers.
*/
atomic_list_concat(L,At) :-
atomic_concat(L, At).
/** @pred atomic_list_concat(? _As_,+ _Separator_,? _A_)
Creates an atom just like atomic_list_concat/2, but inserts
_Separator_ between each pair of atoms. For example:
~~~~~{.prolog}
?- atomic_list_concat([gnu, gnat], `, `, A).
A = `gnu, gnat`
~~~~~
YAP emulates the SWI-Prolog version of this predicate that can also be
used to split atoms by instantiating _Separator_ and _Atom_ as
shown below.
~~~~~{.prolog}
?- atomic_list_concat(L, -, 'gnu-gnat').
L = [gnu, gnat]
~~~~~
*/
atomic_list_concat(L, El, At) :-
var(El), !,
'$do_error'(instantiation_error,atomic_list_concat(L,El,At)).
atomic_list_concat(L, El, At) :-
ground(L), !,
'$add_els'(L,El,LEl),
atomic_concat(LEl, At).
atomic_list_concat(L, El, At) :-
nonvar(At), !,
'$atomic_list_concat_all'( At, El, L).
'$atomic_list_concat_all'( At, El, [A|L]) :-
sub_atom(At, Pos, 1, Left, El), !,
sub_atom(At, 0, Pos, _, A),
sub_atom(At, _, Left, 0, At1),
'$atomic_list_concat_all'( At1, El, L).
'$atomic_list_concat_all'( At, _El, [At]).
'$add_els'([A,B|L],El,[A,El|NL]) :- !,
'$add_els'([B|L],El,NL).
'$add_els'(L,_,L).
%
% small compatibility hack
'$singletons_in_term'(T,VL) :-
'$variables_in_term'(T,[],V10),
'$sort'(V10, V1),
'$non_singletons_in_term'(T,[],V20),
'$sort'(V20, V2),
'$subtract_lists_of_variables'(V2,V1,VL).
'$subtract_lists_of_variables'([],VL,VL).
'$subtract_lists_of_variables'([_|_],[],[]) :- !.
'$subtract_lists_of_variables'([V1|VL1],[V2|VL2],VL) :-
V1 == V2, !,
'$subtract_lists_of_variables'(VL1,VL2,VL).
'$subtract_lists_of_variables'([V1|VL1],[V2|VL2],[V2|VL]) :-
'$subtract_lists_of_variables'([V1|VL1],VL2,VL).
/** @pred current_atom( _A_)
Checks whether _A_ is a currently defined atom. It is used to find all
currently defined atoms by backtracking.
*/
current_atom(A) :- % check
atom(A), !.
current_atom(A) :- % generate
'$current_atom'(A).
string_concat(Xs,At) :-
( var(At) ->
'$string_concat'(Xs, At )
;
'$string_concat_constraints'(Xs, 0, At, Unbound),
'$process_string_holes'(Unbound)
).
% the constraints are of the form hole: HoleString, Begin, String, End
'$string_concat_constraints'([At], 0, At, []) :- !.
'$string_concat_constraints'([At0], mid(Next, At), At, [hole(At0, Next, At, end)]) :- !.
% just slice first string
'$string_concat_constraints'([At0|Xs], 0, At, Unbound) :-
string(At0), !,
sub_string(At, 0, _Sz, L, At0 ),
sub_string(At, _, L, 0, Atr ), %remainder
'$string_concat_constraints'(Xs, 0, Atr, Unbound).
% first hole: Follow says whether we have two holes in a row, At1 will be our string
'$string_concat_constraints'([At0|Xs], 0, At, [hole(At0, 0, At, Next)|Unbound]) :-
'$string_concat_constraints'(Xs, mid(Next,_At1), At, Unbound).
% end of a run
'$string_concat_constraints'([At0|Xs], mid(end, At1), At, Unbound) :-
string(At0), !,
sub_string(At, Next, _Sz, L, At0),
sub_string(At, 0, Next, Next, At1),
sub_string(At, _, L, 0, Atr), %remainder
'$string_concat_constraints'(Xs, 0, Atr, Unbound).
'$string_concat_constraints'([At0|Xs], mid(Next,At1), At, Next, [hole(At0, Next, At, Follow)|Unbound]) :-
'$string_concat_constraints'(Xs, mid(Follow, At1), At, Unbound).
'$process_string_holes'([]).
'$process_string_holes'([hole(At0, Next, At1, End)|Unbound]) :- End == end, !,
sub_string(At1, Next, _, 0, At0),
'$process_string_holes'(Unbound).
'$process_string_holes'([hole(At0, Next, At1, Follow)|Unbound]) :-
sub_string(At1, Next, Sz, _Left, At0),
Follow is Next+Sz,
'$process_string_holes'(Unbound).
/**
@}
*/

View File

@@ -1,515 +0,0 @@
pattr/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: atts.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: attribute support for Prolog *
* *
*************************************************************************/
/**
@file attributes.yap
@defgroup New_Style_Attribute_Declarations SWI Compatible attributes
@{
@ingroup attributes
*/
:- module('attributes', [delayed_goals/4]).
:- use_system_module( '$_boot', ['$undefp'/1]).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$coroutining', [attr_unify_hook/2]).
:- use_system_module( attributes, [all_attvars/1,
bind_attvar/1,
del_all_atts/1,
del_all_module_atts/2,
get_all_swi_atts/2,
get_module_atts/2,
modules_with_attributes/1,
put_att_term/2,
put_module_atts/2,
unbind_attvar/1,
woken_att_do/4]).
:- dynamic attributes:existing_attribute/4.
:- dynamic attributes:modules_with_attributes/1.
:- dynamic attributes:attributed_module/3.
:- multifile
attributes:attributed_module/3.
:- dynamic existing_attribute/4.
:- dynamic modules_with_attributes/1.
:- dynamic attributed_module/3.
/** @pred get_attr(+ _Var_,+ _Module_,- _Value_)
Request the current _value_ for the attribute named _Module_. If
_Var_ is not an attributed variable or the named attribute is not
associated to _Var_ this predicate fails silently. If _Module_
is not an atom, a type error is raised.
*/
prolog:get_attr(Var, Mod, Att) :-
functor(AttTerm, Mod, 2),
arg(2, AttTerm, Att),
attributes:get_module_atts(Var, AttTerm).
/**
@pred put_attr(+ _Var_,+ _Module_,+ _Value_)
If _Var_ is a variable or attributed variable, set the value for the
attribute named _Module_ to _Value_. If an attribute with this
name is already associated with _Var_, the old value is replaced.
Backtracking will restore the old value (i.e., an attribute is a mutable
term. See also `setarg/3`). This predicate raises a representation error if
_Var_ is not a variable and a type error if _Module_ is not an atom.
*/
prolog:put_attr(Var, Mod, Att) :-
functor(AttTerm, Mod, 2),
arg(2, AttTerm, Att),
attributes:put_module_atts(Var, AttTerm).
/** @pred del_attr(+ _Var_,+ _Module_)
Delete the named attribute. If _Var_ loses its last attribute it
is transformed back into a traditional Prolog variable. If _Module_
is not an atom, a type error is raised. In all other cases this
predicate succeeds regardless whether or not the named attribute is
present.
*/
prolog:del_attr(Var, Mod) :-
functor(AttTerm, Mod, 2),
attributes:del_all_module_atts(Var, AttTerm).
/** @pred del_attrs(+ _Var_)
If _Var_ is an attributed variable, delete <em>all</em> its
attributes. In all other cases, this predicate succeeds without
side-effects.
*/
prolog:del_attrs(Var) :-
attributes:del_all_atts(Var).
/**
@pred get_attrs(+ _Var_,- _Attributes_)
Get all attributes of _Var_. _Attributes_ is a term of the form
`att( _Module_, _Value_, _MoreAttributes_)`, where _MoreAttributes_ is
`[]` for the last attribute.
*/
prolog:get_attrs(AttVar, SWIAtts) :-
attributes:get_all_swi_atts(AttVar,SWIAtts).
/** @pred put_attrs(+ _Var_,+ _Attributes_)
Set all attributes of _Var_. See get_attrs/2 for a description of
_Attributes_.
*/
prolog:put_attrs(_, []).
prolog:put_attrs(V, Atts) :-
cvt_to_swi_atts(Atts, YapAtts),
attributes:put_att_term(V, YapAtts).
cvt_to_swi_atts([], _).
cvt_to_swi_atts(att(Mod,Attribute,Atts), ModAttribute) :-
ModAttribute =.. [Mod, YapAtts, Attribute],
cvt_to_swi_atts(Atts, YapAtts).
/** @pred copy_term(? _TI_,- _TF_,- _Goals_)
Term _TF_ is a variant of the original term _TI_, such that for
each variable _V_ in the term _TI_ there is a new variable _V'_
in term _TF_ without any attributes attached. Attributed
variables are thus converted to standard variables. _Goals_ is
unified with a list that represents the attributes. The goal
`maplist(call, _Goals_)` can be called to recreate the
attributes.
Before the actual copying, `copy_term/3` calls
`attribute_goals/1` in the module where the attribute is
defined.
*/
prolog:copy_term(Term, Copy, Gs) :-
term_attvars(Term, Vs),
( Vs == []
-> Gs = [],
copy_term(Term, Copy)
; findall(Term-Gs,
'$attributes':residuals_and_delete_attributes(Vs, Gs, Term),
[Copy-Gs])
).
residuals_and_delete_attributes(Vs, Gs, Term) :-
attvars_residuals(Vs, Gs, []),
delete_attributes(Term).
attvars_residuals([]) --> [].
attvars_residuals([V|Vs]) -->
{ nonvar(V) }, !,
attvars_residuals(Vs).
attvars_residuals([V|Vs]) -->
( { get_attrs(V, As) }
-> attvar_residuals(As, V)
; []
),
attvars_residuals(Vs).
%
% wake_up_goal is called by the system whenever a suspended goal
% resumes.
%
/* The first case may happen if this variable was used for dif.
In this case, we need a way to keep the original
suspended goal around
*/
%'$wake_up_goal'([Module1|Continuation],G) :-
% '$write'(4,vsc_woke:G+[Module1|Continuation]:'
%'), fail.
prolog:'$wake_up_goal'([Module1|Continuation], LG) :-
% writeln( [Module1|Continuation]:LG),
execute_woken_system_goals(LG),
do_continuation(Continuation, Module1).
%
% in the first two cases restore register immediately and proceed
% to continuation. In the last case take care with modules, but do
% not act as if a meta-call.
%
%
do_continuation('$cut_by'(X), _) :- !,
'$$cut_by'(X).
do_continuation('$restore_regs'(X), _) :- !,
% yap_flag(gc_trace,verbose),
% garbage_collect,
'$restore_regs'(X).
do_continuation('$restore_regs'(X,Y), _) :- !,
% yap_flag(gc_trace,verbose),
% garbage_collect,
'$restore_regs'(X,Y).
do_continuation(Continuation, Module1) :-
execute_continuation(Continuation,Module1).
execute_continuation(Continuation, Module1) :-
'$undefined'(Continuation, Module1), !,
'$current_module'( M ),
current_prolog_flag( M:unknown, Default ),
'$undefp'([Module1|Continuation] , Default ).
execute_continuation(Continuation, Mod) :-
% do not do meta-expansion nor any fancy stuff.
'$execute0'(Continuation, Mod).
execute_woken_system_goals([]).
execute_woken_system_goals(['$att_do'(V,New)|LG]) :-
execute_woken_system_goals(LG),
call_atts(V,New).
%
% what to do when an attribute gets bound
%
call_atts(V,_) :-
nonvar(V), !.
call_atts(V,_) :-
'$att_bound'(V), !.
call_atts(V,New) :-
attributes:get_all_swi_atts(V,SWIAtts),
(
'$undefined'(woken_att_do(V, New, LGoals, DoNotBind), attributes)
->
LGoals = [],
DoNotBind = false
;
attributes:woken_att_do(V, New, LGoals, DoNotBind)
),
( DoNotBind == true
->
attributes:unbind_attvar(V)
;
attributes:bind_attvar(V)
),
do_hook_attributes(SWIAtts, New),
lcall(LGoals).
do_hook_attributes([], _).
do_hook_attributes(att(Mod,Att,Atts), Binding) :-
('$undefined'(attr_unify_hook(Att,Binding), Mod)
->
true
;
Mod:attr_unify_hook(Att, Binding)
),
do_hook_attributes(Atts, Binding).
lcall([]).
lcall([Mod:Gls|Goals]) :-
lcall2(Gls,Mod),
lcall(Goals).
lcall2([], _).
lcall2([Goal|Goals], Mod) :-
call(Mod:Goal),
lcall2(Goals, Mod).
/** @pred call_residue_vars(: _G_, _L_)
Call goal _G_ and unify _L_ with a list of all constrained variables created <em>during</em> execution of _G_:
~~~~~
?- dif(X,Z), call_residue_vars(dif(X,Y),L).
dif(X,Z), call_residue_vars(dif(X,Y),L).
L = [Y],
dif(X,Z),
dif(X,Y) ? ;
no
~~~~~
*/
prolog:call_residue_vars(Goal,Residue) :-
attributes:all_attvars(Vs0),
call(Goal),
attributes:all_attvars(Vs),
% this should not be actually strictly necessary right now.
% but it makes it a safe bet.
sort(Vs, Vss),
sort(Vs0, Vs0s),
'$ord_remove'(Vss, Vs0s, Residue).
'$ord_remove'([], _, []).
'$ord_remove'([V|Vs], [], [V|Vs]).
'$ord_remove'([V1|Vss], [V2|Vs0s], Residue) :-
( V1 == V2 ->
'$ord_remove'(Vss, Vs0s, Residue)
;
V1 @< V2 ->
Residue = [V1|ResidueF],
'$ord_remove'(Vss, [V2|Vs0s], ResidueF)
;
'$ord_remove'([V1|Vss], Vs0s, Residue)
).
/** @pred attribute_goals(+ _Var_,- _Gs_,+ _GsRest_)
This nonterminal, if it is defined in a module, is used by _copy_term/3_
to project attributes of that module to residual goals. It is also
used by the toplevel to obtain residual goals after executing a query.
Normal user code should deal with put_attr/3, get_attr/3 and del_attr/2.
The routines in this section fetch or set the entire attribute list of a
variables. Use of these predicates is anticipated to be restricted to
printing and other special purpose operations.
*/
/** @pred _Module_:attribute_goal( _-Var_, _-Goal_)
User-defined procedure, called to convert the attributes in _Var_ to
a _Goal_. Should fail when no interpretation is available.
*/
attvar_residuals(att(Module,Value,As), V) -->
( { nonvar(V) }
-> % a previous projection predicate could have instantiated
% this variable, for example, to avoid redundant goals
[]
; generate_goals( V, As, Value, Module)
).
generate_goals( V, _, Value, Module) -->
{ attributes:module_has_attributes(Module) },
% like run, put attributes back first
{ Value =.. [Name,_|Vs],
NValue =.. [Name,_|Vs],
attributes:put_module_atts(V,NValue)
},
{ current_predicate(Module:attribute_goal/2) },
{ call(Module:attribute_goal(V, Goal)) },
dot_list(Goal),
[put_attr(V, Module, Value)].
generate_goals( V, _, _Value , Module) -->
{ '$pred_exists'(attribute_goals(_,_,_), Module) },
call(Module:attribute_goals(V) ).
attributes:module_has_attributes(Mod) :-
attributes:attributed_module(Mod, _, _), !.
list([]) --> [].
list([L|Ls]) --> [L], list(Ls).
dot_list((A,B)) --> !, dot_list(A), dot_list(B).
dot_list(A) --> [A].
delete_attributes(Term) :-
term_attvars(Term, Vs),
delete_attributes_(Vs).
delete_attributes_([]).
delete_attributes_([V|Vs]) :-
del_attrs(V),
delete_attributes_(Vs).
/** @pred call_residue(: _G_, _L_)
Call goal _G_. If subgoals of _G_ are still blocked, return
a list containing these goals and the variables they are blocked in. The
goals are then considered as unblocked. The next example shows a case
where dif/2 suspends twice, once outside call_residue/2,
and the other inside:
~~~~~
?- dif(X,Y),
call_residue((dif(X,Y),(X = f(Z) ; Y = f(Z))), L).
X = f(Z),
L = [[Y]-dif(f(Z),Y)],
dif(f(Z),Y) ? ;
Y = f(Z),
L = [[X]-dif(X,f(Z))],
dif(X,f(Z)) ? ;
no
~~~~~
The system only reports one invocation of dif/2 as having
suspended.
*/
prolog:call_residue(Goal,Residue) :-
var(Goal), !,
'$do_error'(instantiation_error,call_residue(Goal,Residue)).
prolog:call_residue(Module:Goal,Residue) :-
atom(Module), !,
call_residue(Goal,Module,Residue).
prolog:call_residue(Goal,Residue) :-
'$current_module'(Module),
call_residue(Goal,Module,Residue).
call_residue(Goal,Module,Residue) :-
prolog:call_residue_vars(Module:Goal,NewAttVars),
(
attributes:modules_with_attributes([_|_])
->
project_attributes(NewAttVars, Module:Goal)
;
true
),
copy_term(Goal, Goal, Residue).
attributes:delayed_goals(G, Vs, NVs, Gs) :-
project_delayed_goals(G),
% term_factorized([G|Vs], [_|NVs], Gs).
copy_term([G|Vs], [_|NVs], Gs).
project_delayed_goals(G) :-
% SICStus compatible step,
% just try to simplify store by projecting constraints
% over query variables.
% called by top_level to find out about delayed goals
attributes:modules_with_attributes([_|_]), !,
attributes:all_attvars(LAV),
LAV = [_|_],
project_attributes(LAV, G), !.
project_delayed_goals(_).
attributed(G, Vs) :-
term_variables(G, LAV),
att_vars(LAV, Vs).
att_vars([], []).
att_vars([V|LGs], [V|AttVars]) :- attvar(V), !,
att_vars(LGs, AttVars).
att_vars([_|LGs], AttVars) :-
att_vars(LGs, AttVars).
% make sure we set the suspended goal list to its previous state!
% make sure we have installed a SICStus like constraint solver.
/** @pred _Module_:project_attributes(+AttrVars, +Goal)
Given a goal _Goa]l_ with variables _QueryVars_ and list of attributed
variables _AttrVars_, project all attributes in _AttrVars_ to
_QueryVars_. Although projection is constraint system dependent,
typically this will involve expressing all constraints in terms of
_QueryVars_ and considering all remaining variables as existentially
quantified.
Projection interacts with attribute_goal/2 at the Prolog top
level. When the query succeeds, the system first calls
project_attributes/2. The system then calls
attribute_goal/2 to get a user-level representation of the
constraints. Typically, project_attributes/2 will convert from the
original constraints into a set of new constraints on the projection,
and these constraints are the ones that will have an
attribute_goal/2 handler.
*/
project_attributes(AllVs, G) :-
attributes:modules_with_attributes(LMods),
LMods = [_|_],
term_variables(G, InputVs),
pick_att_vars(InputVs, AttIVs),
project_module(LMods, AttIVs, AllVs).
pick_att_vars([],[]).
pick_att_vars([V|L],[V|NL]) :- attvar(V), !,
pick_att_vars(L,NL).
pick_att_vars([_|L],NL) :-
pick_att_vars(L,NL).
project_module([], _, _).
project_module([Mod|LMods], LIV, LAV) :-
'$pred_exists'(project_attributes(LIV, LAV),Mod),
call(Mod:project_attributes(LIV, LAV)), !,
attributes:all_attvars(NLAV),
project_module(LMods,LIV,NLAV).
project_module([_|LMods], LIV, LAV) :-
project_module(LMods,LIV,LAV).
%% @}

File diff suppressed because it is too large Load Diff

View File

@@ -1,140 +0,0 @@
/**
* @file bootlists.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Thu Nov 19 09:54:00 2015
*
* @addtogroup lists
* @{
*/
:- system_module( '$_lists', [], []).
:- set_prolog_flag(source, true). % source.
% memberchk(+Element, +Set)
% means the same thing, but may only be used to test whether a known
% Element occurs in a known Set. In return for this limited use, it
% is more efficient when it is applicable.
/** @pred memberchk(+ _Element_, + _Set_)
As member/2, but may only be used to test whether a known
_Element_ occurs in a known Set. In return for this limited use, it
is more efficient when it is applicable.
*/
lists:memberchk(X,[X|_]) :- !.
lists:memberchk(X,[_|L]) :-
lists:memberchk(X,L).
%% member(?Element, ?Set)
% is true when Set is a list, and Element occurs in it. It may be used
% to test for an element or to enumerate all the elements by backtracking.
% Indeed, it may be used to generate the Set!
/** @pred member(? _Element_, ? _Set_)
True when _Set_ is a list, and _Element_ occurs in it. It may be used
to test for an element or to enumerate all the elements by backtracking.
*/
lists:member(X,[X|_]).
lists:member(X,[_|L]) :-
lists:member(X,L).
%% @pred identical_member(?Element, ?Set) is nondet
%
% identical_member holds true when Set is a list, and Element is
% exactly identical to one of the elements that occurs in it.
lists:identical_member(X,[Y|M]) :-
(
X == Y
;
M \= [], lists:identical_member(X,M)
).
/** @pred append(? _List1_,? _List2_,? _List3_)
Succeeds when _List3_ unifies with the concatenation of _List1_
and _List2_. The predicate can be used with any instantiation
pattern (even three variables).
*/
lists:append([], L, L).
lists:append([H|T], L, [H|R]) :-
lists:append(T, L, R).
:- set_prolog_flag(source, true). % :- no_source.
% lists:delete(List, Elem, Residue)
% is true when List is a list, in which Elem may or may not occur, and
% Residue is a copy of List with all elements identical to Elem lists:deleted.
/** @pred delete(+ _List_, ? _Element_, ? _Residue_)
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee
True when _List_ is a list, in which _Element_ may or may not
occur, and _Residue_ is a copy of _List_ with all elements
identical to _Element_ deleted.
eeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeeee
*/
lists:delete([], _, []).
lists:delete([Head|List], Elem, Residue) :-
Head = Elem,
lists:delete(List, Elem, Residue).
lists:delete([Head|List], Elem, [Head|Residue]) :-
lists:delete(List, Elem, Residue).
:- set_prolog_flag(source, false). % disable source.
% length of a list.
/** @pred length(? _L_,? _S_)
Unify the well-defined list _L_ with its length. The procedure can
be used to find the length of a pre-defined list, or to build a list
of length _S_.
*/
prolog:length(L, M) :-
'$skip_list'(L, M, M0, R),
( var(R) -> '$$_length'(R, M, M0) ;
R == []
).
%
% in case A1 is unbound or a difference list, things get tricky
%
'$$_length'(R, M, M0) :-
( var(M) -> '$$_length1'(R,M,M0)
; M >= M0 -> '$$_length2'(R,M,M0) ).
%
% Size is unbound, generate lists
%
'$$_length1'([], M, M).
'$$_length1'([_|L], O, N) :-
M is N + 1,
'$$_length1'(L, O, M).
%
% Size is bound, generate single list
%
'$$_length2'(NL, O, N) :-
( N =:= O -> NL = [];
M is N + 1, NL = [_|L], '$$_length2'(L, O, M) ).
%% @}

View File

@@ -1,152 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: callcount.yap *
* Last rev: 8/2/02 *
* mods: *
* comments: Some profiling predicates available in yap *
* *
*************************************************************************/
%% @{
/** @defgroup Profiling Profiling Prolog Programs
@ingroup extensions
YAP includes two profilers. The count profiler keeps information on the
number of times a predicate was called. This information can be used to
detect what are the most commonly called predicates in the program. The
count profiler can be compiled by setting YAP's flag profiling
to `on`. The time-profiler is a `gprof` profiler, and counts
how many ticks are being spent on specific predicates, or on other
system functions such as internal data-base accesses or garbage collects.
The YAP profiling sub-system is currently under
development. Functionality for this sub-system will increase with newer
implementation.
*/
%% @{
/** @defgroup Call_Counting Counting Calls
@ingroup Profiling
Predicates compiled with YAP's flag call_counting set to
`on` update counters on the numbers of calls and of
retries. Counters are actually decreasing counters, so that they can be
used as timers. Three counters are available:
+ `calls`: number of predicate calls since execution started or since
system was reset;
+ `retries`: number of retries for predicates called since
execution started or since counters were reset;
+ `calls_and_retries`: count both on predicate calls and
retries.
These counters can be used to find out how many calls a certain
goal takes to execute. They can also be used as timers.
The code for the call counters piggybacks on the profiling
code. Therefore, activating the call counters also activates the profiling
counters.
These are the predicates that access and manipulate the call counters.
*/
:- system_module( '$_callcount', [call_count/3,
call_count_data/3,
call_count_reset/0], []).
:- use_system_module( '$_errors', ['$do_error'/2]).
/** @pred call_count_data(- _Calls_, - _Retries_, - _CallsAndRetries_)
Give current call count data. The first argument gives the current value
for the _Calls_ counter, next the _Retries_ counter, and last
the _CallsAndRetries_ counter.
*/
call_count_data(Calls, Retries, Both) :-
'$call_count_info'(Calls, Retries, Both).
/** @pred call_count_reset
Reset call count counters. All timers are also reset.
*/
call_count_reset :-
'$call_count_reset'.
/** @pred call_count(? _CallsMax_, ? _RetriesMax_, ? _CallsAndRetriesMax_)
Set call counters as timers. YAP will generate an exception
if one of the instantiated call counters decreases to 0:
+ _CallsMax_
throw the exception `call_counter` when the
counter `calls` reaches 0;
+ _RetriesMax_
throw the exception `retry_counter` when the
counter `retries` reaches 0;
+ _CallsAndRetriesMax_
throw the exception
`call_and_retry_counter` when the counter `calls_and_retries`
reaches 0.
YAP will ignore counters that are called with unbound arguments.
Next, we show a simple example of how to use call counters:
~~~~~{.prolog}
?- yap_flag(call_counting,on), [-user]. l :- l. end_of_file. yap_flag(call_counting,off).
yes
yes
?- catch((call_count(10000,_,_),l),call_counter,format("limit_exceeded.~n",[])).
limit_exceeded.
yes
~~~~~
Notice that we first compile the looping predicate `l/0` with
call_counting `on`. Next, we catch/3 to handle an
exception when `l/0` performs more than 10000 reductions.
*/
call_count(Calls, Retries, Both) :-
'$check_if_call_count_on'(Calls, CallsOn),
'$check_if_call_count_on'(Retries, RetriesOn),
'$check_if_call_count_on'(Both, BothOn),
'$call_count_set'(Calls, CallsOn, Retries, RetriesOn, Both, BothOn).
'$check_if_call_count_on'(Calls, 1) :- integer(Calls), !.
'$check_if_call_count_on'(Calls, 0) :- var(Calls), !.
'$check_if_call_count_on'(Calls, A) :-
'$do_error'(type_error(integer,Calls),call_count(A)).
%% @}
/**
@}
*/

View File

@@ -1,173 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: checker.yap *
* comments: style checker for Prolog *
* *
* Last rev: $Date: 2008-03-31 22:56:22 $,$Author: vsc $ *
* *
*************************************************************************/
:- system_module( style_checker, [no_style_check/1,
style_check/1], ['$check_term'/5,
'$sv_warning'/2,
'$syntax_check_discontiguous'/2,
'$syntax_check_multiple'/2,
'$syntax_check_single_var'/2]).
%% @{
/**
@defgroup YAPStyle Checker
@ingroup YAPCompilerSettings
YAP implements a style-checker thay currently verifies whether:
1 named variables occur once in a clause.
2 clauses from dofferent predicates are mixed together.
3 clauses for the same predicate occur in different files.
One can declare a predicate to be discontiguous (see the
discontiguous/1 declaration) and/or multifile/1.
*/
/*
@pred style_check(+ _X_)
Turns on style checking according to the attribute specified by _X_,
which must be one of the following:
+ single_var
Checks single occurrences of named variables in a clause.
+ discontiguous
Checks non-contiguous clauses for the same predicate in a file.
+ multiple
Checks the presence of clauses for the same predicate in more than one
file when the predicate has not been declared as `multifile`
+ all
Performs style checking for all the cases mentioned above.
By default, style checking is disabled in YAP unless we are in
`sicstus` or `iso` language mode.
The style_check/1 built-in is now deprecated. Please use
`set_prolog_flag/1` instead.
**/
%
% A Small style checker for YAP
:- op(1150, fx, [multifile,discontiguous]).
style_check(V) :- var(V), !, fail.
style_check(V) :-
\+atom(V),
\+ is_list(V),
V \= + _,
V \= - _, !,
'$do_error'( type_error('+|-|?(Flag)', V), style_check(V) ).
style_check(V) :-
\+atom(V),
\+ is_list(V),
V \= + _,
V \= + _, !,
'$do_error'( domain_error(style_name, V), style_check(V) ).
style_check(all) :-
style_check( [ singleton, discontiguous, multiple ] ).
style_check(+X) :-
style_check(X).
style_check(single_var) :-
style_check( singleton ).
style_check(singleton) :-
yap_flag( single_var_warnings, true ).
style_check(-single_var) :-
yap_flag( single_var_warnings, false ).
style_check(-singleton) :-
yap_flag( single_var_warnings, false ).
style_check(discontiguous) :-
yap_flag( discontiguous_warnings, true ).
style_check(-discontiguous) :-
yap_flag( discontiguous_warnings, false ).
style_check(multiple) :-
yap_flag( redefine_warnings, true ).
style_check(-multiple) :-
yap_flag( redefine_warnings, false ).
style_check(no_effect).
style_check(+no_effect) .
style_check(-no_effect).
style_check(var_branches).
style_check(+var_branches) :-
'$style_checker'( [ var_branches ] ).
style_check(-var_branches) :-
'$style_checker'( [ -var_branches ] ).
style_check(atom).
style_check(+atom) :-
'$style_checker'( [ atom ] ).
style_check(-atom) :-
'$style_checker'( [ -atom ] ).
style_check(charset) :-
'$style_checker'( [ charset ] ).
style_check(+charset) :-
'$style_checker'( [ charset ] ).
style_check(-charset) :-
'$style_checker'( [ -charset ] ).
style_check('?'(Info) ) :-
L = [ singleton, discontiguous, multiple ],
( lists:member(Style, L ) -> Info = +Style ; Info = -Style ).
style_check([]).
style_check([H|T]) :- style_check(H), style_check(T).
/** @pred no_style_check(+ _X_)
Turns off style checking according to the attribute specified by
_X_, which have the same meaning as in style_check/1.
The no_style_check/1 built-in is now deprecated. Please use
`set_prolog_flag/1` instead.
**/
no_style_check(V) :- var(V), !, fail.
no_style_check(all) :-
'$style_checker'( [ -singleton, -discontiguous, -multiple ] ).
no_style_check(-single_var) :-
'$style_checker'( [ -singleton ] ).
no_style_check(-singleton) :-
'$style_checker'( [ -singleton ] ).
no_style_check(-discontiguous) :-
'$style_checker'( [ -discontiguous ] ).
no_style_check(-multiple) :-
'$style_checker'( [ -multiple ] ).
no_style_check([]).
no_style_check([H|T]) :- no_style_check(H), no_style_check(T).
/** @pred discontiguous(+ _G_) is iso
Avoid warnings from the sytax checker.
Declare that the predicate _G_ or list of predicates are discontiguous
procedures, that is, clauses for discontigous procedures may be
separated by clauses from other procedures.
*/
discontiguous(P) :- '$discontiguous'(P).
/*
@}
*/

File diff suppressed because it is too large Load Diff

View File

@@ -1,648 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: control.yap *
* Last rev: 20/08/09 *
* mods: *
* comments: control predicates available in yap *
* *
*************************************************************************/
/**
* @file control.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Thu Nov 19 10:26:35 2015
*
* @brief Control Predicates
*
*
*/
:- system_module( '$_control', [at_halt/1,
b_getval/2,
break/0,
call/2,
call/3,
call/4,
call/5,
call/6,
call/7,
call/8,
call/9,
call/10,
call/11,
call/12,
call_cleanup/2,
call_cleanup/3,
forall/2,
garbage_collect/0,
garbage_collect_atoms/0,
gc/0,
grow_heap/1,
grow_stack/1,
halt/0,
halt/1,
if/3,
ignore/1,
nb_getval/2,
nogc/0,
notrace/1,
once/1,
prolog_current_frame/1,
prolog_initialization/1,
setup_call_catcher_cleanup/4,
setup_call_cleanup/3,
version/0,
version/1], ['$run_atom_goal'/1,
'$set_toplevel_hook'/1]).
:- use_system_module( '$_boot', ['$call'/4,
'$disable_debugging'/0,
'$do_live'/0,
'$enable_debugging'/0,
'$system_catch'/4,
'$version'/0]).
:- use_system_module( '$_debug', ['$init_debugger'/0]).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_utils', ['$getval_exception'/3]).
:- use_system_module( '$coroutining', [freeze_goal/2]).
/**
@addtogroup YAPControl
%% @{
*/
/** @pred once(: _G_) is iso
Execute the goal _G_ only once. The predicate is defined by:
~~~~~{.prolog}
once(G) :- call(G), !.
~~~~~
Note that cuts inside once/1 can only cut the other goals inside
once/1.
*/
once(G) :-
strip_module(G, M, C),
'$meta_call'(C, M),
!.
/** @pred forall(: _Cond_,: _Action_)
For all alternative bindings of _Cond_ _Action_ can be
proven. The example verifies that all arithmetic statements in the list
_L_ are correct. It does not say which is wrong if one proves wrong.
~~~~~{.prolog}
?- forall(member(Result = Formula, [2 = 1 + 1, 4 = 2 * 2]),
Result =:= Formula).
~~~~~
*/
/** @pred forall(+ _Cond_,+ _Action_)
For all alternative bindings of _Cond_ _Action_ can be proven.
The next example verifies that all arithmetic statements in the list
_L_ are correct. It does not say which is wrong if one proves wrong.
~~~~~
?- forall(member(Result = Formula, [2 = 1 + 1, 4 = 2 * 2]),
Result =:= Formula).
~~~~~
*/
forall(Cond, Action) :- \+((Cond, \+(Action))).
/** @pred ignore(: _Goal_)
Calls _Goal_ as once/1, but succeeds, regardless of whether
`Goal` succeeded or not. Defined as:
~~~~~{.prolog}
ignore(Goal) :-
Goal, !.
ignore(_).
~~~~~
*/
ignore(Goal) :- (Goal->true;true).
notrace(G) :-
strip_module(G, M, G1),
( '$$save_by'(CP),
'$debug_stop'( State ),
'$call'(G1, CP, G, M),
'$$save_by'(CP2),
(CP == CP2 -> ! ; '$debug_state'( NState ), ( true ; '$debug_restart'(NState), fail ) ),
'$debug_restart'( State )
;
'$debug_restart'( State ),
fail
).
/** @pred if(? _G_,? _H_,? _I_)
Call goal _H_ once per each solution of goal _H_. If goal
_H_ has no solutions, call goal _I_.
The built-in `if/3` is similar to `->/3`, with the difference
that it will backtrack over the test goal. Consider the following
small data-base:
~~~~~{.prolog}
a(1). b(a). c(x).
a(2). b(b). c(y).
~~~~~
Execution of an `if/3` query will proceed as follows:
~~~~~{.prolog}
?- if(a(X),b(Y),c(Z)).
X = 1,
Y = a ? ;
X = 1,
Y = b ? ;
X = 2,
Y = a ? ;
X = 2,
Y = b ? ;
no
~~~~~
The system will backtrack over the two solutions for `a/1` and the
two solutions for `b/1`, generating four solutions.
Cuts are allowed inside the first goal _G_, but they will only prune
over _G_.
If you want _G_ to be deterministic you should use if-then-else, as
it is both more efficient and more portable.
*/
if(X,Y,Z) :-
(
CP is '$last_choice_pt',
'$call'(X,CP,if(X,Y,Z),M),
'$execute'(X),
'$clean_ifcp'(CP),
'$call'(Y,CP,if(X,Y,Z),M)
;
'$call'(Z,CP,if(X,Y,Z),M)
).
call(X,A) :- '$execute'(X,A).
call(X,A1,A2) :- '$execute'(X,A1,A2).
/** @pred call(+ _Closure_,...,? _Ai_,...) is iso
Meta-call where _Closure_ is a closure that is converted into a goal by
appending the _Ai_ additional arguments. The number of arguments varies
between 0 and 10.
*/
call(X,A1,A2,A3) :- '$execute'(X,A1,A2,A3).
call(X,A1,A2,A3,A4) :- '$execute'(X,A1,A2,A3,A4).
call(X,A1,A2,A3,A4,A5) :- '$execute'(X,A1,A2,A3,A4,A5).
call(X,A1,A2,A3,A4,A5,A6) :- '$execute'(X,A1,A2,A3,A4,A5,A6).
call(X,A1,A2,A3,A4,A5,A6,A7) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7).
call(X,A1,A2,A3,A4,A5,A6,A7,A8) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7,A8).
call(X,A1,A2,A3,A4,A5,A6,A7,A8,A9) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7,A8,A9).
call(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10).
call(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11) :- '$execute'(X,A1,A2,A3,A4,A5,A6,A7,A8,A9,A10,A11).
/** @pred call_cleanup(: _Goal_, : _CleanUpGoal_)
This is similar to call_cleanup/1 but with an additional
_CleanUpGoal_ which gets called after _Goal_ is finished.
*/
call_cleanup(Goal, Cleanup) :-
setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup).
call_cleanup(Goal, Catcher, Cleanup) :-
setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup).
/** @pred setup_call_cleanup(: _Setup_,: _Goal_, : _CleanUpGoal_)
Calls `(Setup, Goal)`. For each sucessful execution of _Setup_,
calling _Goal_, the cleanup handler _Cleanup_ is guaranteed to be
called exactly once. This will happen after _Goal_ completes, either
through failure, deterministic success, commit, or an exception.
_Setup_ will contain the goals that need to be protected from
asynchronous interrupts such as the ones received from
`call_with_time_limit/2` or thread_signal/2. In most uses, _Setup_
will perform temporary side-effects required by _Goal_ that are
finally undone by _Cleanup_.
*/
setup_call_cleanup(Setup,Goal, Cleanup) :-
setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).
/** @pred call_with_args(+ _Name_,...,? _Ai_,...)
Meta-call where _Name_ is the name of the procedure to be called and
the _Ai_ are the arguments. The number of arguments varies between 0
and 10. New code should use `call/N` for better portability.
If _Name_ is a complex term, then call_with_args/n behaves as
call/n:
~~~~~{.prolog}
call(p(X1,...,Xm), Y1,...,Yn) :- p(X1,...,Xm,Y1,...,Yn).
~~~~~
*/
%%% Some "dirty" predicates
% Only efective if yap compiled with -DDEBUG
% this predicate shows the code produced by the compiler
'$show_code' :- '$debug'(0'f). %' just make emacs happy
/** @pred grow_heap(+ _Size_)
Increase heap size _Size_ kilobytes.
*/
grow_heap(X) :- '$grow_heap'(X).
/** @pred grow_stack(+ _Size_)
Increase stack size _Size_ kilobytes
*/
grow_stack(X) :- '$grow_stack'(X).
%
% gc() expects to be called from "call". Make sure it has an
% environment to return to.
%
%garbage_collect :- save(dump), '$gc', save(dump2).
/** @pred garbage_collect
The goal `garbage_collect` forces a garbage collection.
*/
garbage_collect :-
'$gc'.
/** @pred gc
The goal `gc` enables garbage collection. The same as
`yap_flag(gc,on)`.
*/
gc :-
yap_flag(gc,on).
/** @pred nogc
The goal `nogc` disables garbage collection. The same as
`yap_flag(gc,off)`.
*/
nogc :-
yap_flag(gc,off).
/** @pred garbage_collect_atoms
The goal `garbage_collect` forces a garbage collection of the atoms
in the data-base. Currently, only atoms are recovered.
*/
garbage_collect_atoms :-
'$atom_gc'.
'$force_environment_for_gc'.
'$good_list_of_character_codes'(V) :- var(V), !.
'$good_list_of_character_codes'([]).
'$good_list_of_character_codes'([X|L]) :-
'$good_character_code'(X),
'$good_list_of_character_codes'(L).
'$good_character_code'(X) :- var(X), !.
'$good_character_code'(X) :- integer(X), X > -2, X < 256.
/** @pred prolog_initialization( _G_)
Add a goal to be executed on system initialization. This is compatible
with SICStus Prolog's initialization/1.
*/
prolog_initialization(G) :- var(G), !,
'$do_error'(instantiation_error,initialization(G)).
prolog_initialization(T) :- callable(T), !,
'$assert_init'(T).
prolog_initialization(T) :-
'$do_error'(type_error(callable,T),initialization(T)).
'$assert_init'(T) :- recordz('$startup_goal',T,_), fail.
'$assert_init'(_).
/** @pred version
Write YAP's boot message.
*/
version :- '$version'.
/** @pred version(- _Message_)
Add a message to be written when yap boots or after aborting. It is not
possible to remove messages.
*/
version(V) :- var(V), !,
'$do_error'(instantiation_error,version(V)).
version(T) :- atom(T), !, '$assert_version'(T).
version(T) :-
'$do_error'(type_error(atom,T),version(T)).
'$assert_version'(T) :- recordz('$version',T,_), fail.
'$assert_version'(_).
'$set_toplevel_hook'(_) :-
recorded('$toplevel_hooks',_,R),
erase(R),
fail.
'$set_toplevel_hook'(H) :-
recorda('$toplevel_hooks',H,_),
fail.
'$set_toplevel_hook'(_).
%% @}
%% @{
%% @addtogroup Global_Variables
/** @pred nb_getval(+ _Name_, - _Value_)
The nb_getval/2 predicate is a synonym for b_getval/2,
introduced for compatibility and symmetry. As most scenarios will use
a particular global variable either using non-backtrackable or
backtrackable assignment, using nb_getval/2 can be used to
document that the variable is used non-backtrackable.
*/
/** @pred nb_getval(+ _Name_,- _Value_)
The nb_getval/2 predicate is a synonym for b_getval/2, introduced for
compatibility and symmetry. As most scenarios will use a particular
global variable either using non-backtrackable or backtrackable
assignment, using nb_getval/2 can be used to document that the
variable is used non-backtrackable.
*/
nb_getval(GlobalVariable, Val) :-
'$nb_getval'(GlobalVariable, Val, Error),
(var(Error)
->
true
;
'$getval_exception'(GlobalVariable, Val, nb_getval(GlobalVariable, Val)) ->
nb_getval(GlobalVariable, Val)
;
'$do_error'(existence_error(variable, GlobalVariable),nb_getval(GlobalVariable, Val))
).
/** @pred b_getval(+ _Name_, - _Value_)
Get the value associated with the global variable _Name_ and unify
it with _Value_. Note that this unification may further
instantiate the value of the global variable. If this is undesirable
the normal precautions (double negation or copy_term/2) must be
taken. The b_getval/2 predicate generates errors if _Name_ is not
an atom or the requested variable does not exist.
Notice that for compatibility with other systems _Name_ <em>must</em> be already associated with a term: otherwise the system will generate an error.
*/
/** @pred b_getval(+ _Name_,- _Value_)
Get the value associated with the global variable _Name_ and unify
it with _Value_. Note that this unification may further instantiate
the value of the global variable. If this is undesirable the normal
precautions (double negation or copy_term/2) must be taken. The
b_getval/2 predicate generates errors if _Name_ is not an atom or
the requested variable does not exist.
*/
b_getval(GlobalVariable, Val) :-
'$nb_getval'(GlobalVariable, Val, Error),
(var(Error)
->
true
;
'$getval_exception'(GlobalVariable, Val, b_getval(GlobalVariable, Val)) ->
true
;
'$do_error'(existence_error(variable, GlobalVariable),b_getval(GlobalVariable, Val))
).
%% @}
%% @{
%% @addtogroup YAPControl
/* This is the break predicate,
it saves the importante data about current streams and
debugger state */
'$debug_state'(state(Trace, Debug, Jump, Run, SPY_GN, GList)) :-
'$init_debugger',
nb_getval('$trace',Trace),
nb_getval('$debug_jump',Jump),
nb_getval('$debug_run',Run),
current_prolog_flag(debug, Debug),
nb_getval('$spy_gn',SPY_GN),
b_getval('$spy_glist',GList).
'$debug_stop'( State ) :-
'$debug_state'( State ),
b_setval('$trace',off),
% set_prolog_flag(debug, false),
b_setval('$spy_glist',[]),
'$disable_debugging'.
'$debug_restart'(state(Trace, Debug, Jump, Run, SPY_GN, GList)) :-
b_setval('$spy_glist',GList),
b_setval('$spy_gn',SPY_GN),
set_prolog_flag(debug, Debug),
b_setval('$debug_jump',Jump),
b_setval('$debug_run',Run),
b_setval('$trace',Trace),
'$enable_debugging'.
/** @pred break
Suspends the execution of the current goal and creates a new execution
level similar to the top level, displaying the following message:
~~~~~{.prolog}
[ Break (level <number>) ]
~~~~~
telling the depth of the break level just entered. To return to the
previous level just type the end-of-file character or call the
end_of_file predicate. This predicate is especially useful during
debugging.
*/
break :-
'$init_debugger',
nb_getval('$trace',Trace),
nb_setval('$trace',off),
nb_getval('$debug_jump',Jump),
nb_getval('$debug_run',Run),
current_prolog_flag(debug, Debug),
set_prolog_flag(debug, false),
'$break'( true ),
nb_getval('$spy_gn',SPY_GN),
b_getval('$spy_glist',GList),
b_setval('$spy_glist',[]),
current_output(OutStream), current_input(InpStream),
current_prolog_flag(break_level, BL ),
NBL is BL+1,
set_prolog_flag(break_level, NBL ),
format(user_error, '% Break (level ~w)~n', [NBL]),
'$do_live',
!,
set_value('$live','$true'),
b_setval('$spy_glist',GList),
nb_setval('$spy_gn',SPY_GN),
set_input(InpStream),
set_output(OutStream),
set_prolog_flag(debug, Debug),
nb_setval('$debug_jump',Jump),
nb_setval('$debug_run',Run),
nb_setval('$trace',Trace),
set_prolog_flag(break_level, BL ),
'$break'( false ).
at_halt(G) :-
recorda('$halt', G, _),
fail.
at_halt(_).
/** @pred halt is iso
Halts Prolog, and exits to the calling application. In YAP,
halt/0 returns the exit code `0`.
*/
halt :-
print_message(informational, halt),
fail.
halt :-
halt(0).
/** @pred halt(+ _I_) is iso
Halts Prolog, and exits to 1the calling application returning the code
given by the integer _I_.
*/
halt(_) :-
recorded('$halt', G, _),
catch(once(G), Error, user:'$Error'(Error)),
fail.
halt(X) :-
'$sync_mmapped_arrays',
set_value('$live','$false'),
'$halt'(X).
prolog_current_frame(Env) :-
Env is '$env'.
'$run_atom_goal'(GA) :-
'$current_module'(Module),
atom_to_term(GA, G, _),
catch(once(Module:G), Error,user:'$Error'(Error)).
'$add_dot_to_atom_goal'([],[0'.]) :- !. %'
'$add_dot_to_atom_goal'([0'.],[0'.]) :- !.
'$add_dot_to_atom_goal'([C|Gs0],[C|Gs]) :-
'$add_dot_to_atom_goal'(Gs0,Gs).
/**
@}
*/

View File

@@ -1,581 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: corout.pl *
* Last rev: *
* mods: *
* comments: Coroutines implementation *
* *
*************************************************************************/
/**
* @file corout.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Mon Nov 16 22:47:27 2015
* *
*/
:- module('$coroutining',[
op(1150, fx, block)
%dif/2,
%when/2,
%block/1,
%wait/1,
%frozen/2
]).
:- use_system_module( '$_boot', ['$$compile'/4]).
:- use_system_module( attributes, [get_module_atts/2,
put_module_atts/2]).
/**
* @defgroup corout Implementing Attributed Variables and Co-Routining
*
* @ingroup attributes
* @{
* @brief Support for co-routining
*
*
”” */
/** @pred attr_unify_hook(+ _AttValue_,+ _VarValue_)
Hook that must be defined in the module an attributed variable refers
to. Is is called <em>after</em> the attributed variable has been
unified with a non-var term, possibly another attributed variable.
_AttValue_ is the attribute that was associated to the variable
in this module and _VarValue_ is the new value of the variable.
Normally this predicate fails to veto binding the variable to
_VarValue_, forcing backtracking to undo the binding. If
_VarValue_ is another attributed variable the hook often combines
the two attribute and associates the combined attribute with
_VarValue_ using put_attr/3.
*/
attr_unify_hook(DelayList, _) :-
wake_delays(DelayList).
wake_delays([]).
wake_delays([Delay|List]) :-
wake_delay(Delay),
wake_delays(List).
%
% Interface to attributed variables.
%
wake_delay(redo_dif(Done, X, Y)) :-
redo_dif(Done, X, Y).
wake_delay(redo_freeze(Done, V, Goal)) :-
redo_freeze(Done, V, Goal).
wake_delay(redo_eq(Done, X, Y, Goal)) :-
redo_eq(Done, X, Y, Goal, _G).
wake_delay(redo_ground(Done, X, Goal)) :-
redo_ground(Done, X, Goal).
attribute_goals(Var) -->
{ get_attr(Var, '$coroutining', Delays) },
attgoal_for_delays(Delays, Var).
attgoal_for_delays([], _V) --> [].
attgoal_for_delays([G|AllAtts], V) -->
attgoal_for_delay(G, V),
attgoal_for_delays(AllAtts, V).
attgoal_for_delay(redo_dif(Done, X, Y), V) -->
{ var(Done), first_att(dif(X,Y), V) }, !,
[prolog:dif(X,Y)].
attgoal_for_delay(redo_freeze(Done, V, Goal), V) -->
{ var(Done) }, !,
{ remove_when_declarations(Goal, NoWGoal) },
[ prolog:freeze(V,NoWGoal) ].
attgoal_for_delay(redo_eq(Done, X, Y, Goal), V) -->
{ var(Done), first_att(Goal, V) }, !,
[ prolog:when(X=Y,Goal) ].
attgoal_for_delay(redo_ground(Done, X, Goal), _V) -->
{ var(Done) }, !,
[ prolog:when(ground(X),Goal) ].
attgoal_for_delay(_, _V) --> [].
remove_when_declarations(when(Cond,Goal,_), when(Cond,NoWGoal)) :- !,
remove_when_declarations(Goal, NoWGoal).
remove_when_declarations(Goal, Goal).
%
% operators defined in this module:
%
/**
@pred freeze(? _X_,: _G_)
Delay execution of goal _G_ until the variable _X_ is bound.
*/
prolog:freeze(V, G) :-
var(V), !,
freeze_goal(V,G).
prolog:freeze(_, G) :-
'$execute'(G).
freeze_goal(V,VG) :-
var(VG), !,
'$current_module'(M),
internal_freeze(V, redo_freeze(_Done,V,M:VG)).
freeze_goal(V,M:G) :- !,
internal_freeze(V, redo_freeze(_Done,V,M:G)).
freeze_goal(V,G) :-
'$current_module'(M),
internal_freeze(V, redo_freeze(_Done,V,M:G)).
%
%
% Dif is tricky because we need to wake up on the two variables being
% bound together, or on any variable of the term being bound to
% another. Also, the day YAP fully supports infinite rational trees,
% dif should work for them too. Hence, term comparison should not be
% implemented in Prolog.
%
% This is the way dif works. The '$can_unify' predicate does not know
% anything about dif semantics, it just compares two terms for
% equaility and is based on compare. If it succeeds without generating
% a list of variables, the terms are equal and dif fails. If it fails,
% dif succeeds.
%
% If it succeeds but it creates a list of variables, dif creates
% suspension records for all these variables on the '$redo_dif'(V,
% X, Y) goal. V is a flag that says whether dif has completed or not,
% X and Y are the original goals. Whenever one of these variables is
% bound, it calls '$redo_dif' again. '$redo_dif' will then check whether V
% was bound. If it was, dif has succeeded and redo_dif just
% exits. Otherwise, '$redo_dif' will call dif again to see what happened.
%
% Dif needs two extensions from the suspension engine:
%
% First, it needs
% for the engine to be careful when binding two suspended
% variables. Basically, in this case the engine must be sure to wake
% up one of the goals, as they may make dif fail. The way the engine
% does so is by searching the list of suspended variables, and search
% whether they share a common suspended goal. If they do, that
% suspended goal is added to the WokenList.
%
% Second, thanks to dif we may try to suspend on the same variable
% several times. dif calls a special version of freeze that checks
% whether that is in fact the case.
%
/** @pred dif( _X_, _Y_)
Succeed if the two arguments do not unify. A call to dif/2 will
suspend if unification may still succeed or fail, and will fail if they
always unify.
*/
prolog:dif(X, Y) :-
'$can_unify'(X, Y, LVars), !,
LVars = [_|_],
dif_suspend_on_lvars(LVars, redo_dif(_Done, X, Y)).
prolog:dif(_, _).
dif_suspend_on_lvars([], _).
dif_suspend_on_lvars([H|T], G) :-
internal_freeze(H, G),
dif_suspend_on_lvars(T, G).
%
% This predicate is called whenever a variable dif was suspended on is
% bound. Note that dif may have already executed successfully.
%
% Three possible cases: dif has executed and Done is bound; we redo
% dif and the two terms either unify, hence we fail, or may unify, and
% we try to increase the number of suspensions; last, the two terms
% did not unify, we are done, so we succeed and bind the Done variable.
%
redo_dif(Done, _, _) :- nonvar(Done), !.
redo_dif(Done, X, Y) :-
'$can_unify'(X, Y, LVars), !,
LVars = [_|_],
dif_suspend_on_lvars(LVars, redo_dif(Done, X, Y)).
redo_dif('$done', _, _).
redo_freeze(Done, V, G0) :-
% If you called nonvar as condition for when, then you may find yourself
% here.
%
% someone else (that is Cond had ;) did the work, do nothing
%
(nonvar(Done) -> true ;
%
% We still have some more conditions: continue the analysis.
%
G0 = when(C, G, Done) -> when(C, G, Done) ;
%
% check if the variable was really bound
%
var(V) -> internal_freeze(V, redo_freeze(Done,V,G0)) ;
%
% I can't believe it: we're done and can actually execute our
% goal. Notice we have to say we are done, otherwise someone else in
% the disjunction might decide to wake up the goal themselves.
%
Done = '$done', '$execute'(G0) ).
%
% eq is a combination of dif and freeze
redo_eq(Done, _, _, _, _) :- nonvar(Done), !.
redo_eq(_, X, Y, _, G) :-
'$can_unify'(X, Y, LVars),
LVars = [_|_], !,
dif_suspend_on_lvars(LVars, G).
redo_eq(Done, _, _, when(C, G, Done), _) :- !,
when(C, G, Done).
redo_eq('$done', _ ,_ , Goal, _) :-
'$execute'(Goal).
%
% ground is similar to freeze
redo_ground(Done, _, _) :- nonvar(Done), !.
redo_ground(Done, X, Goal) :-
'$non_ground'(X, Var), !,
internal_freeze(Var, redo_ground(Done, X, Goal)).
redo_ground(Done, _, when(C, G, Done)) :- !,
when(C, G, Done).
redo_ground('$done', _, Goal) :-
'$execute'(Goal).
%
% support for when/2 built-in
%
/** @pred when(+ _C_,: _G_)
Delay execution of goal _G_ until the conditions _C_ are
satisfied. The conditions are of the following form:
+ _C1_, _C2_
Delay until both conditions _C1_ and _C2_ are satisfied.
+ _C1_; _C2_
Delay until either condition _C1_ or condition _C2_ is satisfied.
+ ?=( _V1_, _C2_)
Delay until terms _V1_ and _V1_ have been unified.
+ nonvar( _V_)
Delay until variable _V_ is bound.
+ ground( _V_)
Delay until variable _V_ is ground.
Note that when/2 will fail if the conditions fail.
*/
prolog:when(Conds,Goal) :-
'$current_module'(Mod),
prepare_goal_for_when(Goal, Mod, ModG),
when(Conds, ModG, Done, [], LG), !,
%write(vsc:freezing(LG,Done)),nl,
suspend_when_goals(LG, Done).
prolog:when(_,Goal) :-
'$execute'(Goal).
%
% support for when/2 like declaration.
%
%
% when will block on a conjunction or disjunction of nonvar, ground,
% ?=, where ?= is both terms being bound together
%
%
'$declare_when'(Cond, G) :-
generate_code_for_when(Cond, G, Code),
'$current_module'(Module),
'$$compile'(Code, Code, 5, Module), fail.
'$declare_when'(_,_).
%
% use a meta interpreter for now
%
generate_code_for_when(Conds, G,
( G :- when(Conds, ModG, Done, [], LG), !,
suspend_when_goals(LG, Done)) ) :-
'$current_module'(Mod),
prepare_goal_for_when(G, Mod, ModG).
%
% make sure we have module info for G!
%
prepare_goal_for_when(G, Mod, Mod:call(G)) :- var(G), !.
prepare_goal_for_when(M:G, _, M:G) :- !.
prepare_goal_for_when(G, Mod, Mod:G).
%
% now for the important bit
%
% Done is used to synchronise: when it is bound someone else did the
% goal and we can give up.
%
% when/5 and when_suspend succeds when there is need to suspend a goal
%
%
when(V, G, _Done, LG, LG) :- var(V), !,
'$do_error'(instantiation_error,when(V,G)).
when(nonvar(V), G, Done, LG0, LGF) :-
when_suspend(nonvar(V), G, Done, LG0, LGF).
when(?=(X,Y), G, Done, LG0, LGF) :-
when_suspend(?=(X,Y), G, Done, LG0, LGF).
when(ground(T), G, Done, LG0, LGF) :-
when_suspend(ground(T), G, Done, LG0, LGF).
when((C1, C2), G, Done, LG0, LGF) :-
% leave it open to continue with when.
(
when(C1, when(C2, G, Done), Done, LG0, LGI)
->
LGI = LGF
;
% we solved C1, great, now we just have to solve C2!
when(C2, G, Done, LG0, LGF)
).
when((G1 ; G2), G, Done, LG0, LGF) :-
when(G1, G, Done, LG0, LGI),
when(G2, G, Done, LGI, LGF).
%
% Auxiliary predicate called from within a conjunction.
% Repeat basic code for when, as inserted in first clause for predicate.
%
when(_, _, Done) :-
nonvar(Done), !.
when(Cond, G, Done) :-
when(Cond, G, Done, [], LG),
!,
suspend_when_goals(LG, Done).
when(_, G, '$done') :-
'$execute'(G).
%
% Do something depending on the condition!
%
% some one else did the work.
%
when_suspend(_, _, Done, _, []) :- nonvar(Done), !.
%
% now for the serious stuff.
%
when_suspend(nonvar(V), G, Done, LG0, LGF) :-
try_freeze(V, G, Done, LG0, LGF).
when_suspend(?=(X,Y), G, Done, LG0, LGF) :-
try_eq(X, Y, G, Done, LG0, LGF).
when_suspend(ground(X), G, Done, LG0, LGF) :-
try_ground(X, G, Done, LG0, LGF).
try_freeze(V, G, Done, LG0, LGF) :-
var(V),
LGF = ['$coroutining':internal_freeze(V, redo_freeze(Done, V, G))|LG0].
try_eq(X, Y, G, Done, LG0, LGF) :-
'$can_unify'(X, Y, LVars), LVars = [_|_],
LGF = ['$coroutining':dif_suspend_on_lvars(LVars, redo_eq(Done, X, Y, G))|LG0].
try_ground(X, G, Done, LG0, LGF) :-
'$non_ground'(X, Var), % the C predicate that succeds if
% finding out the term is nonground
% and gives the first variable it
% finds. Notice that this predicate
% must know about svars.
LGF = ['$coroutining':internal_freeze(Var, redo_ground(Done, X, G))| LG0].
%
% When executing a when, if nobody succeeded, we need to create suspensions.
%
suspend_when_goals([], _).
suspend_when_goals(['$coroutining':internal_freeze(V, G)|Ls], Done) :-
var(Done), !,
internal_freeze(V, G),
suspend_when_goals(Ls, Done).
suspend_when_goals([dif_suspend_on_lvars(LVars, G)|LG], Done) :-
var(Done), !,
dif_suspend_on_lvars(LVars, G),
suspend_when_goals(LG, Done).
suspend_when_goals([_|_], _).
%
% Support for wait declarations on goals.
% Or we also use the more powerful, SICStus like, "block" declarations.
%
% block or wait declarations must precede the first clause.
%
%
% I am using the simplest solution now: I'll add an extra clause at
% the beginning of the procedure to do this work. This creates a
% choicepoint and make things a bit slower, but it's probably not as
% significant as the remaining overheads.
%
prolog:'$block'(Conds) :-
generate_blocking_code(Conds, _, Code),
'$current_module'(Module),
'$$compile'(Code, Code, 5, Module), fail.
prolog:'$block'(_).
generate_blocking_code(Conds, G, Code) :-
extract_head_for_block(Conds, G),
recorded('$blocking_code','$code'(G,OldConds),R), !,
erase(R),
functor(G, Na, Ar),
'$current_module'(M),
abolish(M:Na, Ar),
generate_blocking_code((Conds,OldConds), G, Code).
generate_blocking_code(Conds, G, (G :- (If, !, when(When, G)))) :-
extract_head_for_block(Conds, G),
recorda('$blocking_code','$code'(G,Conds),_),
generate_body_for_block(Conds, G, If, When).
%
% find out what we are blocking on.
%
extract_head_for_block((C1, _), G) :- !,
extract_head_for_block(C1, G).
extract_head_for_block(C, G) :-
functor(C, Na, Ar),
functor(G, Na, Ar).
%
% If we suspend on the conditions, we should continue
% execution. If we don't suspend we should fail so that we can take
% the next clause. To
% know what we have to do we just test how many variables we suspended
% on ;-).
%
%
% We generate code as follows:
%
% block a(-,-,?)
%
% (var(A1), var(A2) -> true ; fail), !, when((nonvar(A1);nonvar(A2)),G).
%
% block a(-,-,?), a(?,-, -)
%
% (var(A1), var(A2) -> true ; (var(A2), var(A3) -> true ; fail)), !,
% when(((nonvar(A1);nonvar(A2)),(nonvar(A2);nonvar(A3))),G).
generate_body_for_block((C1, C2), G, (Code1 -> true ; Code2), (WhenConds,OtherWhenConds)) :- !,
generate_for_cond_in_block(C1, G, Code1, WhenConds),
generate_body_for_block(C2, G, Code2, OtherWhenConds).
generate_body_for_block(C, G, (Code -> true ; fail), WhenConds) :-
generate_for_cond_in_block(C, G, Code, WhenConds).
generate_for_cond_in_block(C, G, Code, Whens) :-
C =.. [_|Args],
G =.. [_|GArgs],
fetch_out_variables_for_block(Args,GArgs,L0Vars),
add_blocking_vars(L0Vars, LVars),
generate_for_each_arg_in_block(LVars, Code, Whens).
add_blocking_vars([], [_]) :- !.
add_blocking_vars(LV, LV).
fetch_out_variables_for_block([], [], []).
fetch_out_variables_for_block(['?'|Args], [_|GArgs], LV) :-
fetch_out_variables_for_block(Args, GArgs, LV).
fetch_out_variables_for_block(['-'|Args], [GArg|GArgs],
[GArg|LV]) :-
fetch_out_variables_for_block(Args, GArgs, LV).
generate_for_each_arg_in_block([], false, true).
generate_for_each_arg_in_block([V], var(V), nonvar(V)) :- !.
generate_for_each_arg_in_block([V|L], (var(V),If), (nonvar(V);Whens)) :-
generate_for_each_arg_in_block(L, If, Whens).
%
% The wait declaration is a simpler and more efficient version of block.
%
prolog:'$wait'(Na/Ar) :-
functor(S, Na, Ar),
arg(1, S, A),
'$current_module'(M),
'$$compile'((S :- var(A), !, freeze(A, S)), (S :- var(A), !, freeze(A, S)), 5, M), fail.
prolog:'$wait'(_).
/** @pred frozen( _X_, _G_)
Unify _G_ with a conjunction of goals suspended on variable _X_,
or `true` if no goal has suspended.
*/
prolog:frozen(V, LG) :-
var(V), !,
'$attributes':attvars_residuals([V], Gs, []),
simplify_frozen( Gs, SGs ),
list_to_conj( SGs, LG ).
prolog:frozen(V, G) :-
'$do_error'(uninstantiation_error(V),frozen(V,G)).
simplify_frozen( [prolog:freeze(_, G)|Gs], [G|NGs] ) :-
simplify_frozen( Gs,NGs ).
simplify_frozen( [prolog:when(_, G)|Gs], [G|NGs] ) :-
simplify_frozen( Gs,NGs ).
simplify_frozen( [prolog:dif(_, _)|Gs], NGs ) :-
simplify_frozen( Gs,NGs ).
simplify_frozen( [], [] ).
list_to_conj([], true).
list_to_conj([El], El).
list_to_conj([E,E1|Els], (E,C) ) :-
list_to_conj([E1|Els], C).
%internal_freeze(V,G) :-
% attributes:get_att(V, 0, Gs), write(G+Gs),nl,fail.
internal_freeze(V,G) :-
update_att(V, G).
update_att(V, G) :-
attributes:get_module_atts(V, '$coroutining'(_,Gs)),
not_vmember(G, Gs), !,
attributes:put_module_atts(V, '$coroutining'(_,[G|Gs])).
update_att(V, G) :-
attributes:put_module_atts(V, '$coroutining'(_,[G])).
not_vmember(_, []).
not_vmember(V, [V1|DonesSoFar]) :-
V \== V1,
not_vmember(V, DonesSoFar).
first_att(T, V) :-
term_variables(T, Vs),
check_first_attvar(Vs, V).
check_first_attvar([V|_Vs], V0) :- attvar(V), !, V == V0.
check_first_attvar([_|Vs], V0) :-
check_first_attvar(Vs, V0).
/**
@}
*/

View File

@@ -1,189 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: dbload.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: Compact Loading of Facts in YAP *
* *
*************************************************************************/
:- module('$db_load',
[]).
:- use_system_module( '$_boot', ['$$compile'/4]).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( attributes, [get_module_atts/2,
put_module_atts/2]).
%%% @file dbload.yap
%%% @defgroup YAPBigLoad
%%% @brief Fast and Exo Loading
/*!
* @pred load_mega_clause( +Stream ) is detail
* Load a single predicare composed of facts with the same size.
*/
load_mega_clause( Stream ) :-
% line_spec( Stream, Line),
repeat,
( fact( Stream ), fail ;
stream_property(Stream, at_end_of_file( on )) ).
'$input_lines'(R, csv, Lines ) :-
'$process_lines'(R, Lines, _Type ),
close(R).
/*!
* @pred load_db( +Files ) is det
* Load files each one containing as single predicare composed of facts with the same size.
*/
prolog:load_db(Fs) :-
'$current_module'(M0),
prolog_flag(agc_margin,Old,0),
dbload(Fs,M0,load_db(Fs)),
load_facts,
prolog_flag(agc_margin,_,Old),
clean_up.
dbload(Fs, _, G) :-
var(Fs),
'$do_error'(instantiation_error,G).
dbload([], _, _) :- !.
dbload([F|Fs], M0, G) :- !,
dbload(F, M0, G),
dbload(Fs, M0, G).
dbload(M:F, _M0, G) :- !,
dbload(F, M, G).
dbload(F, M0, G) :-
atom(F), !,
do_dbload(F, M0, G).
dbload(F, _, G) :-
'$do_error'(type_error(atom,F),G).
do_dbload(F0, M0, G) :-
'$full_filename'(F0, F, G),
assert(dbprocess(F, M0)),
open(F, read, R),
check_dbload_stream(R, M0),
close(R).
check_dbload_stream(R, M0) :-
repeat,
catch(read(R,T), _, fail),
( T = end_of_file -> !;
dbload_count(T, M0),
fail
).
dbload_count(T0, M0) :-
get_module(T0,M0,T,M),
functor(T,Na,Arity),
% dbload_check_term(T),
(
dbloading(Na,Arity,M,_,NaAr,_) ->
nb_getval(NaAr,I0),
I is I0+1,
nb_setval(NaAr,I)
;
atomic_concat([Na,'__',Arity,'__',M],NaAr),
assert(dbloading(Na,Arity,M,T,NaAr,0)),
nb_setval(NaAr,1)
).
get_module(M1:T0,_,T,M) :- !,
get_module(T0, M1, T , M).
get_module(T,M,T,M).
load_facts :-
!, % yap_flag(exo_compilation, on), !.
load_exofacts.
load_facts :-
retract(dbloading(Na,Arity,M,T,NaAr,_)),
nb_getval(NaAr,Size),
dbload_get_space(T, M, Size, Handle),
assertz(dbloading(Na,Arity,M,T,NaAr,Handle)),
nb_setval(NaAr,0),
fail.
load_facts :-
dbprocess(F, M),
open(F, read, R),
dbload_add_facts(R, M),
close(R),
fail.
load_facts.
dbload_add_facts(R, M) :-
repeat,
catch(read(R,T), _, fail),
( T = end_of_file -> !;
dbload_add_fact(T, M),
fail
).
dbload_add_fact(T0, M0) :-
get_module(T0,M0,T,M),
functor(T,Na,Arity),
dbloading(Na,Arity,M,_,NaAr,Handle),
nb_getval(NaAr,I0),
I is I0+1,
nb_setval(NaAr,I),
dbassert(T,Handle,I0).
load_exofacts :-
retract(dbloading(Na,Arity,M,T,NaAr,_)),
nb_getval(NaAr,Size),
exo_db_get_space(T, M, Size, Handle),
assertz(dbloading(Na,Arity,M,T,NaAr,Handle)),
nb_setval(NaAr,0),
fail.
load_exofacts :-
dbprocess(F, M),
open(F, read, R),
exodb_add_facts(R, M),
close(R),
fail.
load_exofacts.
exodb_add_facts(R, M) :-
repeat,
catch(protected_exodb_add_fact(R, M), _, fail),
!.
protected_exodb_add_fact(R, M) :-
repeat,
read(R,T),
( T == end_of_file -> !;
exodb_add_fact(T, M),
fail
).
exodb_add_fact(T0, M0) :-
get_module(T0,M0,T,M),
functor(T,Na,Arity),
dbloading(Na,Arity,M,_,NaAr,Handle),
nb_getval(NaAr,I0),
I is I0+1,
nb_setval(NaAr,I),
exoassert(T,Handle,I0).
clean_up :-
retractall(dbloading(_,_,_,_,_,_)),
retractall(dbprocess(_,_)),
fail.
clean_up.
%% @}

File diff suppressed because it is too large Load Diff

View File

@@ -1,35 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: corout.pl *
* Last rev: *
* mods: *
* comments: Coroutines implementation *
* *
*************************************************************************/
/**
@defgroup DepthLimited Depth Limited Search
@ingroup extensions
YAP implements various extensions to the default Prolog search. One of
the most iseful s restricting the maximum search depth.
*/
:-
system_module( '$_depth_bound', [depth_bound_call/2], []).
%depth_bound_call(A,D) :-
%write(depth_bound_call(A,D)), nl, fail.
depth_bound_call(A,D) :-
'$execute_under_depth_limit'(A,D).

View File

@@ -1,93 +0,0 @@
:- module(dialect,
[
exists_source/1,
source_exports/2
]).
:- use_system_module( '$_errors', ['$do_error'/2]).
% @pred expects_dialect(+Dialect)
%
% True if YAP can enable support for a different Prolog dialect.
% Currently there is support for bprolog, hprolog and swi-prolog.
% Notice that this support may be incomplete.
%
% The
prolog:expects_dialect(yap) :- !,
eraseall('$dialect'),
recorda('$dialect',yap,_).
prolog:expects_dialect(Dialect) :-
check_dialect(Dialect),
eraseall('$dialect'),
load_files(library(dialect/Dialect),[silent(true),if(not_loaded)]),
( current_predicate(Dialect:setup_dialect/0)
-> Dialect:setup_dialect
; true
),
recorda('$dialect',Dialect,_).
check_dialect(Dialect) :-
var(Dialect),!,
'$do_error'(instantiation_error,(:- expects_dialect(Dialect))).
check_dialect(Dialect) :-
\+ atom(Dialect),!,
'$do_error'(type_error(Dialect),(:- expects_dialect(Dialect))).
check_dialect(Dialect) :-
exists_source(library(dialect/Dialect)), !.
check_dialect(Dialect) :-
'$do_error'(domain_error(dialect,Dialect),(:- expects_dialect(Dialect))).
%% exists_source(+Source) is semidet.
%
% True if Source (a term valid for load_files/2) exists. Fails
% without error if this is not the case. The predicate is intended
% to be used with :- if, as in the example below. See also
% source_exports/2.
%
% ==
% :- if(exists_source(library(error))).
% :- use_module_library(error).
% :- endif.
% ==
%exists_source(Source) :-
% exists_source(Source, _Path).
exists_source(Source, Path) :-
absolute_file_name(Source, Path,
[ file_type(prolog),
access(read),
file_errors(fail)
]).
%% source_exports(+Source, +Export) is semidet.
%% source_exports(+Source, -Export) is nondet.
%
% True if Source exports Export. Fails without error if this is
% not the case. See also exists_source/1.
%
% @tbd Should we also allow for source_exports(-Source, +Export)?
source_exports(Source, Export) :-
open_source(Source, In),
catch(call_cleanup(exports(In, Exports), close(In)), _, fail),
( ground(Export)
-> lists:memberchk(Export, Exports)
; lists:member(Export, Exports)
).
%% open_source(+Source, -In:stream) is semidet.
%
% Open a source location.
open_source(File, In) :-
exists_source(File, Path),
open(Path, read, In),
( peek_char(In, #)
-> skip(In, 10)
; true
).
exports(In, Exports) :-
read(In, Term),
Term = (:- module(_Name, Exports)).

View File

@@ -1,263 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: directives.yap *
* Last rev: *
* mods: *
* comments: directing system execution *
* *
*************************************************************************/
:- system_module( '$_directives', [user_defined_directive/2], ['$all_directives'/1,
'$exec_directives'/5]).
:- use_system_module( '$_boot', ['$command'/4,
'$system_catch'/4]).
:- use_system_module( '$_consult', ['$elif'/2,
'$else'/1,
'$endif'/1,
'$if'/2,
'$include'/2,
'$initialization'/1,
'$initialization'/2,
'$load_files'/3,
'$require'/2,
'$set_encoding'/1,
'$use_module'/3]).
:- use_system_module( '$_modules', ['$meta_predicate'/2,
'$module'/3,
'$module'/4,
'$module_transparent'/2]).
:- use_system_module( '$_preddecls', ['$discontiguous'/2,
'$dynamic'/2]).
:- use_system_module( '$_preds', ['$noprofile'/2,
'$public'/2]).
:- use_system_module( '$_threads', ['$thread_local'/2]).
'$all_directives'(_:G1) :- !,
'$all_directives'(G1).
'$all_directives'((G1,G2)) :- !,
'$all_directives'(G1),
'$all_directives'(G2).
'$all_directives'(G) :- !,
'$directive'(G).
%:- '$multifile'( '$directive'/1, prolog ).
:- multifile prolog:'$exec_directive'/5, prolog:'$directive'/1.
'$directive'(block(_)).
'$directive'(char_conversion(_,_)).
'$directive'(compile(_)).
'$directive'(consult(_)).
'$directive'(discontiguous(_)).
'$directive'(dynamic(_)).
'$directive'(elif(_)).
'$directive'(else).
'$directive'(encoding(_)).
'$directive'(endif).
'$directive'(ensure_loaded(_)).
'$directive'(expects_dialect(_)).
'$directive'(if(_)).
'$directive'(include(_)).
'$directive'(initialization(_)).
'$directive'(initialization(_,_)).
'$directive'(license(_)).
'$directive'(meta_predicate(_)).
'$directive'(module(_,_)).
'$directive'(module(_,_,_)).
'$directive'(module_transparent(_)).
'$directive'(multifile(_)).
'$directive'(noprofile(_)).
'$directive'(public(_)).
'$directive'(op(_,_,_)).
'$directive'(require(_)).
'$directive'(set_prolog_flag(_,_)).
'$directive'(reconsult(_)).
'$directive'(reexport(_)).
'$directive'(reexport(_,_)).
'$directive'(predicate_options(_,_,_)).
'$directive'(thread_initialization(_)).
'$directive'(thread_local(_)).
'$directive'(uncutable(_)).
'$directive'(use_module(_)).
'$directive'(use_module(_,_)).
'$directive'(use_module(_,_,_)).
'$directive'(wait(_)).
'$exec_directives'((G1,G2), Mode, M, VL, Pos) :-
!,
'$exec_directives'(G1, Mode, M, VL, Pos),
'$exec_directives'(G2, Mode, M, VL, Pos).
'$exec_directives'(G, Mode, M, VL, Pos) :-
'$exec_directive'(G, Mode, M, VL, Pos).
'$exec_directive'(multifile(D), _, M, _, _) :-
'$system_catch'('$multifile'(D, M), M,
Error,
user:'$LoopError'(Error, top)).
'$exec_directive'(discontiguous(D), _, M, _, _) :-
'$discontiguous'(D,M).
/** @pred initialization
Execute the goals defined by initialization/1. Only the first answer is
considered.
*/
'$exec_directive'(initialization(D), _, M, _, _) :-
'$initialization'(M:D).
'$exec_directive'(initialization(D,OPT), _, M, _, _) :-
'$initialization'(M:D, OPT).
'$exec_directive'(thread_initialization(D), _, M, _, _) :-
'$thread_initialization'(M:D).
'$exec_directive'(expects_dialect(D), _, _, _, _) :-
expects_dialect(D).
'$exec_directive'(encoding(Enc), _, _, _, _) :-
'$set_encoding'(Enc).
'$exec_directive'(include(F), Status, _, _, _) :-
'$include'(F, Status).
% don't declare modules into Prolog Module
'$exec_directive'(module(N,P), Status, _, _, _) :-
'$module'(Status,N,P).
'$exec_directive'(module(N,P,Op), Status, _, _, _) :-
'$module'(Status,N,P,Op).
'$exec_directive'(meta_predicate(P), _, M, _, _) :-
strip_module(M:P,M0,P0),
'$meta_predicate'(M0:P0).
'$exec_directive'(module_transparent(P), _, M, _, _) :-
'$module_transparent'(P, M).
'$exec_directive'(noprofile(P), _, M, _, _) :-
'$noprofile'(P, M).
'$exec_directive'(require(Ps), _, M, _, _) :-
'$require'(Ps, M).
'$exec_directive'(dynamic(P), _, M, _, _) :-
'$dynamic'(P, M).
'$exec_directive'(thread_local(P), _, M, _, _) :-
'$thread_local'(P, M).
'$exec_directive'(op(P,OPSEC,OP), _, _, _, _) :-
'$current_module'(M),
op(P,OPSEC,M:OP).
'$exec_directive'(set_prolog_flag(F,V), _, _, _, _) :-
set_prolog_flag(F,V).
'$exec_directive'(ensure_loaded(Fs), _, M, _, _) :-
'$load_files'(M:Fs, [if(changed)], ensure_loaded(Fs)).
'$exec_directive'(char_conversion(IN,OUT), _, _, _, _) :-
char_conversion(IN,OUT).
'$exec_directive'(public(P), _, M, _, _) :-
'$public'(P, M).
'$exec_directive'(compile(Fs), _, M, _, _) :-
'$load_files'(M:Fs, [], compile(Fs)).
'$exec_directive'(reconsult(Fs), _, M, _, _) :-
'$load_files'(M:Fs, [], reconsult(Fs)).
'$exec_directive'(consult(Fs), _, M, _, _) :-
'$load_files'(M:Fs, [consult(consult)], consult(Fs)).
'$exec_directive'(use_module(F), _, M, _, _) :-
use_module(M:F).
'$exec_directive'(reexport(F), _, M, _, _) :-
'$load_files'(M:F, [if(not_loaded), silent(true), reexport(true),must_be_module(true)], reexport(F)).
'$exec_directive'(reexport(F,Spec), _, M, _, _) :-
'$load_files'(M:F, [if(changed), silent(true), imports(Spec), reexport(true),must_be_module(true)], reexport(F, Spec)).
'$exec_directive'(use_module(F, Is), _, M, _, _) :-
use_module(M:F, Is).
'$exec_directive'(use_module(Mod,F,Is), _, _, _, _) :-
'$use_module'(Mod,F,Is).
'$exec_directive'(block(BlockSpec), _, _, _, _) :-
'$block'(BlockSpec).
'$exec_directive'(wait(BlockSpec), _, _, _, _) :-
'$wait'(BlockSpec).
'$exec_directive'(table(PredSpec), _, M, _, _) :-
'$table'(PredSpec, M).
'$exec_directive'(uncutable(PredSpec), _, M, _, _) :-
'$uncutable'(PredSpec, M).
'$exec_directive'(if(Goal), Context, M, _, _) :-
'$if'(M:Goal, Context).
'$exec_directive'(else, Context, _, _, _) :-
'$else'(Context).
'$exec_directive'(elif(Goal), Context, M, _, _) :-
'$elif'(M:Goal, Context).
'$exec_directive'(endif, Context, _, _, _) :-
'$endif'(Context).
'$exec_directive'(license(_), Context, _, _, _) :-
Context \= top.
'$exec_directive'(predicate_options(PI, Arg, Options), Context, Module, VL, Pos) :-
Context \= top,
predopts:expand_predicate_options(PI, Arg, Options, Clauses),
'$assert_list'(Clauses, Context, Module, VL, Pos).
'$assert_list'([], _Context, _Module, _VL, _Pos).
'$assert_list'([Clause|Clauses], Context, Module, VL, Pos) :-
'$command'(Clause, VL, Pos, Context),
'$assert_list'(Clauses, Context, Module, VL, Pos).
%
% allow users to define their own directives.
%
user_defined_directive(Dir,_) :-
'$directive'(Dir), !.
user_defined_directive(Dir,Action) :-
functor(Dir,Na,Ar),
functor(NDir,Na,Ar),
'$current_module'(M, prolog),
assert_static(prolog:'$directive'(NDir)),
assert_static(prolog:('$exec_directive'(Dir, _, _, _, _) :- Action)),
'$current_module'(_, M).
'$thread_initialization'(M:D) :-
eraseall('$thread_initialization'),
recorda('$thread_initialization',M:D,_),
fail.
'$thread_initialization'(M:D) :-
'$initialization'(M:D).
%
% This command is very different depending on the language mode we are in.
%
% ISO only wants directives in files
% SICStus accepts everything in files
% YAP accepts everything everywhere
%
'$process_directive'(G, top, M, VL, Pos) :-
current_prolog_flag(language_mode, yap), !, /* strict_iso on */
'$process_directive'(G, consult, M, VL, Pos).
'$process_directive'(G, top, M, _, _) :-
!,
'$do_error'(context_error((:-M:G),clause),query).
%
% default case
%
'$process_directive'(Gs, Mode, M, VL, Pos) :-
'$all_directives'(Gs), !,
'$exec_directives'(Gs, Mode, M, VL, Pos).
%
% ISO does not allow goals (use initialization).
%
'$process_directive'(D, _, M, _VL, _Pos) :-
current_prolog_flag(language_mode, iso),
!, % ISO Prolog mode, go in and do it,
'$do_error'(context_error((:- M:D),query),directive).
%
% but YAP and SICStus do.
%
'$process_directive'(G, _Mode, M, _VL, _Pos) :-
'$execute'(M:G),
!.
'$process_directive'(G, _Mode, M, _VL, _Pos) :-
format(user_error,':- ~w:~w failed.~n',[M,G]).

View File

@@ -1,44 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* BEAM extends the YAP Prolog system to support the EAM *
* *
* Copyright Ricardo Lopes and Universidade do Porto 2000-2006 *
* *
**************************************************************************
* *
* File: eam.yap *
* Last rev: 6/4/2006 *
* mods: *
* comments: Some utility predicates needed by BEAM *
* *
*************************************************************************/
:- system_module( '$_eam', [eamconsult/1,
eamtrans/2], []).
eamtrans(A,A):- var(A),!.
eamtrans((A,B),(C,D)):- !, eamtrans(A,C),eamtrans(B,D).
eamtrans((X is Y) ,(skip_while_var(Vars), X is Y )):- !, '$variables_in_term'(Y,[],Vars).
eamtrans((X =\= Y),(skip_while_var(Vars), X =\= Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X =:= Y),(skip_while_var(Vars), X =:= Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X >= Y) ,(skip_while_var(Vars), X >= Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X > Y) ,(skip_while_var(Vars), X > Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X < Y) ,(skip_while_var(Vars), X < Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X =< Y) ,(skip_while_var(Vars), X =< Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X @>= Y) ,(skip_while_var(Vars), X @>= Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X @> Y) ,(skip_while_var(Vars), X @> Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X @< Y) ,(skip_while_var(Vars), X @< Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X @=< Y) ,(skip_while_var(Vars), X @=< Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X \= Y) ,(skip_while_var(Vars), X \= Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans((X \== Y),(skip_while_var(Vars), X \== Y )):- !, '$variables_in_term'(X + Y,[],Vars).
eamtrans(B,B).
eamconsult(File):- eam, eam, %fails if eam is disable
assert((user:term_expansion((A :- B),(A :- C)):- eamtrans(B,C))),
eam, ( consult(File) ; true), eam,
abolish(user:term_expansion,2).

View File

@@ -1,339 +0,0 @@
/**
@file pl/error.yap
@author Jan Wielemaker
@author Richard O'Keefe
@author adapted to YAP by Vitor Santos Costa
*/
:- module(system(error,
[ must_be_of_type/2, % +Type, +Term
must_be_of_type/3, % +Type, +Term, +Comment
must_be/2, % +Type, +Term
must_be/3, % +Type, +Term, +Comment
type_error/2, % +Type, +Term
% must_be_in_domain/2, % +Domain, +Term
% must_be_in_domain/3, % +Domain, +Term, +Comment
domain_error/3, % +Domain, +Values, +Term
existence_error/2, % +Type, +Term
permission_error/3, % +Action, +Type, +Term
must_be_instantiated/1, % +Term
must_bind_to_type/2, % +Type, ?Term
instantiation_error/1, % +Term
representation_error/1, % +Reason
is_of_type/2 % +Type, +Term
]), []) .
/**
@defgroup error Error generating support
@ingroup YAPError
This SWI module provides predicates to simplify error generation and
checking. Adapted to use YAP built-ins.
Its implementation is based on a discussion on the SWI-Prolog
mailinglist on best practices in error handling. The utility predicate
must_be/2 provides simple run-time type validation. The *_error
predicates are simple wrappers around throw/1 to simplify throwing the
most common ISO error terms.
YAP reuses the code with some extensions, and supports interfacing to some C-builtins.
@{
*/
:- multifile
has_type/2.
%% @pred type_error(+Type, +Term).
%% @pred domain_error(+Type, +Value, +Term).
%% @pred existence_error(+Type, +Term).
%% @pred permission_error(+Action, +Type, +Term).
%% @pred instantiation_error(+Term).
%% @pred representation_error(+Reason).
%
% Throw ISO compliant error messages.
type_error(Type, Term) :-
throw(error(type_error(Type, Term), _)).
domain_error(Type, Term) :-
throw(error(domain_error(Type, Term), _)).
existence_error(Type, Term) :-
throw(error(existence_error(Type, Term), _)).
permission_error(Action, Type, Term) :-
throw(error(permission_error(Action, Type, Term), _)).
instantiation_error(_Term) :-
throw(error(instantiation_error, _)).
representation_error(Reason) :-
throw(error(representation_error(Reason), _)).
%% must_be_of_type(+Type, @Term) is det.
%
% True if Term satisfies the type constraints for Type. Defined
% types are =atom=, =atomic=, =between=, =boolean=, =callable=,
% =chars=, =codes=, =text=, =compound=, =constant=, =float=,
% =integer=, =nonneg=, =positive_integer=, =negative_integer=,
% =nonvar=, =number=, =oneof=, =list=, =list_or_partial_list=,
% =symbol=, =var=, =rational= and =string=.
%
% Most of these types are defined by an arity-1 built-in predicate
% of the same name. Below is a brief definition of the other
% types.
%
% | boolean | one of =true= or =false= |
% | chars | Proper list of 1-character atoms |
% | codes | Proper list of Unicode character codes |
% | text | One of =atom=, =string=, =chars= or =codes= |
% | between(L,U) | Number between L and U (including L and U) |
% | nonneg | Integer >= 0 |
% | positive_integer | Integer > 0 |
% | negative_integer | Integer < 0 |
% | oneof(L) | Ground term that is member of L |
% | list(Type) | Proper list with elements of Type |
% | list_or_partial_list | A list or an open list (ending in a variable) |
% | predicate_indicator | a predicate indicator of the form M:N/A or M:N//A |
%
% @throws instantiation_error if Term is insufficiently
% instantiated and type_error(Type, Term) if Term is not of Type.
must_be(Type, X) :-
must_be_of_type(Type, X).
must_be(Type, X, Comment) :-
must_be_of_type(Type, X, Comment).
must_be_of_type(callable, X) :-
!,
is_callable(X, _).
must_be_of_type(atom, X) :-
!,
is_atom(X, _).
must_be_of_type(module, X) :-
!,
is_atom(X, _).
must_be_of_type(predicate_indicator, X) :-
!,
is_predicate_indicator(X, _).
must_be_of_type(Type, X) :-
( has_type(Type, X)
-> true
; is_not(Type, X)
).
inline(must_be_of_type( atom, X ), is_atom(X, _) ).
inline(must_be_of_type( module, X ), is_module(X, _) ).
inline(must_be_of_type( callable, X ), is_callable(X, _) ).
inline(must_be_of_type( callable, X ), is_callable(X, _) ).
inline(must_be_atom( X ), is_callable(X, _) ).
inline(must_be_module( X ), is_atom(X, _) ).
must_be_of_type(predicate_indicator, X, Comment) :-
!,
is_predicate_indicator(X, Comment).
must_be_of_type(callable, X, Comment) :-
!,
is_callable(X, Comment).
must_be_of_type(Type, X, _Comment) :-
( has_type(Type, X)
-> true
; is_not(Type, X)
).
must_bind_to_type(Type, X) :-
( may_bind_to_type(Type, X)
-> true
; is_not(Type, X)
).
%% @predicate is_not(+Type, @Term)
%
% Throws appropriate error. It is _known_ that Term is not of type
% Type.
%
% @throws type_error(Type, Term)
% @throws instantiation_error
is_not(list, X) :- !,
not_a_list(list, X).
is_not(list(_), X) :- !,
not_a_list(list, X).
is_not(list_or_partial_list, X) :- !,
type_error(list, X).
is_not(chars, X) :- !,
not_a_list(chars, X).
is_not(codes, X) :- !,
not_a_list(codes, X).
is_not(var,_X) :- !,
representation_error(variable).
is_not(rational, X) :- !,
not_a_rational(X).
is_not(Type, X) :-
( var(X)
-> instantiation_error(X)
; ground_type(Type), \+ ground(X)
-> instantiation_error(X)
; type_error(Type, X)
).
ground_type(ground).
ground_type(oneof(_)).
ground_type(stream).
ground_type(text).
ground_type(string).
not_a_list(Type, X) :-
'$skip_list'(_, X, Rest),
( var(Rest)
-> instantiation_error(X)
; type_error(Type, X)
).
not_a_rational(X) :-
( var(X)
-> instantiation_error(X)
; X = rdiv(N,D)
-> must_be(integer, N), must_be(integer, D),
type_error(rational,X)
; type_error(rational,X)
).
%% is_of_type(+Type, @Term) is semidet.
%
% True if Term satisfies Type.
is_of_type(Type, Term) :-
has_type(Type, Term).
%% has_type(+Type, @Term) is semidet.
%
% True if Term satisfies Type.
has_type(impossible, _) :- instantiation_error(_).
has_type(any, _).
has_type(atom, X) :- atom(X).
has_type(atomic, X) :- atomic(X).
has_type(between(L,U), X) :- ( integer(L)
-> integer(X), between(L,U,X)
; number(X), X >= L, X =< U
).
has_type(boolean, X) :- (X==true;X==false), !.
has_type(callable, X) :- callable(X).
has_type(chars, X) :- chars(X).
has_type(codes, X) :- codes(X).
has_type(text, X) :- text(X).
has_type(compound, X) :- compound(X).
has_type(constant, X) :- atomic(X).
has_type(float, X) :- float(X).
has_type(ground, X) :- ground(X).
has_type(integer, X) :- integer(X).
has_type(nonneg, X) :- integer(X), X >= 0.
has_type(positive_integer, X) :- integer(X), X > 0.
has_type(negative_integer, X) :- integer(X), X < 0.
has_type(nonvar, X) :- nonvar(X).
has_type(number, X) :- number(X).
has_type(oneof(L), X) :- ground(X), lists:memberchk(X, L).
has_type(proper_list, X) :- is_list(X).
has_type(list, X) :- is_list(X).
has_type(list_or_partial_list, X) :- is_list_or_partial_list(X).
has_type(symbol, X) :- atom(X).
has_type(var, X) :- var(X).
has_type(rational, X) :- rational(X).
has_type(string, X) :- string(X).
has_type(stream, X) :- is_stream(X).
has_type(list(Type), X) :- is_list(X), element_types(X, Type).
%% may_bind_to_type(+Type, @Term) is semidet.
%
% True if _Term_ or term _Term\theta_ satisfies _Type_.
may_bind_to_type(_, X ) :- var(X), !.
may_bind_to_type(impossible, _) :- instantiation_error(_).
may_bind_to_type(any, _).
may_bind_to_type(atom, X) :- atom(X).
may_bind_to_type(atomic, X) :- atomic(X).
may_bind_to_type(between(L,U), X) :- ( integer(L)
-> integer(X), between(L,U,X)
; number(X), X >= L, X =< U
).
may_bind_to_type(boolean, X) :- (X==true;X==false), !.
may_bind_to_type(callable, X) :- callable(X).
may_bind_to_type(chars, X) :- chars(X).
may_bind_to_type(codes, X) :- codes(X).
may_bind_to_type(text, X) :- text(X).
may_bind_to_type(compound, X) :- compound(X).
may_bind_to_type(constant, X) :- atomic(X).
may_bind_to_type(float, X) :- float(X).
may_bind_to_type(ground, X) :- ground(X).
may_bind_to_type(integer, X) :- integer(X).
may_bind_to_type(nonneg, X) :- integer(X), X >= 0.
may_bind_to_type(positive_integer, X) :- integer(X), X > 0.
may_bind_to_type(negative_integer, X) :- integer(X), X < 0.
may_bind_to_type(predicate_indicator, X) :-
(
X = M:PI
->
may_bind_to_type( atom, M),
may_bind_to_type(predicate_indicator, PI)
;
X = N/A
->
may_bind_to_type( atom, N),
may_bind_to_type(integer, A)
;
X = N//A
->
may_bind_to_type( atom, N),
may_bind_to_type(integer, A)
).
may_bind_to_type(nonvar, _X).
may_bind_to_type(number, X) :- number(X).
may_bind_to_type(oneof(L), X) :- ground(X), lists:memberchk(X, L).
may_bind_to_type(proper_list, X) :- is_list(X).
may_bind_to_type(list, X) :- is_list(X).
may_bind_to_type(list_or_partial_list, X) :- is_list_or_partial_list(X).
may_bind_to_type(symbol, X) :- atom(X).
may_bind_to_type(var, X) :- var(X).
may_bind_to_type(rational, X) :- rational(X).
may_bind_to_type(string, X) :- string(X).
may_bind_to_type(stream, X) :- is_stream(X).
may_bind_to_type(list(Type), X) :- is_list(X), element_types(X, Type).
chars(0) :- !, fail.
chars([]).
chars([H|T]) :-
atom(H), atom_length(H, 1),
chars(T).
codes(x) :- !, fail.
codes([]).
codes([H|T]) :-
integer(H), between(1, 0x10ffff, H),
codes(T).
text(X) :-
( atom(X)
; string(X)
; chars(X)
; codes(X)
), !.
element_types([], _).
element_types([H|T], Type) :-
must_be(Type, H),
element_types(T, Type).
is_list_or_partial_list(L0) :-
'$skip_list'(_, L0,L),
( var(L) -> true ; L == [] ).
must_be_instantiated(X) :-
( var(X) -> instantiation_error(X) ; true).
must_be_instantiated(X, Comment) :-
( var(X) -> instantiation_error(X, Comment) ; true).
%% @}

View File

@@ -1,149 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: errors.yap *
* comments: error messages for YAP *
* *
* *
* *
*************************************************************************/
/** @defgroup YAPError Error Handling
@ingroup YAPControl
The error handler is called when there is an execution error or a
warning needs to be displayed. The handlers include a number of hooks
to allow user-control.
Errors are terms of the form:
- error( domain_error( Domain, Culprit )`
- error( evaluation_error( Expression, Culprit )`
- error( existence_error( Object, Culprit )`
- error( instantiation_error )`
- error( permission_error( Error, Permission, Culprit)`
- error( representation_error( Domain, Culprit )`
- error( resource_error( Resource, Culprit )`
- error( syntax_error( Error )`
- error( system_error( Domain, Culprit )`
- error( type_error( Type, Culprit )`
- error( uninstantiation_error( Culprit )`
@{
*/
:- system_module( '$_errors', [system_error/2], ['$Error'/1,
'$do_error'/2,
system_error/3,
system_error/2]).
:- use_system_module( '$messages', [file_location/2,
generate_message/3,
translate_message/4]).
/**
* @pred system_error( +Error, +Cause)
*
* Generate a system error _Error_, informing the possible cause _Cause_.
*
*/
system_error(Type,Goal) :-
'$do_error'(Type,Goal).
'$do_error'(Type,Goal) :-
% format('~w~n', [Type]),
ancestor_location(Call, Caller),
throw(error(Type, [
[g|g(Goal)],
[p|Call],
[e|Caller]])).
/**
* @pred system_error( +Error, +Cause, +Culprit)
*
* Generate a system error _Error_, informing the source goal _Cause_ and a possible _Culprit_.
*
*
* ~~~~~~~~~~
* ~~~~~~~~~~
*
*
*/
system_error(Type,Goal,Culprit) :-
% format('~w~n', [Type]),
ancestor_location(Call, Caller),
throw(error(Type, [
[i|Culprit],
[g|g(Goal)],
[p|Call],
[e|Caller]])).
'$do_pi_error'(type_error(callable,Name/0),Message) :- !,
'$do_error'(type_error(callable,Name),Message).
'$do_pi_error'(Error,Message) :- !,
'$do_error'(Error,Message).
'$Error'(E) :-
'$LoopError'(E,top).
'$LoopError'(_, _) :-
flush_output(user_output),
flush_output(user_error),
fail.
'$LoopError'(Error, Level) :- !,
'$process_error'(Error, Level),
fail.
'$LoopError'(_, _) :-
flush_output,
'$close_error',
fail.
'$process_error'('$forward'(Msg), _) :-
!,
throw( '$forward'(Msg) ).
'$process_error'(abort, Level) :-
!,
(
Level \== top
->
throw( abort )
;
current_prolog_flag(break_level, 0)
->
print_message(informational,abort(user)),
fail
;
current_prolog_flag(break_level, I0),
I is I0-1,
current_prolog_flag(break_level, I),
throw(abort)
).
'$process_error'(error(thread_cancel(_Id), _G),top) :-
!.
'$process_error'(error(thread_cancel(Id), G), _) :-
!,
throw(error(thread_cancel(Id), G)).
'$process_error'(error(permission_error(module,redefined,A),B), Level) :-
Level \= top, !,
throw(error(permission_error(module,redefined,A),B)).
'$process_error'(Error, _Level) :-
functor(Error, Severity, _),
print_message(Severity, Error), !.
%'$process_error'(error(Msg, Where), _) :-
% print_message(error,error(Msg, [g|Where])), !.
'$process_error'(Throw, _) :-
print_message(error,error(unhandled_exception,Throw)).
%% @}

View File

@@ -1,128 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: eval.yap *
* Last rev: *
* mods: *
* comments: optimise disjunction handling *
* *
*************************************************************************/
:- system_module( '$_eval', [], ['$full_clause_optimisation'/4]).
:- use_system_module( terms, [new_variables_in_term/3,
variables_within_term/3]).
:- multifile '$full_clause_optimisation'/4.
'$add_extra_safe'('$plus'(_,_,V)) --> !, [V].
'$add_extra_safe'('$minus'(_,_,V)) --> !, [V].
'$add_extra_safe'('$times'(_,_,V)) --> !, [V].
'$add_extra_safe'('$div'(_,_,V)) --> !, [V].
'$add_extra_safe'('$and'(_,_,V)) --> !, [V].
'$add_extra_safe'('$or'(_,_,V)) --> !, [V].
'$add_extra_safe'('$sll'(_,_,V)) --> !, [V].
'$add_extra_safe'('$slr'(_,_,V)) --> !, [V].
'$add_extra_safe'(C=D,A,B) :-
!,
( compound(C) ->
'$variables_in_term'(C,E,A)
;
E=A
),
( compound(D) ->
'$variables_in_term'(D,B,E)
;
B=E
).
'$add_extra_safe'(_) --> [].
'$gen_equals'([], [], _, O, O).
'$gen_equals'([V|Commons],[NV|NCommons], LV0, O, NO) :- V == NV, !,
'$gen_equals'(Commons,NCommons, LV0, O, NO).
'$gen_equals'([V|Commons],[NV|NCommons], LV0, O, OO) :-
'$vmember'(V,LV0),
OO = (V=NV,'$safe'(NV),NO),
'$gen_equals'(Commons,NCommons, LV0, O, NO).
'$gen_equals'([V|Commons],[NV|NCommons], LV0, O, OO) :-
OO = (V=NV,NO),
'$gen_equals'(Commons,NCommons, LV0, O, NO).
'$safe_guard'((A,B), M) :- !,
'$safe_guard'(A, M),
'$safe_guard'(B, M).
'$safe_guard'((A;B), M) :- !,
'$safe_guard'(A, M),
'$safe_guard'(B, M).
'$safe_guard'(A, M) :- !,
'$safe_builtin'(A, M).
'$safe_builtin'(G, Mod) :-
'$predicate_flags'(G, Mod, Fl, Fl),
Fl /\ 0x00008880 =\= 0.
'$vmember'(V,[V1|_]) :- V == V1, !.
'$vmember'(V,[_|LV0]) :-
'$vmember'(V,LV0).
'$localise_disj_vars'((B;B2), M, (NB ; NB2), LV, LV0, LEqs) :- !,
'$localise_vars'(B, M, NB, LV, LV0, LEqs),
'$localise_disj_vars'(B2, M, NB2, LV, LV0, LEqs).
'$localise_disj_vars'(B2, M, NB, LV, LV0, LEqs) :-
'$localise_vars'(B2, M, NB, LV, LV0, LEqs).
'$localise_vars'((A->B), M, (A->NB), LV, LV0, LEqs) :-
'$safe_guard'(A, M), !,
'$variables_in_term'(A, LV, LV1),
'$localise_vars'(B, M, NB, LV1, LV0, LEqs).
'$localise_vars'((A;B), M, (NA;NB), LV1, LV0, LEqs) :- !,
'$localise_vars'(A, M, NA, LV1, LV0, LEqs),
'$localise_disj_vars'(B, M, NB, LV1, LV0, LEqs).
'$localise_vars'(((A,B),C), M, NG, LV, LV0, LEqs) :- !,
'$flatten_bd'((A,B),C,NB),
'$localise_vars'(NB, M, NG, LV, LV0, LEqs).
'$localise_vars'((!,B), M, (!,NB), LV, LV0, LEqs) :- !,
'$localise_vars'(B, M, NB, LV, LV0, LEqs).
'$localise_vars'((X=Y,B), M, (X=Y,NB1), LV, LV0, LEqs) :-
var(X), var(Y), !,
'$localise_vars'(B, M, NB1, LV, LV0, [X,Y|LEqs]).
'$localise_vars'((G,B), M, (G,NB1), LV, LV0, LEqs) :-
'$safe_builtin'(G, M), !,
'$variables_in_term'(G, LV, LV1),
'$add_extra_safe'(G, NLV0, LV0),
'$localise_vars'(B, M, NB1, LV1, NLV0, LEqs).
'$localise_vars'((G1,B1), _, O, LV, LV0, LEqs) :- !,
terms:variables_within_term(LV, B1, Commons),
terms:new_variables_in_term(LV, B1, New),
copy_term(Commons+New+LEqs+B1, NCommons+NNew+NLEqs+NB1),
NNew = New,
NLEqs = LEqs,
'$gen_equals'(Commons, NCommons, LV0, (G1,NB1), O).
'$localise_vars'(G, _, G, _, _, _).
'$flatten_bd'((A,B),R,NB) :- !,
'$flatten_bd'(B,R,R1),
'$flatten_bd'(A,R1,NB).
'$flatten_bd'(A,R,(A,R)).
% the idea here is to make global variables in disjunctions
% local.
'$localise_vars_opt'(H, M, (B1;B2), (NB1;NB2)) :-
'$variables_in_term'(H, [], LV),
'$localise_vars'(B1, M, NB1, LV, LV, []),
'$localise_disj_vars'(B2, M, NB2, LV, LV, []).
%, portray_clause((H:-BF))
'$full_clause_optimisation'(H, M, B0, BF) :-
'$localise_vars_opt'(H, M, B0, BF), !.

View File

@@ -1,106 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: flags.yap *
* Last rev: *
* mods: *
* comments: controlling YAP *
* *
*************************************************************************/
/**
* @file flagd.ysp
*
* @defgroup Flags Yap Flags
*n@{}
* @ingroup builtins
* @}@[ ]
*/
:- system_module( '$_flags', [create_prolog_flag/3,
current_prolog_flag/2,
no_source/0,
prolog_flag/2,
prolog_flag/3,
set_prolog_flag/2,
source/0,
source_mode/2,
yap_flag/2,
yap_flag/3], []).
'$adjust_language'(cprolog) :-
% '$switch_log_upd'(0),
'$syntax_check_mode'(_,off),
'$syntax_check_single_var'(_,off),
'$syntax_check_discontiguous'(_,off),
'$syntax_check_multiple'(_,off),
'$swi_set_prolog_flag'(character_escapes, false), % disable character escapes.
'$set_yap_flags'(14,1),
'$set_fpu_exceptions'(true),
unknown(_,fail).
'$adjust_language'(sicstus) :-
'$switch_log_upd'(1),
leash(full),
'$syntax_check_mode'(_,on),
'$syntax_check_single_var'(_,on),
'$syntax_check_discontiguous'(_,on),
'$syntax_check_multiple'(_,on),
'$transl_to_on_off'(X1,on),
'$set_yap_flags'(5,X1),
'$force_char_conversion',
'$set_yap_flags'(14,0),
% CHARACTER_ESCAPE
'$swi_set_prolog_flag'(character_escapes, true), % disable character escapes.
'$set_fpu_exceptions'(true),
'$swi_set_prolog_flag'(fileerrors, true),
unknown(_,error).
'$adjust_language'(iso) :-
'$switch_log_upd'(1),
style_check(all),
fileerrors,
'$transl_to_on_off'(X1,on),
% CHAR_CONVERSION
'$set_yap_flags'(5,X1),
'$force_char_conversion',
% ALLOW_ASSERTING_STATIC
'$set_yap_flags'(14,0),
% CHARACTER_ESCAPE
'$swi_set_prolog_flag'(character_escapes, true), % disable character escapes.
'$set_fpu_exceptions'(true),
unknown(_,error).
/** @pred create_prolog_flag(+ _Flag_,+ _Value_,+ _Options_)
Create a new YAP Prolog flag. _Options_ include
* `type(+_Type_)` with _Type_ one of `boolean`, `integer`, `float`, `atom`
and `term` (that is, any ground term)
* `access(+_Access_)` with _Access_ one of `read_only` or `read_write`
* `keeep(+_Keep_) protect existing flag.
*/
create_prolog_flag(Name, Value, Options) :-
'$flag_domain_from_value'( Value, Type ),
'$create_prolog_flag'(Name, Value, [type(Type)|Options]).
'$flag_domain_from_value'(true, boolean) :- !.
'$flag_domain_from_value'(false, boolean) :- !.
'$flag_domain_from_value'(Value, integer) :- integer(Value), !.
'$flag_domain_from_value'(Value, float) :- float(Value), !.
'$flag_domain_from_value'(Value, atom) :- atom(Value), !.
'$flag_domain_from_value'(_, term).
/**
@}
*/

View File

@@ -1,325 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: grammar.pl *
* Last rev: *
* mods: *
* comments: BNF grammar for Prolog *
* *
*************************************************************************/
/**
* @file grammar.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Thu Nov 19 10:20:55 2015
*
* @brief Grammar Rules
*
*
*/
/**
@defgroup Grammars Grammar Rules
@ingroup builtins
@{
Grammar rules in Prolog are both a convenient way to express definite
clause grammars and an extension of the well known context-free grammars.
A grammar rule is of the form:
~~~~~
head --> body
~~~~~
where both \a head and \a body are sequences of one or more items
linked by the standard conjunction operator `,`.
<em>Items can be:</em>
+
a <em>non-terminal</em> symbol may be either a complex term or an atom.
+
a <em>terminal</em> symbol may be any Prolog symbol. Terminals are
written as Prolog lists.
+
an <em>empty body</em> is written as the empty list `[ ]`.
+
<em>extra conditions</em> may be inserted as Prolog procedure calls, by being
written inside curly brackets `{` and `}`.
+
the left side of a rule consists of a nonterminal and an optional list
of terminals.
+
alternatives may be stated in the right-hand side of the rule by using
the disjunction operator `;`.
+
the <em>cut</em> and <em>conditional</em> symbol (`->`) may be inserted in the
right hand side of a grammar rule
Grammar related built-in predicates:
*/
:- system_module( '$_grammar', [!/2,
(',')/4,
(->)/4,
('.')/4,
(;)/4,
'C'/3,
[]/2,
[]/4,
(\+)/3,
phrase/2,
phrase/3,
{}/3,
('|')/4], ['$do_error'/2]).
% :- meta_predicate ^(?,0,?).
% ^(Xs, Goal, Xs) :- call(Goal).
% :- meta_predicate ^(?,1,?,?).
% ^(Xs0, Goal, Xs0, Xs) :- call(Goal, Xs).
/*
Variables X in grammar rule bodies are translated as
if phrase(X) had been written, where phrase/3 is obvious.
Also, phrase/2-3 check their first argument.
*/
prolog:'$translate_rule'(Rule, (NH :- B) ) :-
source_module( SM ),
'$yap_strip_module'( SM:Rule, M0, (LP-->RP) ),
t_head(LP, NH0, NGs, S, SR, (LP-->SM:RP)),
'$yap_strip_module'( M0:NH0, M, NH1 ),
( M == SM -> NH = NH1 ; NH = M:NH1 ),
(var(NGs) ->
t_body(RP, _, last, S, SR, B1)
;
t_body((RP,{NGs}), _, last, S, SR, B1)
),
t_tidy(B1, B).
t_head(V, _, _, _, _, G0) :- var(V), !,
'$do_error'(instantiation_error,G0).
t_head((H,List), NH, NGs, S, S1, G0) :- !,
t_hgoal(H, NH, S, SR, G0),
t_hlist(List, S1, SR, NGs, G0).
t_head(H, NH, _, S, SR, G0) :-
t_hgoal(H, NH, S, SR, G0).
t_hgoal(V, _, _, _, G0) :- var(V), !,
'$do_error'(instantiation_error,G0).
t_hgoal(M:H, M:NH, S, SR, G0) :- !,
t_hgoal(H, NH, S, SR, G0).
t_hgoal(H, NH, S, SR, _) :-
extend([S,SR],H,NH).
t_hlist(V, _, _, _, G0) :- var(V), !,
'$do_error'(instantiation_error,G0).
t_hlist([], _, _, true, _).
t_hlist(String, S0, SR, SF, G0) :- string(String), !,
string_codes( String, X ),
t_hlist( X, S0, SR, SF, G0).
t_hlist([H], S0, SR, ('C'(SR,H,S0)), _) :- !.
t_hlist([H|List], S0, SR, ('C'(SR,H,S1),G0), Goal) :- !,
t_hlist(List, S0, S1, G0, Goal).
t_hlist(T, _, _, _, Goal) :-
'$do_error'(type_error(list,T),Goal).
%
% Two extra variables:
% ToFill tells whether we need to explictly close the chain of
% variables.
% Last tells whether we are the ones who should close that chain.
%
t_body(Var, filled_in, _, S, S1, phrase(Var,S,S1)) :-
var(Var),
!.
t_body(!, to_fill, last, S, S1, (!, S1 = S)) :- !.
t_body(!, _, _, S, S, !) :- !.
t_body([], to_fill, last, S, S1, S1=S) :- !.
t_body([], _, _, S, S, true) :- !.
t_body(X, FilledIn, Last, S, SR, OS) :- string(X), !,
string_codes( X, Codes),
t_body(Codes, FilledIn, Last, S, SR, OS).
t_body([X], filled_in, _, S, SR, 'C'(S,X,SR)) :- !.
t_body([X|R], filled_in, Last, S, SR, ('C'(S,X,SR1),RB)) :- !,
t_body(R, filled_in, Last, SR1, SR, RB).
t_body({T}, to_fill, last, S, S1, (T, S1=S)) :- !.
t_body({T}, _, _, S, S, T) :- !.
t_body((T,R), ToFill, Last, S, SR, (Tt,Rt)) :- !,
t_body(T, ToFill, not_last, S, SR1, Tt),
t_body(R, ToFill, Last, SR1, SR, Rt).
t_body((T->R), ToFill, Last, S, SR, (Tt->Rt)) :- !,
t_body(T, ToFill, not_last, S, SR1, Tt),
t_body(R, ToFill, Last, SR1, SR, Rt).
t_body(\+T, ToFill, _, S, SR, (Tt->fail ; S=SR)) :- !,
t_body(T, ToFill, not_last, S, _, Tt).
t_body((T;R), _ToFill, _, S, SR, (Tt;Rt)) :- !,
t_body(T, _, last, S, SR, Tt),
t_body(R, _, last, S, SR, Rt).
t_body((T|R), _ToFill, _, S, SR, (Tt;Rt)) :- !,
t_body(T, _, last, S, SR, Tt),
t_body(R, _, last, S, SR, Rt).
t_body(M:G, ToFill, Last, S, SR, M:NG) :- !,
t_body(G, ToFill, Last, S, SR, NG).
t_body(T, filled_in, _, S, SR, Tt) :-
extend([S,SR], T, Tt).
extend(More, OldT, NewT) :-
OldT =.. OldL,
lists:append(OldL, More, NewL),
NewT =.. NewL.
t_tidy(P,P) :- var(P), !.
t_tidy((P1;P2), (Q1;Q2)) :- !,
t_tidy(P1, Q1),
t_tidy(P2, Q2).
t_tidy((P1->P2), (Q1->Q2)) :- !,
t_tidy(P1, Q1),
t_tidy(P2, Q2).
t_tidy(((P1,P2),P3), Q) :-
t_tidy((P1,(P2,P3)), Q).
t_tidy((true,P1), Q1) :- !,
t_tidy(P1, Q1).
t_tidy((P1,true), Q1) :- !,
t_tidy(P1, Q1).
t_tidy((P1,P2), (Q1,Q2)) :- !,
t_tidy(P1, Q1),
t_tidy(P2, Q2).
t_tidy(A, A).
/** @pred `C`( _S1_, _T_, _S2_)
This predicate is used by the grammar rules compiler and is defined as
`C`([H|T],H,T)`.
*/
prolog:'C'([X|S],X,S).
/** @pred phrase(+ _P_, _L_)
This predicate succeeds when _L_ is a phrase of type _P_. The
same as `phrase(P,L,[])`.
Both this predicate and the previous are used as a convenient way to
start execution of grammar rules.
*/
prolog:phrase(PhraseDef, WordList) :-
prolog:phrase(PhraseDef, WordList, []).
/** @pred phrase(+ _P_, _L_, _R_)
This predicate succeeds when the difference list ` _L_- _R_`
is a phrase of type _P_.
*/
prolog:phrase(V, S0, S) :-
var(V),
!,
'$do_error'(instantiation_error,phrase(V,S0,S)).
prolog:phrase([H|T], S0, S) :-
!,
S0 = [H|S1],
'$phrase_list'(T, S1, S).
prolog:phrase([], S0, S) :-
!,
S0 = S.
prolog:phrase(P, S0, S) :-
call(P, S0, S).
'$phrase_list'([], S, S).
'$phrase_list'([H|T], [H|S1], S0) :-
'$phrase_list'(T, S1, S0).
prolog:!(S, S).
prolog:[](S, S).
prolog:[](H, T, S0, S) :- lists:append([H|T], S, S0).
prolog:'.'(H,T, S0, S) :-
lists:append([H|T], S, S0).
prolog:{}(Goal, S0, S) :-
Goal,
S0 = S.
prolog:','(A,B, S0, S) :-
t_body((A,B), _, last, S0, S, Goal),
'$execute'(Goal).
prolog:';'(A,B, S0, S) :-
t_body((A;B), _, last, S0, S, Goal),
'$execute'(Goal).
prolog:('|'(A,B, S0, S)) :-
t_body((A|B), _, last, S0, S, Goal),
'$execute'(Goal).
prolog:'->'(A,B, S0, S) :-
t_body((A->B), _, last, S0, S, Goal),
'$execute'(Goal).
prolog:'\\+'(A, S0, S) :-
t_body(\+ A, _, last, S0, S, Goal),
'$execute'(Goal).
:- multifile system:goal_expansion/2.
:- dynamic system:goal_expansion/2.
'$c_built_in_phrase'(NT, Xs0, Xs, Mod, NewGoal) :-
catch(prolog:'$translate_rule'(
(pseudo_nt --> Mod:NT), Rule),
error(Pat,ImplDep),
( \+ '$harmless_dcgexception'(Pat),
throw(error(Pat,ImplDep))
)
),
Rule = (pseudo_nt(Xs0c,Xsc) :- NewGoal0),
Mod:NT \== NewGoal0,
% apply translation only if we are safe
\+ '$contains_illegal_dcgnt'(NT),
!,
( var(Xsc), Xsc \== Xs0c
-> Xs = Xsc, NewGoal1 = NewGoal0
; NewGoal1 = (NewGoal0, Xsc = Xs)
),
( var(Xs0c)
-> Xs0 = Xs0c,
NewGoal2 = NewGoal1
; ( Xs0 = Xs0c, NewGoal1 ) = NewGoal2
),
'$yap_strip_module'(Mod:NewGoal2, M, NewGoal3),
(nonvar(NewGoal3) -> NewGoal = M:NewGoal3
;
var(M) -> NewGoal = '$execute_wo_mod'(NewGoal3,M)
;
NewGoal = '$execute_in_mod'(NewGoal3,M)
).
do_c_built_in('C'(A,B,C), _, _, (A=[B|C])) :- !.
do_c_built_in(phrase(NT,Xs0, Xs),Mod, _, NewGoal) :-
nonvar(NT), nonvar(Mod), !,
'$c_built_in_phrase'(NT, Xs0, Xs, Mod, NewGoal).
do_c_built_in(phrase(NT,Xs),Mod,_,NewGoal) :-
nonvar(NT), nonvar(Mod),
'$c_built_in_phrase'(NT, Xs, [], Mod, NewGoal).
/**
@}
*/

View File

@@ -1,63 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: ground.pl *
* Last rev: *
* mods: *
* comments: Variables and ground *
* *
*************************************************************************/
/*
% grounds all free variables
% as terms of the form '$VAR'(N)
numbervars('$VAR'(M), M, N) :- !,
succ(M, N).
numbervars(Atomic, M, M) :-
atomic(Atomic), !.
numbervars(Term, M, N) :-
functor(Term, _, Arity),
'$numbervars'(0,Arity, Term, M, N).
'$numbervars'(A, A, _, N, N) :- !.
'$numbervars'(A,Arity, Term, M, N) :-
'$succ'(A,An),
arg(An, Term, Arg),
numbervars(Arg, M, K), !,
'$numbervars'(An, Arity, Term, K, N).
ground(Term) :-
nonvar(Term), % This term is not a variable,
functor(Term, _, Arity),
'$ground'(Arity, Term). % and none of its arguments are.
'$ground'(0, _) :- !.
'$ground'(N, Term) :-
'$predc'(N,M),
arg(N, Term, ArgN),
ground(ArgN),
'$ground'(M, Term).
numbervars(Term, M, N) :-
'$variables_in_term'(Term, [], L),
'$numbermarked_vars'(L, M, N).
'$numbermarked_vars'([], M, M).
'$numbermarked_vars'([V|L], M, N) :-
attvar(V), !,
'$numbermarked_vars'(L, M, N).
'$numbermarked_vars'(['$VAR'(M)|L], M, N) :-
M1 is M+1,
'$numbermarked_vars'(L, M1, N).
*/

View File

@@ -1,255 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: utilities for messing around in YAP internals. *
* comments: error messages for YAP *
* *
* Last rev: $Date: 2008-03-24 23:48:47 $,$Author: vsc $ *
* *
* *
*************************************************************************/
%% @file pl/hacks.yap
:- module('$hacks',
[display_stack_info/4,
display_stack_info/6,
display_pc/4,
fully_strip_module/3,
code_location/3]).
/** hacks:context_variables(-NamedVariables)
Access variable names.
Unify NamedVariables with a list of terms _Name_=_V_
giving the names of the variables occurring in the last term read.
Notice that variable names option must have been on.
*/
hacks:context_variables(NamedVariables) :-
'$context_variables'(NamedVariables).
prolog:'$stack_dump' :-
yap_hacks:current_choicepoints(CPs),
yap_hacks:current_continuations([Env|Envs]),
yap_hacks:continuation(Env,_,ContP,_),
length(CPs, LCPs),
length(Envs, LEnvs),
format(user_error,'~n~n~tStack Dump~t~40+~n~nAddress~tChoiceP~16+ Clause Goal~n',[LCPs,LEnvs]),
display_stack_info(CPs, Envs, 20, ContP, StackInfo, []),
run_formats(StackInfo, user_error).
run_formats([], _).
run_formats([Com-Args|StackInfo], Stream) :-
format(Stream, Com, Args),
run_formats(StackInfo, Stream).
display_stack_info(CPs,Envs,Lim,PC) :-
display_stack_info(CPs,Envs,Lim,PC,Lines,[]),
flush_output(user_output),
flush_output(user_error),
print_message_lines(user_error, '', Lines).
code_location(Info,Where,Location) :-
integer(Where) , !,
pred_for_code(Where,Name,Arity,Mod,Clause),
construct_code(Clause,Name,Arity,Mod,Info,Location).
code_location(Info,_,Info).
construct_code(-1,Name,Arity,Mod,Where,Location) :- !,
number_codes(Arity,ArityCode),
atom_codes(ArityAtom,ArityCode),
atom_concat([Where,' at ',Mod,':',Name,'/',ArityAtom,' at indexing code'],Location).
construct_code(0,_,_,_,Location,Location) :- !.
construct_code(Cl,Name,Arity,Mod,Where,Location) :-
number_codes(Arity,ArityCode),
atom_codes(ArityAtom,ArityCode),
number_codes(Cl,ClCode),
atom_codes(ClAtom,ClCode),
atom_concat([Where,' at ',Mod,':',Name,'/',ArityAtom,' (clause ',ClAtom,')'],Location).
'$prepare_loc'(Info,Where,Location) :- integer(Where), !,
pred_for_code(Where,Name,Arity,Mod,Clause),
'$construct_code'(Clause,Name,Arity,Mod,Info,Location).
'$prepare_loc'(Info,_,Info).
display_pc(PC, PP, Source) -->
{ integer(PC) },
{ pred_for_code(PC,Name,Arity,Mod,Clause) },
pc_code(Clause, PP, Name, Arity, Mod, Source).
pc_code(0,_PP,_Name,_Arity,_Mod, 'top level or system code' - []) --> !.
pc_code(-1,_PP,Name,Arity,Mod, '~a:~q/~d' - [Mod,Name,Arity]) --> !,
{ functor(S, Name,Arity),
nth_clause(Mod:S,1,Ref),
clause_property(Ref, file(File)),
clause_property(Ref, line_count(Line)) },
[ '~a:~d:0, ' - [File,Line] ].
pc_code(Cl,Name,Arity,Mod, 'clause ~d for ~a:~q/~d'-[Cl,Mod,Name,Arity]) -->
{ Cl > 0 },
{ functor(S, Name,Arity),
nth_clause(Mod:S,Cl,Ref),
clause_property(Ref, file(File)),
clause_property(Ref, line_count(Line)) },
[ '~a:~d:0, ' - [File,Line] ].
display_stack_info(_,_,0,_) --> !.
display_stack_info([],[],_,_) --> [].
display_stack_info([CP|CPs],[],I,_) -->
show_lone_cp(CP),
{ I1 is I-1 },
display_stack_info(CPs,[],I1,_).
display_stack_info([],[Env|Envs],I,Cont) -->
show_env(Env, Cont, NCont),
{ I1 is I-1 },
display_stack_info([], Envs, I1, NCont).
display_stack_info([CP|LCPs],[Env|LEnvs],I,Cont) -->
{
yap_hacks:continuation(Env, _, NCont, CB),
I1 is I-1
},
( { CP == Env, CB < CP } ->
% if we follow choice-point and we cut to before choice-point
% we are the same goal
show_cp(CP, ''), %
display_stack_info(LCPs, LEnvs, I1, NCont)
;
{ CP > Env } ->
show_cp(CP, ' < '),
display_stack_info(LCPs,[Env|LEnvs],I1,Cont)
;
show_env(Env,Cont,NCont),
display_stack_info([CP|LCPs],LEnvs,I1,NCont)
).
show_cp(CP, Continuation) -->
{ yap_hacks:choicepoint(CP, Addr, Mod, Name, Arity, Goal, ClNo) },
( { Goal = (_;_) }
->
{ scratch_goal(Name,Arity,Mod,Caller) },
[ '0x~16r~t*~16+ ~d~16+ ~q ~n'-
[Addr, ClNo, Caller] ]
;
[ '0x~16r~t *~16+~a ~d~16+ ~q:' -
[Addr, Continuation, ClNo, Mod]]
),
{ prolog_flag( debugger_print_options, Opts) },
{clean_goal(Goal,Mod,G)},
['~@.~n' - write_term(G,Opts)].
show_env(Env,Cont,NCont) -->
{
yap_hacks:continuation(Env, Addr, NCont, _),
format('0x~16r 0x~16r~n',[Env,NCont]),
yap_hacks:cp_to_predicate(Cont, Mod, Name, Arity, ClId)
},
[ '0x~16r~t ~16+ ~d~16+ ~q:' -
[Addr, ClId, Mod] ],
{scratch_goal(Name, Arity, Mod, G)},
{ prolog_flag( debugger_print_options, Opts) },
['~@.~n' - write_term(G,Opts)].
clean_goal(G,Mod,NG) :-
beautify_hidden_goal(G,Mod,[NG],[]), !.
clean_goal(G,_,G).
scratch_goal(N,0,Mod,Mod:N) :-
!.
scratch_goal(N,A,Mod,NG) :-
list_of_qmarks(A,L),
G=..[N|L],
(
beautify_hidden_goal(G,Mod,[NG],[])
;
G = NG
),
!.
list_of_qmarks(0,[]) :- !.
list_of_qmarks(I,[?|L]) :-
I1 is I-1,
list_of_qmarks(I1,L).
fully_strip_module( T, M, TF) :-
'$yap_strip_module'( T, M, TF).
beautify_hidden_goal('$yes_no'(G,_Query), prolog) -->
!,
{ Call =.. [(?), G] },
[Call].
beautify_hidden_goal('$do_yes_no'(G,Mod), prolog) -->
[Mod:G].
beautify_hidden_goal('$query'(G,VarList), prolog) -->
[query(G,VarList)].
beautify_hidden_goal('$enter_top_level', prolog) -->
['TopLevel'].
% The user should never know these exist.
beautify_hidden_goal('$csult'(Files,Mod),prolog) -->
[reconsult(Mod:Files)].
beautify_hidden_goal('$use_module'(Files,Mod,Is),prolog) -->
[use_module(Mod,Files,Is)].
beautify_hidden_goal('$continue_with_command'(reconsult,V,P,G,Source),prolog) -->
['Assert'(G,V,P,Source)].
beautify_hidden_goal('$continue_with_command'(consult,V,P,G,Source),prolog) -->
['Assert'(G,V,P,Source)].
beautify_hidden_goal('$continue_with_command'(top,V,P,G,_),prolog) -->
['Query'(G,V,P)].
beautify_hidden_goal('$continue_with_command'(Command,V,P,G,Source),prolog) -->
['TopLevel'(Command,G,V,P,Source)].
beautify_hidden_goal('$spycall'(G,M,InControl,Redo),prolog) -->
['DebuggerCall'(M:G, InControl, Redo)].
beautify_hidden_goal('$do_spy'(Goal, Mod, _CP, InControl),prolog) -->
['DebuggerCall'(Mod:Goal, InControl)].
beautify_hidden_goal('$system_catch'(G,Mod,Exc,Handler),prolog) -->
[catch(Mod:G, Exc, Handler)].
beautify_hidden_goal('$catch'(G,Exc,Handler),prolog) -->
[catch(G, Exc, Handler)].
beautify_hidden_goal('$execute_command'(Query,V,P,Option,Source),prolog) -->
[toplevel_query(Query, V, P, Option, Source)].
beautify_hidden_goal('$process_directive'(Gs,_Mode,_VL),prolog) -->
[(:- Gs)].
beautify_hidden_goal('$loop'(Stream,Option),prolog) -->
[execute_load_file(Stream, consult=Option)].
beautify_hidden_goal('$load_files'(Files,Opts,?),prolog) -->
[load_files(Files,Opts)].
beautify_hidden_goal('$load_files'(_,_,Name),prolog) -->
[Name].
beautify_hidden_goal('$reconsult'(Files,Mod),prolog) -->
[reconsult(Mod:Files)].
beautify_hidden_goal('$undefp'([Mod|G]),prolog) -->
['CallUndefined'(Mod:G)].
beautify_hidden_goal('$undefp'(?),prolog) -->
['CallUndefined'(?:?)].
beautify_hidden_goal(repeat,prolog) -->
[repeat].
beautify_hidden_goal('$recorded_with_key'(A,B,C),prolog) -->
[recorded(A,B,C)].
beautify_hidden_goal('$findall_with_common_vars'(Templ,Gen,Answ),prolog) -->
[findall(Templ,Gen,Answ)].
beautify_hidden_goal('$bagof'(Templ,Gen,Answ),prolog) -->
[bagof(Templ,Gen,Answ)].
beautify_hidden_goal('$setof'(Templ,Gen,Answ),prolog) -->
[setof(Templ,Gen,Answ)].
beautify_hidden_goal('$findall'(T,G,S,A),prolog) -->
[findall(T,G,S,A)].
beautify_hidden_goal('$listing'(G,M,_Stream),prolog) -->
[listing(M:G)].
beautify_hidden_goal('$call'(G,_CP,?,M),prolog) -->
[call(M:G)].
beautify_hidden_goal('$call'(_G,_CP,G0,M),prolog) -->
[call(M:G0)].
beautify_hidden_goal('$current_predicate'(Na,M,S,_),prolog) -->
[current_predicate(Na,M:S)].
beautify_hidden_goal('$list_clauses'(Stream,M,Pred),prolog) -->
[listing(Stream,M:Pred)].

View File

@@ -1,384 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
** Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: init.yap *
* Last rev: *
* mods: *
* comments: initializing the full prolog system *
* *
*************************************************************************/
/**
@file init.yap
@{
@defgroup library The Prolog library
@}
@addtogroup YAPControl
@ingroup builtins
@{
*/
:- system_module( '$_init', [!/0,
':-'/1,
'?-'/1,
[]/0,
extensions_to_present_answer/1,
fail/0,
false/0,
goal_expansion/2,
goal_expansion/3,
otherwise/0,
term_expansion/2,
version/2,
'$do_log_upd_clause'/6,
'$do_log_upd_clause0'/6,
'$do_log_upd_clause_erase'/6,
'$do_static_clause'/5], [
'$system_module'/1]).
:- use_system_module( '$_boot', ['$cut_by'/1]).
%:- start_low_level_trace.
% This is the YAP init file
% should be consulted first step after booting
% These are pseudo declarations
% so that the user will get a redefining system predicate
:- '$init_pred_flag_vals'('$flag_info'(a,0), prolog).
/** @pred fail is iso
Always fails.
*/
fail :- fail.
/** @pred false is iso
The same as fail.
*/
false :- fail.
otherwise.
!.
(:- G) :- '$execute'(G), !.
(?- G) :- '$execute'(G).
'$$!'(CP) :- '$cut_by'(CP).
[] :- true.
:- set_value('$doindex',true).
% just create a choice-point
% the 6th argument marks the time-stamp.
'$do_log_upd_clause'(_,_,_,_,_,_).
'$do_log_upd_clause'(A,B,C,D,E,_) :-
'$continue_log_update_clause'(A,B,C,D,E).
'$do_log_upd_clause'(_,_,_,_,_,_).
'$do_log_upd_clause_erase'(_,_,_,_,_,_).
'$do_log_upd_clause_erase'(A,B,C,D,E,_) :-
'$continue_log_update_clause_erase'(A,B,C,D,E).
'$do_log_upd_clause_erase'(_,_,_,_,_,_).
'$do_log_upd_clause0'(_,_,_,_,_,_).
'$do_log_upd_clause0'(A,B,C,D,_,_) :-
'$continue_log_update_clause'(A,B,C,D).
'$do_log_upd_clause0'(_,_,_,_,_,_).
'$do_static_clause'(_,_,_,_,_).
'$do_static_clause'(A,B,C,D,E) :-
'$continue_static_clause'(A,B,C,D,E).
'$do_static_clause'(_,_,_,_,_).
:- bootstrap('arith.yap').
:- '$all_current_modules'(M), yap_flag(M:unknown, error) ; true.
:- compile_expressions.
:- bootstrap('bootutils.yap').
:- bootstrap('bootlists.yap').
:- bootstrap('consult.yap').
:- bootstrap('preddecls.yap').
:- bootstrap('preddyns.yap').
:- bootstrap('meta.yap').
:- bootstrap('newmod.yap').
:- bootstrap('atoms.yap').
:- bootstrap('os.yap').
:- bootstrap('grammar.yap').
:- bootstrap('directives.yap').
:- bootstrap('absf.yap').
:- dynamic prolog:'$parent_module'/2.
:- [
'preds.yap',
'modules.yap'
].
:- use_module('error.yap').
:- [
'errors.yap',
'utils.yap',
'control.yap',
'flags.yap'
].
:- [
% lists is often used.
'yio.yap',
'debug.yap',
'checker.yap',
'depth_bound.yap',
'ground.yap',
'listing.yap',
'arithpreds.yap',
% modules must be after preds, otherwise we will have trouble
% with meta-predicate expansion being invoked
% must follow grammar
'eval.yap',
'signals.yap',
'profile.yap',
'callcount.yap',
'load_foreign.yap',
% 'save.yap',
'setof.yap',
'sort.yap',
'statistics.yap',
'strict_iso.yap',
'tabling.yap',
'threads.yap',
'eam.yap',
'yapor.yap',
'qly.yap',
'spy.yap',
'udi.yap'].
:- meta_predicate(log_event(+,:)).
:- dynamic prolog:'$user_defined_flag'/4.
:- multifile prolog:debug_action_hook/1.
:- multifile prolog:'$system_predicate'/2.
:- ['protect.yap'].
version(yap,[6,3]).
:- op(1150,fx,(mode)).
:- dynamic 'extensions_to_present_answer'/1.
:- ['arrays.yap'].
%:- start_low_level_trace.
:- multifile user:portray_message/2.
:- dynamic user:portray_message/2.
/** @pred _CurrentModule_:goal_expansion(+ _G_,+ _M_,- _NG_), user:goal_expansion(+ _G_,+ _M_,- _NG_)
YAP now supports goal_expansion/3. This is an user-defined
procedure that is called after term expansion when compiling or
asserting goals for each sub-goal in a clause. The first argument is
bound to the goal and the second to the module under which the goal
_G_ will execute. If goal_expansion/3 succeeds the new
sub-goal _NG_ will replace _G_ and will be processed in the same
way. If goal_expansion/3 fails the system will use the defaultyap+flrules.
*/
:- multifile user:goal_expansion/3.
:- dynamic user:goal_expansion/3.
:- multifile user:goal_expansion/2.
:- dynamic user:goal_expansion/2.
:- multifile system:goal_expansion/2.
:- dynamic system:goal_expansion/2.
:- multifile goal_expansion/2.
:- dynamic goal_expansion/2.
:- use_module('messages.yap').
:- ['undefined.yap'].
:- use_module('hacks.yap').
:- use_module('attributes.yap').
:- use_module('corout.yap').
:- use_module('dialect.yap').
:- use_module('dbload.yap').
:- use_module('../library/ypp.yap').
:- use_module('../os/chartypes.yap').
:- ensure_loaded('../os/edio.yap').
yap_hacks:cut_by(CP) :- '$$cut_by'(CP).
:- '$change_type_of_char'(36,7). % Make $ a symbol character
:- set_prolog_flag(generate_debug_info,true).
%
% cleanup ensure loaded and recover some data-base space.
%
:- ( recorded('$lf_loaded',_,R), erase(R), fail ; true ).
:- ( recorded('$lf_loaded',_,R), erase(R), fail ; true ).
:- ( recorded('$module',_,R), erase(R), fail ; true ).
:- set_value('$user_module',user), '$protect'.
:- style_check([+discontiguous,+multiple,+single_var]).
%
% moved this to init_gc in gc.c to separate the alpha
%
% :- yap_flag(gc,on).
% :- yap_flag(gc_trace,verbose).
:- multifile
prolog:comment_hook/3.
:- source.
:- module(user).
/** @pred _CurrentModule_:term_expansion( _T_,- _X_), user:term_expansion( _T_,- _X_)
This user-defined predicate is called by `expand_term/3` to
preprocess all terms read when consulting a file. If it succeeds:
+
If _X_ is of the form `:- G` or `?- G`, it is processed as
a directive.
+
If _X_ is of the form `$source_location`( _File_, _Line_): _Clause_` it is processed as if from `File` and line `Line`.
+
If _X_ is a list, all terms of the list are asserted or processed
as directives.
+ The term _X_ is asserted instead of _T_.
*/
:- multifile term_expansion/2.
:- dynamic term_expansion/2.
:- multifile system:term_expansion/2.
:- dynamic system:term_expansion/2.
:- multifile swi:swi_predicate_table/4.
/** @pred user:message_hook(+ _Term_, + _Kind_, + _Lines_)
Hook predicate that may be define in the module `user` to intercept
messages from print_message/2. _Term_ and _Kind_ are the
same as passed to print_message/2. _Lines_ is a list of
format statements as described with print_message_lines/3.
This predicate should be defined dynamic and multifile to allow other
modules defining clauses for it too.
*/
:- multifile user:message_hook/3.
:- dynamic user:message_hook/3.
/** @pred exception(+ _Exception_, + _Context_, - _Action_)
Dynamic predicate, normally not defined. Called by the Prolog system on run-time exceptions that can be repaired `just-in-time`. The values for _Exception_ are described below. See also catch/3 and throw/1.
If this hook predicate succeeds it must instantiate the _Action_ argument to the atom `fail` to make the operation fail silently, `retry` to tell Prolog to retry the operation or `error` to make the system generate an exception. The action `retry` only makes sense if this hook modified the environment such that the operation can now succeed without error.
+ `undefined_predicate`
_Context_ is instantiated to a predicate-indicator ( _Module:Name/Arity_). If the predicate fails Prolog will generate an existence_error exception. The hook is intended to implement alternatives to the SWI built-in autoloader, such as autoloading code from a database. Do not use this hook to suppress existence errors on predicates. See also `unknown`.
+ `undefined_global_variable`
_Context_ is instantiated to the name of the missing global variable. The hook must call nb_setval/2 or b_setval/2 before returning with the action retry.
*/
:- multifile user:exception/3.
:- dynamic user:exception/3.
:- reconsult('pathconf.yap').
/*
Add some tests
*/
:- yap_flag(user:unknown,error).
/*
:- if(predicate_property(run_tests, static)).
aa b.
p(X,Y) :- Y is X*X.
prefix(information, '% ', S, user_error) --> [].
:- format('~d~n', [a]).
:- format('~d~n', []).
:- p(X,Y).
a(1).
a.
a(2).
a(2).
lists:member(1,[1]).
clause_to_indicator(T, M:Name/Arity) :- ,
strip_module(T, M, T1),
pred_arity( T1, Name, Arity ).
:- endif.
*/

View File

@@ -1,330 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: listing.pl *
* Last rev: *
* mods: *
* comments: listing a prolog program *
* *
*************************************************************************/
:- system_module( '$_listing', [listing/0,
listing/1,
portray_clause/1,
portray_clause/2], []).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_preds', ['$clause'/4,
'$current_predicate'/4]).
/* listing : Listing clauses in the database
*/
/** @pred listing
vxuLists in the current output stream all the clauses for which source code
is available (these include all clauses for dynamic predicates and
clauses for static predicates compiled when source mode was `on`).
- listing/0 lists in the current module
- listing/1 receives a generalization of the predicate indicator:
+ `listing(_)` will list the whole sources.
+ `listing(lists:_)` will list the module lists.
+ `listing(lists:append)` will list all `append` predicates in the module lists.
+ `listing(lists:append/_)` will do the same.
+ listing(lists:append/3)` will list the popular `append/3` predicate in the module lists.
- listing/2 is similar to listing/1, but t he first argument is a stream reference.
The `listing` family of built-ins does not enumerate predicates whose
name starts with a `$` character.
*/
listing :-
current_output(Stream),
'$current_module'(Mod),
\+ system_module(Mod),
Mod \= prolog,
Mod \= system,
\+ '$hidden_atom'( Mod ),
current_predicate( Name, Mod:Pred ),
\+ '$undefined'(Pred, Mod), % skip predicates exported from prolog.
functor(Pred,Name,Arity),
'$listing'(Name,Arity,Mod,Stream),
fail.
listing.
/** @pred listing(+ _P_)
Lists predicate _P_ if its source code is available.
*/
listing(MV) :-
current_output(Stream),
listing(Stream, MV).
listing(Stream, MV) :-
strip_module( MV, M, I),
'$mlisting'(Stream, I, M).
listing(_Stream, []) :- !.
listing(Stream, [MV|MVs]) :- !,
listing(Stream, MV),
listing(Stream, MVs).
'$mlisting'(Stream, MV, M) :-
( var(MV) ->
MV = NA,
'$do_listing'(Stream, M, NA)
;
atom(MV) ->
MV/_ = NA,
'$do_listing'(Stream, M, NA)
;
MV = N//Ar -> ( integer(Ar) -> Ar2 is Ar+2, NA is N/Ar2 ; '$do_listing'(Stream, NA/Ar2, M), Ar2 >= 2, Ar is Ar2-2 )
;
MV = N/Ar, ( atom(N) -> true ; var(N) ), ( integer(Ar) -> true ; var(Ar) ) ->
'$do_listing'(Stream, M, MV)
;
MV = M1:PP -> '$mlisting'(Stream, PP, M1)
;
'$do_error'(type_error(predicate_indicator,MV),listing(Stream, MV) )
).
'$do_listing'(Stream, M, Name/Arity) :-
( current_predicate(Name, M:Pred),
functor( Pred, Name, Arity),
\+ '$undefined'(Pred, M),
'$listing'(Name,Arity,M,Stream),
fail
;
true
).
%
% at this point we are ground and we know who we want to list.
%
'$listing'(Name, Arity, M, Stream) :-
% skip by default predicates starting with $
functor(Pred,Name,Arity),
'$list_clauses'(Stream,M,Pred).
'$listing'(_,_,_,_).
'$funcspec'(Name/Arity,Name,Arity) :- !, atom(Name).
'$funcspec'(Name,Name,_) :- atom(Name), !.
'$funcspec'(Name,_,_) :-
'$do_error'(domain_error(predicate_spec,Name),listing(Name)).
'$list_clauses'(Stream, M, Pred) :-
'$predicate_flags'(Pred,M,Flags,Flags),
(Flags /\ 0x48602000 =\= 0
->
nl(Stream),
fail
;
!
).
'$list_clauses'(Stream, M, Pred) :-
( '$is_dynamic'(Pred, M) -> true ; '$is_log_updatable'(Pred, M) ),
functor( Pred, N, Ar ),
'$current_module'(Mod),
(
M == Mod
->
format( Stream, ':- dynamic ~q/~d.~n', [N,Ar])
;
format( Stream, ':- dynamic ~q:~q/~d.~n', [M,N,Ar])
),
fail.
'$list_clauses'(Stream, M, Pred) :-
'$is_thread_local'(Pred, M),
functor( Pred, N, Ar ),
'$current_module'(Mod),
(
M == Mod
->
format( Stream, ':- thread_local ~q/~d.~n', [N,Ar])
;
format( Stream, ':- thread_local ~q:~q/~d.~n', [M,N,Ar])
),
fail.
'$list_clauses'(Stream, M, Pred) :-
'$is_multifile'(Pred, M),
functor( Pred, N, Ar ),
'$current_module'(Mod),
(
M == Mod
->
format( Stream, ':- multifile ~q/~d.~n', [N,Ar])
;
format( Stream, ':- multifile ~q:~q/~d.~n', [M,N,Ar])
),
fail.
'$list_clauses'(Stream, M, Pred) :-
'$is_metapredicate'(Pred, M),
functor( Pred, Name, Arity ),
prolog:'$meta_predicate'(Name,M,Arity,PredDef),
'$current_module'(Mod),
(
M == Mod
->
format( Stream, ':- ~q.~n', [PredDef])
;
format( Stream, ':- ~q:~q.~n', [M,PredDef])
),
fail.
'$list_clauses'(Stream, _M, _Pred) :-
nl( Stream ),
fail.
'$list_clauses'(Stream, M, Pred) :-
'$predicate_flags'(Pred,M,Flags,Flags),
% has to be dynamic, source, or log update.
Flags /\ 0x08402000 =\= 0,
'$clause'(Pred, M, Body, _),
'$current_module'(Mod),
( M \= Mod -> H = M:Pred ; H = Pred ),
'$portray_clause'(Stream,(H:-Body)),
fail.
/** @pred portray_clause(+ _S_,+ _C_)
Write clause _C_ on stream _S_ as if written by listing/0.
*/
portray_clause(Stream, Clause) :-
copy_term_nat(Clause, CopiedClause),
'$portray_clause'(Stream, CopiedClause),
fail.
portray_clause(_, _).
/** @pred portray_clause(+ _C_)
Write clause _C_ as if written by listing/0.
*/
portray_clause(Clause) :-
current_output(Stream),
portray_clause(Stream, Clause).
'$portray_clause'(Stream, (Pred :- true)) :- !,
'$beautify_vars'(Pred),
format(Stream, '~q.~n', [Pred]).
'$portray_clause'(Stream, (Pred:-Body)) :- !,
'$beautify_vars'((Pred:-Body)),
format(Stream, '~q :-', [Pred]),
'$write_body'(Body, 3, ',', Stream),
format(Stream, '.~n', []).
'$portray_clause'(Stream, Pred) :-
'$beautify_vars'(Pred),
format(Stream, '~q.~n', [Pred]).
'$write_body'(X,I,T,Stream) :- var(X), !,
'$beforelit'(T,I,Stream),
writeq(Stream, '_').
'$write_body'((P,Q), I, T, Stream) :-
!,
'$write_body'(P,I,T, Stream),
put(Stream, 0',),
'$write_body'(Q,I,',',Stream).
'$write_body'((P->Q;S),I,_, Stream) :-
!,
format(Stream, '~n~*c(',[I,0' ]),
I1 is I+2,
'$write_body'(P,I1,'(',Stream),
format(Stream, '~n~*c->',[I,0' ]),
'$write_disj'((Q;S),I,I1,'->',Stream),
format(Stream, '~n~*c)',[I,0' ]).
'$write_body'((P->Q|S),I,_,Stream) :-
!,
format(Stream, '~n~*c(',[I,0' ]),
I1 is I+2,
'$write_body'(P,I,'(',Stream),
format(Stream, '~n~*c->',[I,0' ]),
'$write_disj'((Q|S),I,I1,'->',Stream),
format(Stream, '~n~*c)',[I,0' ]).
'$write_body'((P->Q),I,_,Stream) :-
!,
format(Stream, '~n~*c(',[I,0' ]),
I1 is I+2,
'$write_body'(P,I1,'(',Stream),
format(Stream, '~n~*c->',[I,0' ]),
'$write_body'(Q,I1,'->',Stream),
format(Stream, '~n~*c)',[I,0' ]).
'$write_body'((P;Q),I,_,Stream) :-
!,
format(Stream, '~n~*c(',[I,0' ]),
I1 is I+2,
'$write_disj'((P;Q),I,I1,'->',Stream),
format(Stream, '~n~*c)',[I,0' ]).
'$write_body'((P|Q),I,_,Stream) :-
!,
format(Stream, '~n~*c(',[I,0' ]),
I1 is I+2,
'$write_disj'((P|Q),I,I1,'->',Stream),
format(Stream, '~n~*c)',[I,0' ]).
'$write_body'(X,I,T,Stream) :-
'$beforelit'(T,I,Stream),
writeq(Stream,X).
'$write_disj'((Q;S),I0,I,C,Stream) :- !,
'$write_body'(Q,I,C,Stream),
format(Stream, '~n~*c;',[I0,0' ]),
'$write_disj'(S,I0,I,';',Stream).
'$write_disj'((Q|S),I0,I,C,Stream) :- !,
'$write_body'(Q,I,C,Stream),
format(Stream, '~n~*c|',[I0,0' ]),
'$write_disj'(S,I0,I,'|',Stream).
'$write_disj'(S,_,I,C,Stream) :-
'$write_body'(S,I,C,Stream).
'$beforelit'('(',_,Stream) :-
!,
format(Stream,' ',[]).
'$beforelit'(_,I,Stream) :- format(Stream,'~n~*c',[I,0' ]).
'$beautify_vars'(T) :-
'$list_get_vars'(T,[],L),
msort(L,SL),
'$list_transform'(SL,0).
'$list_get_vars'(V,L,[V|L] ) :- var(V), !.
'$list_get_vars'(Atomic, M, M) :-
primitive(Atomic), !.
'$list_get_vars'([Arg|Args], M, N) :- !,
'$list_get_vars'(Arg, M, K),
'$list_get_vars'(Args, K, N).
'$list_get_vars'(Term, M, N) :-
Term =.. [_|Args],
'$list_get_vars'(Args, M, N).
'$list_transform'([],_) :- !.
'$list_transform'([X,Y|L],M) :-
X == Y,
X = '$VAR'(M),
!,
N is M+1,
'$list_transform'(L,N).
'$list_transform'(['$VAR'(-1)|L],M) :- !,
'$list_transform'(L,M).
'$list_transform'([_|L],M) :-
'$list_transform'(L,M).

View File

@@ -1,244 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: load_foreign.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: Utility predicates for load_foreign *
* *
*************************************************************************/
:- system_module( '$_load_foreign', [load_foreign_files/3,
open_shared_object/2,
open_shared_object/3], ['$import_foreign'/3]).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_modules', ['$do_import'/3]).
/**
@defgroup LoadForeign Access to Foreign Language Programs
@ingroup fli_c_cx
@{
*/
/** @pred load_foreign_files( _Files_, _Libs_, _InitRoutine_)
should be used, from inside YAP, to load object files produced by the C
compiler. The argument _ObjectFiles_ should be a list of atoms
specifying the object files to load, _Libs_ is a list (possibly
empty) of libraries to be passed to the unix loader (`ld`) and
InitRoutine is the name of the C routine (to be called after the files
are loaded) to perform the necessary declarations to YAP of the
predicates defined in the files.
YAP will search for _ObjectFiles_ in the current directory first. If
it cannot find them it will search for the files using the environment
variable:
+ YAPLIBDIR
if defined, or in the default library.
YAP supports the SWI-Prolog interface to loading foreign code, the shlib package.
*/
load_foreign_files(Objs,Libs,Entry) :-
source_module(M),
'$check_objs_for_load_foreign_files'(Objs,NewObjs,load_foreign_files(Objs,Libs,Entry)),
'$check_libs_for_load_foreign_files'(Libs,NewLibs,load_foreign_files(Objs,Libs,Entry)),
'$check_entry_for_load_foreign_files'(Entry,load_foreign_files(Objs,Libs,Entry)),
(
recordzifnot( '$foreign', M:'$foreign'(Objs,Libs,Entry), _)
->
'$load_foreign_files'(NewObjs,NewLibs,Entry),
(
prolog_load_context(file, F)
->
ignore( recordzifnot( '$load_foreign_done', [F, M], _) )
;
true
)
;
true
),
!.
/** @pred load_absolute_foreign_files( _Files_, _Libs_, _InitRoutine_)
Loads object files produced by the C compiler. It is useful when no search should be performed and instead one has the full paths to the _Files_ and _Libs_.
*/
load_absolute_foreign_files(Objs,Libs,Entry) :-
source_module(M),
(
recordzifnot( '$foreign', M:'$foreign'(Objs,Libs,Entry), _)
->
'$load_foreign_files'(Objs,Libs,Entry),
(
prolog_load_context(file, F)
->
ignore( recordzifnot( '$load_foreign_done', [F, M], _) )
;
true
)
;
true
),
!.
'$check_objs_for_load_foreign_files'(V,_,G) :- var(V), !,
'$do_error'(instantiation_error,G).
'$check_objs_for_load_foreign_files'([],[],_) :- !.
'$check_objs_for_load_foreign_files'([Obj|Objs],[NObj|NewObjs],G) :- !,
'$check_obj_for_load_foreign_files'(Obj,NObj,G),
'$check_objs_for_load_foreign_files'(Objs,NewObjs,G).
'$check_objs_for_load_foreign_files'(Objs,_,G) :-
'$do_error'(type_error(list,Objs),G).
'$check_obj_for_load_foreign_files'(V,_,G) :- var(V), !,
'$do_error'(instantiation_error,G).
'$check_obj_for_load_foreign_files'(Obj,NewObj,_) :- atom(Obj), !,
( atom(Obj), Obj1 = foreign(Obj) ; Obj1 = Obj ),
absolute_file_name(foreign(Obj),[file_type(executable),
access(read),
expand(true),
file_errors(fail)
], NewObj).
'$check_obj_for_load_foreign_files'(Obj,_,G) :-
'$do_error'(type_error(atom,Obj),G).
'$check_libs_for_load_foreign_files'(V,_,G) :- var(V), !,
'$do_error'(instantiation_error,G).
'$check_libs_for_load_foreign_files'([],[],_) :- !.
'$check_libs_for_load_foreign_files'([Lib|Libs],[NLib|NLibs],G) :- !,
'$check_lib_for_load_foreign_files'(Lib,NLib,G),
'$check_libs_for_load_foreign_files'(Libs,NLibs,G).
'$check_libs_for_load_foreign_files'(Libs,_,G) :-
'$do_error'(type_error(list,Libs),G).
'$check_lib_for_load_foreign_files'(V,_,G) :- var(V), !,
'$do_error'(instantiation_error,G).
'$check_lib_for_load_foreign_files'(Lib,NLib,_) :- atom(Lib), !,
'$process_obj_suffix'(Lib,NewLib),
'$checklib_prefix'(NewLib,NLib).
'$check_lib_for_load_foreign_files'(Lib,_,G) :-
'$do_error'(type_error(atom,Lib),G).
'$process_obj_suffix'(Obj,Obj) :-
current_prolog_flag(shared_object_extension, ObjSuffix),
sub_atom(Obj, _, _, 0, ObjSuffix), !.
'$process_obj_suffix'(Obj,NewObj) :-
current_prolog_flag(shared_object_extension, ObjSuffix),
atom_concat([Obj,'.',ObjSuffix],NewObj).
'$checklib_prefix'(F,F) :- is_absolute_file_name(F), !.
'$checklib_prefix'(F, F) :-
sub_atom(F, 0, _, _, lib), !.
'$checklib_prefix'(F, Lib) :-
atom_concat(lib, F, Lib).
'$import_foreign'(F, M0, M) :-
M \= M0,
predicate_property(M0:P,built_in),
predicate_property(M0:P,file(F)),
functor(P, N, K),
'$do_import'(N/K-N/K, M0, M),
fail.
'$import_foreign'(_F, _M0, _M).
'$check_entry_for_load_foreign_files'(V,G) :- var(V), !,
'$do_error'(instantiation_error,G).
'$check_entry_for_load_foreign_files'(Entry,_) :- atom(Entry), !.
'$check_entry_for_load_foreign_files'(Entry,G) :-
'$do_error'(type_error(atom,Entry),G).
/** @pred open_shared_object(+ _File_, - _Handle_)
File is the name of a shared object file (called dynamic load
library in MS-Windows). This file is attached to the current process
and _Handle_ is unified with a handle to the library. Equivalent to
`open_shared_object(File, [], Handle)`. See also
load_foreign_library/1 and `load_foreign_library/2`.
On errors, an exception `shared_object`( _Action_,
_Message_) is raised. _Message_ is the return value from
dlerror().
*/
open_shared_object(File, Handle) :-
open_shared_object(File, [], Handle).
/** @pred open_shared_object(+ _File_, - _Handle_, + _Options_)
As `open_shared_object/2`, but allows for additional flags to
be passed. _Options_ is a list of atoms. `now` implies the
symbols are
resolved immediately rather than lazily (default). `global` implies
symbols of the loaded object are visible while loading other shared
objects (by default they are local). Note that these flags may not
be supported by your operating system. Check the documentation of
`dlopen()` or equivalent on your operating system. Unsupported
flags are silently ignored.
*/
open_shared_object(File, Opts, Handle) :-
'$open_shared_opts'(Opts, open_shared_object(File, Opts, Handle), OptsI),
'$open_shared_object'(File, OptsI, Handle),
prolog_load_context(module, M),
ignore( recordzifnot( '$foreign', M:'$swi_foreign'(File,Opts, Handle), _) ).
'$open_shared_opts'(Opts, G, _OptsI) :-
var(Opts), !,
'$do_error'(instantiation_error,G).
'$open_shared_opts'([], _, 0) :- !.
'$open_shared_opts'([Opt|Opts], G, V) :-
'$open_shared_opts'(Opts, G, V0),
'$open_shared_opt'(Opt, G, OptV),
V0 is V \/ OptV.
'$open_shared_opt'(Opt, G, _) :-
var(Opt), !,
'$do_error'(instantiation_error,G).
'$open_shared_opt'(now, __, 1) :- !.
'$open_shared_opt'(global, __, 2) :- !.
'$open_shared_opt'(Opt, Goal, _) :-
'$do_error'(domain_error(open_shared_object_option,Opt),Goal).
/** @pred call_shared_object_function(+ _Handle_, + _Function_)
Call the named function in the loaded shared library. The function is
called without arguments and the return-value is ignored. YAP supports
installing foreign language predicates using calls to 'UserCCall()`,
`PL_register_foreign()`, and friends.
*/
call_shared_object_function( Handle, Function) :-
'$call_shared_object_function'( Handle, Function),
prolog_load_context(module, M),
ignore( recordzifnot( '$foreign', M:'$swi_foreign'( Handle, Function ), _) ).
%% @}
/** @pred $slave is det
Called at boot-time when Prolog is run from another language (eg, Java, Python, Android)
*/
'$slave' :-
getenv( '__PYVENV_LAUNCHER__', _ ),
use_module( library(python) ).

View File

@@ -1,987 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: utilities for displaying messages in YAP. *
* comments: error messages for YAP *
* *
* Last rev: $Date: 2008-07-16 10:58:59 $,$Author: vsc $ *
* *
* *
*************************************************************************/
/**
* @file messages.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Thu Nov 19 10:22:26 2015
*
* @brief The YAP Message Handler
*
*
*/
/**
@defgroup Messages Message Handling
@ingroup YAPControl
The interaction between YAP and the user relies on YAP's ability to
portray messages. These messages range from prompts to error
information. All message processing is performed through the builtin
print_message/2, in two steps:
+ The message is processed into a list of commands
+ The commands in the list are sent to the `format/3` builtin
in sequence.
The first argument to print_message/2 specifies the importance of
the message. The options are:
+ `error`
error handling
+ `warning`
compilation and run-time warnings,
+ `informational`
generic informational messages
+ `help`
help messages (not currently implemented in YAP)
+ `query`
query used in query processing (not currently implemented in YAP)
+ `silent`,M,Na,Ar,File, FilePos]],
[nl, nl].
caller( error(_,Term), _) -->
{ lists:memberchk([g|g(Call)], Term) },
['~*|called from
messages that do not produce output but that can be intercepted by hooks.
The next table shows the main predicates and hooks associated to message
handling in YAP:
An error record comsists of An ISO compatible descriptor of the format
error(errror_kind(Culprit,..), Info)
In YAP, the infoo field describes:
- what() more detauls on the event
- input_stream, may be ine of;
- loop_sream
- file()
- none
- prolog_source(_) a record containing file, line, predicate, and clause
that activated the goal, or a list therof. YAP tries to search for the user
code generatinng the error.
- c_source(0), a record containing the line of C-code thhat caused the event. This
is reported under systm debugging mode, or if this is user code.
- stream_source() - a record containg data on the the I/O stream datum causisng the evwnt.
- user_message () - ttext on the event.
@{
*/
:- module(system('$messages'),
[system_message/4,
prefix/6,
prefix/5,
file_location/3]).
:- use_system_module( user, [message_hook/3]).
:- multifile prolog:message/3.
:- multifile user:message_hook/3.
/** @pred message_to_string(+ _Term_, - _String_)
Translates a message-term into a string object. Primarily intended for SWI-Prolog emulation.
*/
prolog:message_to_string(Event, Message) :-
translate_message(Event, warning, Message, []).
%% @pred compose_message(+Term, +Level, +Lines, -Lines0) is det
%
% Print the message if the user did not intercept the message.
% The first is used for errors and warnings that can be related
% to source-location. Note that syntax errors have their own
% source-location and should therefore not be handled this way.
compose_message( Term, Level ) -->
[' ~w:'- [Level]
],
prolog:message(Term), !.
compose_message( query(_QueryResult,_), _Level) -->
[].
compose_message( absolute_file_path(File), _Level) -->
[ '~N~n absolute_file of ~w' - [File] ].
compose_message( absolute_file_path(Msg, Args), _Level) -->
[ ' : ' - [],
Msg - Args,
nl ].
compose_message( arguments([]), _Level) -->
[].
compose_message( arguments([A|As]), Level) -->
[ ' ~w' - [A],
nl ],
compose_message( arguments(As), Level).
compose_message( ancestors([]), _Level) -->
[ 'There are no ancestors.' ].
compose_message( breakp(bp(debugger,_,_,M:F/N,_),add,already), _Level) -->
[ 'There is already a spy point on ~w:~w/~w.' - [M,F,N] ].
compose_message( breakp(bp(debugger,_,_,M:F/N,_),add,ok), _Level) -->
[ 'Spy point set on ~w:~w/~w.' - [M,F,N] ].
compose_message( breakp(bp(debugger,_,_,M:F/N,_),remove,last), _Level) -->
[ 'Spy point on ~w:~w/~w removed.' - [M,F,N] ].
compose_message( breakp(no,breakpoint_for,M:F/N), _Level) -->
[ 'There is no spy point on ~w:~w/~w.' - [M,F,N] ].
compose_message( breakpoints([]), _Level) -->
[ 'There are no spy-points set.' ].
compose_message( breakpoints(L), _Level) -->
[ 'Spy-points set on:' ],
list_of_preds(L).
compose_message( clauses_not_together(P), _Level) -->
[ 'Discontiguous definition of ~q.' - [P] ].
compose_message( debug(debug), _Level) -->
[ 'Debug mode on.' - [] ].
compose_message( debug(off), _Level) -->
[ 'Debug mode off.'- [] ].
compose_message( debug(trace), _Level) -->
[ 'Trace mode on.'- [] ].
compose_message( declaration(Args,Action), _Level) -->
[ 'declaration ~w ~w.' - [Args,Action] ].
compose_message( defined_elsewhere(P,F), _Level) -->
[ 'predicate ~q previously defined in file ~w' - [P,F] ].
compose_message( functionality(Library), _Level) -->
[ '~q not available' - [Library] ].
compose_message( import(Pred,To,From,private), _Level) -->
[ 'Importing private predicate ~w:~w to ~w.' - [From,Pred,To] ].
compose_message( redefine_imported(M,M0,PI), _Level) -->
{ source_location(ParentF, Line) },
[ '~w:~w: Module ~w redefines imported predicate ~w:~w.' - [ParentF, Line, M,M0,PI] ].
compose_message( leash([]), _Level) -->
[ 'No leashing.' ].
compose_message( leash([A|B]), _Level) -->
[ 'Leashing set to ~w.' - [[A|B]] ].
compose_message( no, _Level) -->
[ 'no' - [] ].
compose_message( no_match(P), _Level) -->
[ 'No matching predicate for ~w.' - [P] ].
compose_message( leash([A|B]), _Level) -->
[ 'Leashing set to ~w.' - [[A|B]] ].
compose_message( halt, _Level) --> !,
[ 'YAP execution halted.'-[] ].
compose_message( false, _Level) --> !,
[ 'false.'-[] ].
compose_message( '$abort', _Level) --> !,
[ 'YAP execution aborted'-[] ].
compose_message( abort(user), _Level) --> !,
[ 'YAP execution aborted' - [] ].
compose_message( loading(_,F), _Level) --> { F == user }, !.
compose_message( loading(What,FileName), _Level) --> !,
[ '~a ~w...' - [What, FileName] ].
compose_message( loaded(_,user,_,_,_), _Level) --> !.
compose_message( loaded(included,AbsFileName,Mod,Time,Space), _Level) --> !,
[ '~a included in module ~a, ~d msec ~d bytes' -
[AbsFileName,Mod,Time,Space] ].
compose_message( loaded(What,AbsoluteFileName,Mod,Time,Space), _Level) --> !,
[ '~a ~a in module ~a, ~d msec ~d bytes' -
[What, AbsoluteFileName,Mod,Time,Space] ].
compose_message(trace_command(-1), _Leve) -->
[ 'EOF is not a valid debugger command.' ].
compose_message(trace_command(C), _Leve) -->
[ '~c is not a valid debugger command.' - [C] ].
compose_message(trace_help, _Leve) -->
[ ' Please enter a valid debugger command (h for help).' ].
compose_message(version(Version), _Leve) -->
[ '~a' - [Version] ].
compose_message(myddas_version(Version), _Leve) -->
[ 'MYDDAS version ~a' - [Version] ].
compose_message(yes, _Level) --> !,
[ 'yes'- [] ].
compose_message(Term, Level) -->
{ '$show_consult_level'(LC) },
location(Term, Level, LC),
main_message( Term, Level, LC ),
c_goal( Term, Level ),
caller( Term, Level ),
extra_info( Term, Level ),
!,
[nl,nl].
compose_message(Term, Level) -->
{ Level == error -> true ; Level == warning },
{ '$show_consult_level'(LC) },
main_message( Term, Level, LC),
[nl,nl].
location(error(syntax_error(_),info(between(_,LN,_), FileName, _)), _ , _) -->
!,
[ '~a:~d:~d ' - [FileName,LN,0] ] .
location(error(style_check(style_check(_,LN,FileName,_ ) ),_), _ , _) -->
!,
[ '~a:~d:0 ' - [FileName,LN] ] .
location( error(_,Term), Level, LC ) -->
{ source_location(F0, L),
stream_property(_Stream, alias(loop_stream)) }, !,
display_consulting( F0, Level, LC ),
{ lists:memberchk([p|p(M,Na,Ar,_File,_FilePos)], Term ) },
[ '~a:~d:0 ~a in ~a:~q/~d:'-[F0, L,Level,M,Na,Ar] ].
location( error(_,Term), Level, LC ) -->
{ lists:memberchk([p|p(M,Na,Ar,File,FilePos)], Term ) }, !,
display_consulting( File, Level, LC ),
[ '~a:~d:0 ~a in ~a:~q/~d:'-[File, FilePos,Level,M,Na,Ar] ].
%message(loaded(Past,AbsoluteFileName,user,Msec,Bytes), Prefix, Suffix) :- !,
main_message(error(Msg,Info), _, _) --> {var(Info)}, !,
[ ' error: uninstantiated message ~w~n.' - [Msg], nl ].
main_message( error(syntax_error(Msg),info(between(L0,LM,LF),_Stream,Term)), Level, LC ) -->
!,
[' ~a: syntax error ~s' - [Level,Msg]],
[nl],
( syntax_error_term( between(L0,LM,LF), Term, LC )
->
[]
;
[' ~a: failed_processing syntax error term ~q' - [Level,Term]],
[nl]
).
main_message(error(style_check(style_check(singleton(SVs),_Pos,_File,P)),_), Level, _LC) -->
!,
% {writeln(ci)},
{ clause_to_indicator(P, I) },
[ ' ~a: singleton variable~*c ~s in ~q.' - [ Level, NVs, 0's, SVsL, I] ],
{ svs(SVs,SVs,SVsL),
( SVs = [_] -> NVs = 0 ; NVs = 1 )
}.
main_message(error(style_check(style_check(multiple(N,A,Mod,I0),_Pos,File,_P)),_), Level, _LC) -->
!,
[ ' ~a: ~a redefines ~q from ~a.' - [Level,File, Mod:N/A, I0] ].
main_message(error(style_check(style_check(discontiguous(N,A,Mod),_S,_W,_P)),_) , Level, _LC)-->
!,
[ ' ~a: discontiguous definition for ~p.' - [Level,Mod:N/A] ].
main_message(error(consistency_error(Who)), Level, _LC) -->
!,
[ ' ~a: has argument ~a not consistent with type.'-[Level,Who] ].
main_message(error(domain_error(Who , Type), _Where), Level, _LC) -->
!,
[ ' ~a: ~q does not belong to domain ~a,' - [Level,Type,Who], nl ].
main_message(error(evaluation_error(What), _Where), Level, _LC) -->
!,
[ ' ~a: ~w during evaluation of arithmetic expressions,' - [Level,What], nl ].
main_message(error(evaluation_error(What, Who), _Where), Level, _LC) -->
!,
[ ' ~a: ~w caused ~a during evaluation of arithmetic expressions,' - [Level,Who,What], nl ].
main_message(error(existence_error(Type , Who), _Where), Level, _LC) -->
!,
[ ' ~a: ~q ~q could not be found,' - [Level,Type, Who], nl ].
main_message(error(permission_error(Op, Type, Id), _Where), Level, _LC) -->
[ ' ~a: ~q is not allowed in ~a ~q,' - [Level, Op, Type,Id], nl ].
main_message(error(instantiation_error, _Where), Level, _LC) -->
[ ' ~a: unbound variable' - [Level], nl ].
main_message(error(representation_error(Type)), Level, _LC) -->
[ ' ~a: ~a representation error ~a' - [Level, Type], nl ].
main_message(error(type_error(Type,Who), _What), Level, _LC) -->
[ ' ~a: ~q should be of type ~a' - [Level,Who,Type]],
[ nl ].
main_message(error(system_error(Who), _What), Level, _LC) -->
[ ' ~a: ~q error' - [Level,Who]],
[ nl ].
main_message(error(uninstantiation_error(T),_), Level, _LC) -->
[ ' ~a: found ~q, expected unbound variable ' - [Level,T], nl ].
display_consulting( F, Level, LC) -->
{ LC > 0,
source_location(F0, L),
F \= F0
}, !,
[ '~a:~d:0: ~a while compiling.'-[F0,L,Level], nl ].
display_consulting(_F, _, _LC) -->
[].
caller( error(_,Term), _) -->
{ lists:memberchk([p|p(M,Na,Ar,File,FilePos)], Term ) },
{ lists:memberchk([g|g(Call)], Term) },
!,
['~*|goal was ~q' - [10,Call]],
[nl],
['~*|exception raised from ~a:~q:~d, ~a:~d:0: '-[10,M,Na,Ar,File, FilePos]],
[nl].
caller( error(_,Term), _) -->
{ lists:memberchk([e|p(M,Na,Ar,File,FilePos)], Term ) },
!,
['~*|exception raised from ~a:~q/~d, ~a:~d:0: '-[10,M,Na,Ar,File, FilePos]],
[nl].
caller( error(_,Term), _) -->
{ lists:memberchk([g|g(Call)], Term) },
!,
['~*|goal ~q '-[10,Call]],
[nl].
caller( _, _) -->
[].
c_goal( error(_,Term), Level ) -->
{ lists:memberchk([c|c(File, Line, Func)], Term ) },
!,
['~*|~a raised at C-function ~a() in ~a:~d:0: '-[10, Level, Func, File, Line]],
[nl].
c_goal( _, _Level ) --> [].
prolog_message(X) -->
system_message(X).
system_message(error(Msg,Info)) -->
( { var(Msg) } ; { var(Info)} ), !,
['bad error ~w' - [error(Msg,Info)]].
system_message(error(consistency_error(Who),Where)) -->
[ 'CONSISTENCY ERROR (arguments not compatible with format)- ~w ~w' - [Who,Where] ].
system_message(error(context_error(Goal,Who),Where)) -->
[ 'CONTEXT ERROR- ~w: ~w appeared in ~w' - [Goal,Who,Where] ].
system_message(error(domain_error(DomainType,Opt), Where)) -->
[ 'DOMAIN ERROR- ~w: ' - Where],
domain_error(DomainType, Opt).
system_message(error(format_argument_type(Type,Arg), Where)) -->
[ 'FORMAT ARGUMENT ERROR- ~~~a called with ~w in ~w: ' - [Type,Arg,Where]].
system_message(error(existence_error(directory,Key), Where)) -->
[ 'EXISTENCE ERROR- ~w: ~w not an existing directory' - [Where,Key] ].
system_message(error(existence_error(key,Key), Where)) -->
[ 'EXISTENCE ERROR- ~w: ~w not an existing key' - [Where,Key] ].
system_message(error(existence_error(mutex,Key), Where)) -->
[ 'EXISTENCE ERROR- ~w: ~w is an erased mutex' - [Where,Key] ].
system_message(existence_error(prolog_flag,F)) -->
[ 'Prolog Flag ~w: new Prolog flags must be created using create_prolog_flag/3.' - [F] ].
system_message(error(existence_error(prolog_flag,P), Where)) --> !,
[ 'EXISTENCE ERROR- ~w: prolog flag ~w is undefined' - [Where,P] ].
system_message(error(existence_error(procedure,P), context(Call,Parent))) --> !,
[ 'EXISTENCE ERROR- procedure ~w is undefined, called from context ~w~n Goal was ~w' - [P,Parent,Call] ].
system_message(error(existence_error(stream,Stream), Where)) -->
[ 'EXISTENCE ERROR- ~w: ~w not an open stream' - [Where,Stream] ].
system_message(error(existence_error(thread,Thread), Where)) -->
[ 'EXISTENCE ERROR- ~w: ~w not a running thread' - [Where,Thread] ].
system_message(error(existence_error(variable,Var), Where)) -->
[ 'EXISTENCE ERROR- ~w: variable ~w does not exist' - [Where,Var] ].
system_message(error(existence_error(Name,F), W)) -->
{ object_name(Name, ObjName) },
[ 'EXISTENCE ERROR- ~w could not open ~a ~w' - [W,ObjName,F] ].
system_message(error(evaluation_error(int_overflow), Where)) -->
[ 'INTEGER OVERFLOW ERROR- ~w' - [Where] ].
system_message(error(evaluation_error(float_overflow), Where)) -->
[ 'FLOATING POINT OVERFLOW ERROR- ~w' - [Where] ].
system_message(error(evaluation_error(undefined), Where)) -->
[ 'UNDEFINED ARITHMETIC RESULT ERROR- ~w' - [Where] ].
system_message(error(evaluation_error(underflow), Where)) -->
[ 'UNDERFLOW ERROR- ~w' - [Where] ].
system_message(error(evaluation_error(float_underflow), Where)) -->
[ 'FLOATING POINT UNDERFLOW ERROR- ~w' - [Where] ].
system_message(error(evaluation_error(zero_divisor), Where)) -->
[ 'ZERO DIVISOR ERROR- ~w' - [Where] ].
system_message(error(not_implemented(Type, What), Where)) -->
[ '~w: ~w not implemented- ~w' - [Where, Type, What] ].
system_message(error(operating_SYSTEM_ERROR_INTERNAL, Where)) -->
[ 'OPERATING SYSTEM ERROR- ~w' - [Where] ].
system_message(error(out_of_heap_error, Where)) -->
[ 'OUT OF DATABASE SPACE ERROR- ~w' - [Where] ].
system_message(error(out_of_stack_error, Where)) -->
[ 'OUT OF STACK SPACE ERROR- ~w' - [Where] ].
system_message(error(out_of_trail_error, Where)) -->
[ 'OUT OF TRAIL SPACE ERROR- ~w' - [Where] ].
system_message(error(out_of_attvars_error, Where)) -->
[ 'OUT OF STACK SPACE ERROR- ~w' - [Where] ].
system_message(error(out_of_auxspace_error, Where)) -->
[ 'OUT OF AUXILIARY STACK SPACE ERROR- ~w' - [Where] ].
system_message(error(permission_error(access,private_procedure,P), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot see clauses for ~w' - [Where,P] ].
system_message(error(permission_error(access,static_procedure,P), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot access static procedure ~w' - [Where,P] ].
system_message(error(permission_error(alias,new,P), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot create alias ~w' - [Where,P] ].
system_message(error(permission_error(create,Name,P), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot create ~a ~w' - [Where,Name,P] ].
system_message(error(permission_error(import,M1:I,redefined,SecondMod), Where)) -->
[ 'PERMISSION ERROR- loading ~w: modules ~w and ~w both define ~w' - [Where,M1,SecondMod,I] ].
system_message(error(permission_error(input,binary_stream,Stream), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot read from binary stream ~w' - [Where,Stream] ].
system_message(error(permission_error(input,closed_stream,Stream), Where)) -->
[ 'PERMISSION ERROR- ~w: trying to read from closed stream ~w' - [Where,Stream] ].
system_message(error(permission_error(input,past_end_of_stream,Stream), Where)) -->
[ 'PERMISSION ERROR- ~w: past end of stream ~w' - [Where,Stream] ].
system_message(error(permission_error(input,stream,Stream), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot read from ~w' - [Where,Stream] ].
system_message(error(permission_error(input,text_stream,Stream), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot read from text stream ~w' - [Where,Stream] ].
system_message(error(permission_error(modify,dynamic_procedure,_), Where)) -->
[ 'PERMISSION ERROR- ~w: modifying a dynamic procedure' - [Where] ].
system_message(error(permission_error(modify,flag,W), _)) -->
[ 'PERMISSION ERROR- cannot modify flag ~w' - [W] ].
system_message(error(permission_error(modify,operator,W), Q)) -->
[ 'PERMISSION ERROR- ~w: cannot modify operator ~q' - [Q,W] ].
system_message(error(permission_error(modify,dynamic_procedure,F), Where)) -->
[ 'PERMISSION ERROR- ~w: modifying dynamic procedure ~w' - [Where,F] ].
system_message(error(permission_error(modify,static_procedure,F), Where)) -->
[ 'PERMISSION ERROR- ~w: modifying static procedure ~w' - [Where,F] ].
system_message(error(permission_error(modify,static_procedure_in_use,_), Where)) -->
[ 'PERMISSION ERROR- ~w: modifying a static procedure in use' - [Where] ].
system_message(error(permission_error(modify,table,P), _)) -->
[ 'PERMISSION ERROR- cannot table procedure ~w' - [P] ].
system_message(error(permission_error(module,redefined,Mod), Who)) -->
[ 'PERMISSION ERROR ~w- redefining module ~a in a different file' - [Who,Mod] ].
system_message(error(permission_error(open,source_sink,Stream), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot open file ~w' - [Where,Stream] ].
system_message(error(permission_error(output,binary_stream,Stream), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot
write to binary stream ~w' - [Where,Stream] ].
system_message(error(permission_error(output,stream,Stream), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot write to ~w' - [Where,Stream] ].
system_message(error(permission_error(output,text_stream,Stream), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot write to text stream ~w' - [Where,Stream] ].
system_message(error(permission_error(resize,array,P), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot resize array ~w' - [Where,P] ].
system_message(error(permission_error(unlock,mutex,P), Where)) -->
[ 'PERMISSION ERROR- ~w: cannot unlock mutex ~w' - [Where,P] ].
system_message(error(representation_error(character), Where)) -->
[ 'REPRESENTATION ERROR- ~w: expected character' - [Where] ].
system_message(error(representation_error(character_code), Where)) -->
[ 'REPRESENTATION ERROR- ~w: expected character code' - [Where] ].
system_message(error(representation_error(max_arity), Where)) -->
[ 'REPRESENTATION ERROR- ~w: number too big' - [Where] ].
system_message(error(representation_error(variable), Where)) -->
[ 'REPRESENTATION ERROR- ~w: should be a variable' - [Where] ].
system_message(error(resource_error(code_space), Where)) -->
[ 'RESOURCE ERROR- not enough code space' - [Where] ].
system_message(error(resource_error(huge_int), Where)) -->
[ 'RESOURCE ERROR- too large an integer in absolute value' - [Where] ].
system_message(error(resource_error(memory), Where)) -->
[ 'RESOURCE ERROR- not enough virtual memory' - [Where] ].
system_message(error(resource_error(stack), Where)) -->
[ 'RESOURCE ERROR- not enough stack' - [Where] ].
system_message(error(resource_error(streams), Where)) -->
[ 'RESOURCE ERROR- could not find a free stream' - [Where] ].
system_message(error(resource_error(threads), Where)) -->
[ 'RESOURCE ERROR- too many open threads' - [Where] ].
system_message(error(resource_error(trail), Where)) -->
[ 'RESOURCE ERROR- not enough trail space' - [Where] ].
system_message(error(signal(SIG,_), _)) -->
[ 'UNEXPECTED SIGNAL: ~a' - [SIG] ].
% SWI like I/O error message.
system_message(error(unhandled_exception,Throw)) -->
[ 'UNHANDLED EXCEPTION - message ~w unknown' - [Throw] ].
system_message(error(uninstantiation_error(TE), _Where)) -->
[ 'UNINSTANTIATION ERROR - expected unbound term, got ~q' - [TE] ].
system_message(Messg) -->
[ '~q' - Messg ].
domain_error(array_overflow, Opt) --> !,
[ 'invalid static index ~w for array' - Opt ].
domain_error(array_type, Opt) --> !,
[ 'invalid static array type ~w' - Opt ].
domain_error(builtin_procedure, _) --> !,
[ 'non-iso built-in procedure' ].
domain_error(character_code_list, Opt) --> !,
[ 'invalid list of codes ~w' - [Opt] ].
domain_error(close_option, Opt) --> !,
[ 'invalid close option ~w' - [Opt] ].
domain_error(delete_file_option, Opt) --> !,
[ 'invalid list of options ~w' - [Opt] ].
domain_error(encoding, Opt) --> !,
[ 'invalid encoding ~w' - [Opt] ].
domain_error(flag_value, [Opt,Flag]) --> !,
[ 'invalid value ~w for flag ~w' - [Opt,Flag] ].
domain_error(flag_value, Opt) --> !,
[ 'invalid value ~w for flag' - [Opt] ].
domain_error(io_mode, Opt) --> !,
[ 'invalid io mode ~w' - [Opt] ].
domain_error(mutable, Opt) --> !,
[ 'invalid id mutable ~w' - [Opt] ].
domain_error(module_decl_options, Opt) --> !,
[ 'expect module declaration options, found ~w' - [Opt] ].
domain_error(non_empty_list, Opt) --> !,
[ 'found empty list' - [Opt] ].
domain_error(not_less_than_zero, Opt) --> !,
[ 'number ~w less than zero' - [Opt] ].
domain_error(not_newline, Opt) --> !,
[ 'number ~w not newline' - [Opt] ].
domain_error(not_zero, Opt) --> !,
[ '~w is not allowed in the domain' - [Opt] ].
domain_error(operator_priority, Opt) --> !,
[ '~w invalid operator priority' - [Opt] ].
domain_error(operator_specifier, Opt) --> !,
[ 'invalid operator specifier ~w' - [Opt] ].
domain_error(out_of_range, Opt) --> !,
[ 'expression ~w is out of range' - [Opt] ].
domain_error(predicate_spec, Opt) --> !,
[ '~w invalid predicate specifier' - [Opt] ].
domain_error(radix, Opt) --> !,
[ 'invalid radix ~w' - [Opt] ].
domain_error(read_option, Opt) --> !,
[ '~w invalid option to read_term' - [Opt] ].
domain_error(semantics_indicator, Opt) --> !,
[ 'predicate indicator, got ~w' - [Opt] ].
domain_error(shift_count_overflow, Opt) --> !,
[ 'shift count overflow in ~w' - [Opt] ].
domain_error(source_sink, Opt) --> !,
[ '~w is not a source sink term' - [Opt] ].
domain_error(stream, Opt) --> !,
[ '~w is not a stream' - [Opt] ].
domain_error(stream_or_alias, Opt) --> !,
[ '~w is not a stream (or alias)' - [Opt] ].
domain_error(stream_encoding, Opt) --> !,
[ '~w is not a supported stream encoding' - [Opt] ].
domain_error(stream_position, Opt) --> !,
[ '~w is not a stream position' - [Opt] ].
domain_error(stream_property, Opt) --> !,
[ '~w is not a stream property' - [Opt] ].
domain_error(syntax_error_handler, Opt) --> !,
[ '~w is not a syntax error handler' - [Opt] ].
domain_error(table, Opt) --> !,
[ 'non-tabled procedure ~w' - [Opt] ].
domain_error(thread_create_option, Opt) --> !,
[ '~w is not a thread_create option' - [Opt] ].
domain_error(time_out_spec, Opt) --> !,
[ '~w is not valid specificatin for time_out' - [Opt] ].
domain_error(unimplemented_option, Opt) --> !,
[ '~w is not yet implemented' - [Opt] ].
domain_error(write_option, Opt) --> !,
[ '~w invalid write option' - [Opt] ].
domain_error(Domain, Opt) -->
[ '~w not a valid element for ~w' - [Opt,Domain] ].
extra_info( error(_,Extra), _ ) -->
{lists:memberchk([i|Msg], Extra)}, !,
['~*|user provided data is: ~q' - [10,Msg]],
[nl].
extra_info( _, _ ) -->
[].
object_name(array, array).
object_name(atom, atom).
object_name(atomic, atomic).
object_name(byte, byte).
object_name(callable, 'callable goal').
object_name(char, char).
object_name(character_code, 'character code').
object_name(compound, 'compound term').
object_name(db_reference, 'data base reference').
object_name(evaluable, 'evaluable term').
object_name(file, file).
object_name(float, float).
object_name(in_byte, byte).
object_name(in_character, character).
object_name(integer, integer).
object_name(key, 'database key').
object_name(leash_mode, 'leash mode').
object_name(library, library).
object_name(list, list).
object_name(message_queue, 'message queue').
object_name(mutex, mutex).
object_name(number, number).
object_name(operator, operator).
object_name(pointer, pointer).
object_name(predicate_indicator, 'predicate indicator').
object_name(source_sink, file).
object_name(unsigned_byte, 'unsigned byte').
object_name(unsigned_char, 'unsigned char').
object_name(variable, 'unbound variable').
svs([A=VA], [A=VA], S) :- !,
atom_string(A, S).
svs([A=VA,B=VB], [A=VA,B=VB], SN) :- !,
atom_string(A, S),
atom_string(B, S1),
string_concat([S,` and `,S1], SN).
svs([A=_], _, SN) :- !,
atom_string(A, S),
string_concat(`, and `,S, SN).
svs([A=V|L], [A=V|L], SN) :- !,
atom_string(A, S),
svs(L, [A=V|L], S1 ),
string_concat([ S, S1], SN).
svs([A=_V|L], All, SN) :- !,
atom_string(A, S),
svs(L, All, S1 ),
string_concat([`, `, S, S1], SN).
list_of_preds([]) --> [].
list_of_preds([P|L]) -->
['~q' - [P]],
list_of_preds(L).
syntax_error_term(between(_I,_J,_L),LTaL,LC) -->
['term between lines ~d and ~d' - [_I,_L], nl ],
syntax_error_tokens(LTaL, LC).
syntax_error_tokens([], _LC) --> [].
syntax_error_tokens([T|L], LC) -->
syntax_error_token(T, LC),
syntax_error_tokens(L, LC).
syntax_error_token(atom(A), _LC) --> !,
[ '~q' - [A] ].
syntax_error_token(number(N), _LC) --> !,
[ '~w' - [N] ].
syntax_error_token(var(_,S), _LC) --> !,
[ '~a' - [S] ].
syntax_error_token(string(S), _LC) --> !,
[ '`~s`' - [S] ].
syntax_error_token(error, _LC) --> !,
[ ' <== HERE ==> ' ].
syntax_error_token('EOT', _LC) --> !,
[ '.' - [], nl ].
syntax_error_token('(', _LC) --> !,
[ '( '- [] ].
syntax_error_token('{', _LC) --> !,
[ '{ '- [] ].
syntax_error_token('[', _LC) --> !,
[ '[' - [] ].
syntax_error_token(')', _LC) --> !,
[ ' )'- [] ].
syntax_error_token(']', _LC) --> !,
[ ']'- [] ].
syntax_error_token('}', _LC) --> !,
[ ' }' - [] ].
syntax_error_token(',', _LC) --> !,
[ ', ' - [] ].
syntax_error_token('.', _LC) --> !,
[ '.' - [] ].
syntax_error_token(';', _LC) --> !,
[ '; ' - [] ].
syntax_error_token(':', _LC) --> !,
[ ':' - [] ].
syntax_error_token('|', _LC) --> !,
[ '|' - [] ].
syntax_error_token('l', _LC) --> !,
[ '|' - [] ].
syntax_error_token(nl, LC) --> !,
[ '~*| ' -[LC], nl ].
syntax_error_token(B, _LC) --> !,
[ nl, 'bad_token: ~q' - [B], nl ].
print_lines( S, _, Key) -->
[nl, end(Key0)],
{ Key == Key0 },
!,
{ nl(S),
flush_output(S) }.
print_lines( S, _, Key) -->
[flush, end(Key0)],
{ Key == Key0 },
!,
{ flush_output(S) }.
print_lines(S, _, Key) -->
[ end(Key0) ],
{ Key0 == Key }, !,
{ nl(S) }.
print_lines( S, Prefix, Key) -->
[at_same_line],
!,
print_lines( S, Prefix, Key).
print_lines( S, Prefixes, Key) -->
[nl],
!,
{ nl(S),
Prefixes = [PrefixS - Cmds|More],
format(S, PrefixS, Cmds)
},
{
More == []
->
NPrefixes = Prefixes
;
NPrefixes = More
},
print_lines( S, NPrefixes, Key).
print_lines( S, Prefixes, Key) -->
[flush],
!,
{ flush_output(S) },
print_lines( S, Prefixes, Key ).
print_lines(S, Prefixes, Key) -->
[end(_OtherKey)],
!,
print_lines( S, Prefixes, Key ).
% consider this a message within the message
print_lines(S, Prefixes, Key) -->
[begin(Severity, OtherKey)],
!,
{ prefix( Severity, P ) },
print_message_lines(S, [P], OtherKey),
print_lines( S, Prefixes, Key ).
print_lines(S, Prefixes, Key) -->
[prefix(Fmt-Args)],
!,
print_lines( S, [Fmt-Args|Prefixes], Key ).
print_lines(S, Prefixes, Key) -->
[prefix(Fmt)],
{ atom( Fmt ) ; string( Fmt ) },
!,
print_lines( S, [Fmt-[]|Prefixes], Key ).
print_lines(S, Prefixes, Key) -->
[Fmt-Args],
!,
{ format(S, Fmt, Args) },
print_lines( S, Prefixes, Key ).
print_lines(S, Prefixes, Key) -->
[format(Fmt,Args)],
!,
{ format(S, Fmt, Args) },
print_lines( S, Prefixes, Key ).
% deprecated....
print_lines(S, Prefixes, Key) -->
[ Fmt ],
{ atom(Fmt) ; string( Fmt ) },
!,
{ format(S, Fmt, []) },
print_lines(S, Prefixes, Key).
print_lines(S, _Prefixes, _Key) -->
[ Msg ],
{ format(S, 'Illegal message Component: ~q !!!.~n', [Msg]) }.
prefix(help, '~N'-[]).
prefix(query, '~N'-[]).
prefix(debug, '~N'-[]).
prefix(warning, '~N'-[]).
/* { thread_self(Id) },
( { Id == main }
-> [ 'warning, ' - [] ]
; { atom(Id) }
-> ['warning [Thread ~a ], ' - [Id] ]
; ['warning [Thread ~d ], ' - [Id] ]
).
*/
prefix(error, '~N'-[]).
/*
{ thread_self(Id) },
( { Id == main }
-> [ 'error ' ]
; { thread_main_name(Id) }
-> [ 'error [ Thread ~w ] ' - [Id] ]
),
!.
prefix(error, '', user_error) -->
{ thread_self(Id) },
( { Id == main }
-> [ 'error ' - [], nl ]
; { atom(Id) }
-> [ 'error [ Thread ~a ] ' - [Id], nl ]
; [ 'error [ Thread ~d ] ' - [Id], nl ]
).
*/
prefix(banner, '~N'-[]).
prefix(informational, '~N~*|% '-[LC]) :-
'$show_consult_level'(LC).
prefix(debug(_), '~N% '-[]).
prefix(information, '~N% '-[]).
clause_to_indicator(T, MNameArity) :-
strip_module(T, M0, T1),
pred_arity( T1, M0, MNameArity ).
pred_arity(V, M, M:call/1) :- var(V), !.
pred_arity((:- _Path), _M, prolog:(:-)/1 ) :- !.
pred_arity((?- _Path), _M, prolog:(?)/1 ) :- !.
pred_arity((H:-_),M, MNameArity) :-
nonvar(H),
!,
strip_module(M:H, M1, H1),
pred_arity( H1, M1, MNameArity).
pred_arity((H-->_), M, M2:Name//Arity) :-
nonvar(H),
!,
strip_module(M:H, M1, H1),
pred_arity( H1, M1, M2:Name/Arity).
% special for a, [x] --> b, [y].
pred_arity((H,_), M, MNameArity) :-
nonvar(H),
!,
strip_module(M:H, M1, H1),
pred_arity( H1, M1, MNameArity).
pred_arity(Name/Arity, M, M:Name/Arity) :-
!.
pred_arity(Name//Arity, M, M:Name//Arity) :-
!.
pred_arity(H,M, M:Name/Arity) :-
functor(H,Name,Arity).
translate_message(Term, Level) -->
compose_message(Term, Level), !.
translate_message(Term, _) -->
{ Term = error(_, _) },
[ 'Unknown exception: ~p'-[Term] ].
translate_message(Term, _) -->
[ 'Unknown message: ~p'-[Term] ].
% print_message_lines(+Stream, +Prefix, +Lines)
%
% Quintus/SICStus/SWI compatibility predicate to print message lines
% using a prefix.
/** @pred print_message_lines(+ _Stream_, + _Prefix_, + _Lines_)
Print a message (see print_message/2) that has been translated to
a list of message elements. The elements of this list are:
+ _Format_-_Args_
Where _Format_ is an atom and _Args_ is a list
of format argument. Handed to `format/3`.
+ `flush`
If this appears as the last element, _Stream_ is flushed
(see `flush_output/1`) and no final newline is generated.
+ `at_same_line`
If this appears as first element, no prefix is printed for
the line and the line-position is not forced to 0
(see `format/1`, `~N`).
+ `prefix`(Prefix)
define a prefix for the next line, say `''` will be seen as an
empty prefix.
(see `format/1`, `~N`).
+ `<Format>`
Handed to `format/3` as `format(Stream, Format, [])`, may get confused
with other commands.
+ nl
A new line is started and if the message is not complete
the _Prefix_ is printed too.
*/
prolog:print_message_lines(S, Prefix0, Lines) :-
Lines = [begin(_, Key)|Msg],
(
atom(Prefix0)
->
Prefix = Prefix0-[]
;
string(Prefix0)
->
Prefix = Prefix0-[]
;
Prefix = Prefix0
),
(Msg = [at_same_line|Msg1]
->
print_lines(S, [Prefix], Key, Msg1, [])
;
print_lines(S, [Prefix], Key, [Prefix|Msg], [])
).
/** @pred prolog:print_message(+ Severity, +Term)
The predicate print_message/2 is used to print messages, notably from
exceptions, in a human-readable format. _Kind_ is one of
`informational`, `banner`, `warning`, `error`, `help` or `silent`. In YAP, the message is always outut to the stream user_error.
If the Prolog flag verbose is `silent`, messages with
_Kind_ `informational`, or `banner` are treated as
silent. See `-q` in [Running_YAP_Interactively].
This predicate first translates the _Term_ into a list of `message
lines` (see print_message_lines/3 for details). Next it will
call the hook message_hook/3 to allow the user intercepting the
message. If message_hook/3 fails it will print the message unless
_Kind_ is silent.
If you need to report errors from your own predicates, we advise you to
stick to the existing error terms if you can; but should you need to
invent new ones, you can define corresponding error messages by
asserting clauses for `prolog:message/2`. You will need to declare
the predicate as multifile.
Note: errors in the implementation of print_message/2 are very
confusing to YAP (who will process the error?). So we write this small
stub to ensure everything os ok
*/
prolog:print_message(Severity, Msg) :-
(
var(Severity)
->
!,
format(user_error, 'malformed message ~q: message level is unbound~n', [Msg])
;
var(Msg)
->
!,
format(user_error, 'uninstantiated message~n', [])
;
Severity == silent
->
true
;
'$pred_exists'(portray_message(_,_),user),
user:portray_message(Severity, Msg)
),
!.
prolog:print_message(Level, _Msg) :-
current_prolog_flag(verbose_load, silent),
stream_property(_Stream, alias(loop_stream) ),
Level = informational,
!.
prolog:print_message(Level, _Msg) :-
current_prolog_flag(verbose, silent),
Level \= error,
Level \= warning,
!.
prolog:print_message(_, _Msg) :-
% first step at hook processing
'$nb_getval'('$if_skip_mode',skip,fail),
!.
prolog:print_message(force(_Severity), Msg) :- !,
print(user_error,Msg).
% This predicate has more hooks than a pirate ship!
prolog:print_message(Severity, Term) :-
prolog:message( Term,Lines0, [ end(Id)]),
Lines = [begin(Severity, Id)| Lines0],
(
user:message_hook(Term, Severity, Lines)
->
true
;
prefix( Severity, Prefix ),
prolog:print_message_lines(user_error, Prefix, Lines)
),
!.
prolog:print_message(Severity, Term) :-
translate_message( Term, Severity, Lines0, [ end(Id)]),
Lines = [begin(Severity, Id)| Lines0],
(
user:message_hook(Term, Severity, Lines)
->
true
;
prefix( Severity, Prefix ),
prolog:print_message_lines(user_error, Prefix, Lines)
),
!.
prolog:print_message(Severity, _Term) :-
format('No handler for ~a message ~q,~n',[Severity, _Term]).
/**
@}
*/

View File

@@ -1,582 +0,0 @@
/**
@defgroup YAPMetaPredicates Using Meta-Calls with Modules
@ingroup YAPModules
@{
@pred meta_predicate(_G1_,...., _Gn) is directive
Declares that this predicate manipulates references to predicates.
Each _Gi_ is a mode specification.
If the argument is `:`, it does not refer directly to a predicate
but must be module expanded. If the argument is an integer, the argument
is a goal or a closure and must be expanded. Otherwise, the argument is
not expanded. Note that the system already includes declarations for all
built-ins.
For example, the declaration for call/1 and setof/3 are:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
:- meta_predicate call(0), setof(?,0,?).
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
meta_predicate declaration
implemented by asserting $meta_predicate(SourceModule,Functor,Arity,Declaration)
*/
% directive now meta_predicate Ps :- $meta_predicate(Ps).
:- dynamic prolog:'$meta_predicate'/4.
:- multifile prolog:'$meta_predicate'/4,
'$inline'/2,
'$full_clause_optimisation'/4.
'$meta_predicate'(M:P) :-
var(P),
'$do_error'(instantiation_error,meta_predicate(M:P)).
'$meta_predicate'(M:P) :-
var(M),
'$do_error'(instantiation_error,meta_predicate(M:P)).
'$meta_predicate'(M:(P,Ps)) :- !,
'$meta_predicate'(M:P),
'$meta_predicate'(M:Ps).
'$meta_predicate'( M:D ) :-
'$yap_strip_module'( M:D, M1, P),
'$install_meta_predicate'(M1:P).
'$install_meta_predicate'(M1:P) :-
functor(P,F,N),
( M1 = prolog -> M = _ ; M1 = M),
( retractall(prolog:'$meta_predicate'(F,M,N,_)), fail ; true),
asserta(prolog:'$meta_predicate'(F,M,N,P)),
'$predicate_flags'(P, M1, Fl, Fl),
NFlags is Fl \/ 0x200000,
'$predicate_flags'(P, M1, Fl, NFlags).
% comma has its own problems.
:- '$install_meta_predicate'(prolog:','(0,0)).
%% handle module transparent predicates by defining a
%% new context module.
'$is_mt'(H, B, HM, _SM, M, (context_module(CM),B), CM) :-
'$yap_strip_module'(HM:H, M, NH),
'$module_transparent'(_, M, _, NH), !.
'$is_mt'(_H, B, _HM, _SM, BM, B, BM).
% I assume the clause has been processed, so the
% var case is long gone! Yes :)
'$clean_cuts'(G,('$current_choicepoint'(DCP),NG)) :-
'$conj_has_cuts'(G,DCP,NG,OK), OK == ok, !.
'$clean_cuts'(G,G).
'$clean_cuts'(G,DCP,NG) :-
'$conj_has_cuts'(G,DCP,NG,OK), OK == ok, !.
'$clean_cuts'(G,_,G).
'$conj_has_cuts'(V,_,V, _) :- var(V), !.
'$conj_has_cuts'(!,DCP,'$$cut_by'(DCP), ok) :- !.
'$conj_has_cuts'((G1,G2),DCP,(NG1,NG2), OK) :- !,
'$conj_has_cuts'(G1, DCP, NG1, OK),
'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'((G1;G2),DCP,(NG1;NG2), OK) :- !,
'$conj_has_cuts'(G1, DCP, NG1, OK),
'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'((G1->G2),DCP,(G1;NG2), OK) :- !,
% G1: the system must have done it already
'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'((G1*->G2),DCP,(G1;NG2), OK) :- !,
% G1: the system must have done it already
'$conj_has_cuts'(G2, DCP, NG2, OK).
'$conj_has_cuts'(if(G1,G2,G3),DCP,if(G1,NG2,NG3), OK) :- !,
% G1: the system must have done it already
'$conj_has_cuts'(G2, DCP, NG2, OK),
'$conj_has_cuts'(G3, DCP, NG3, OK).
'$conj_has_cuts'(G,_,G, _).
% return list of vars in expanded positions on the head of a clause.
%
% these variables should not be expanded by meta-calls in the body of the goal.
%
% should be defined before caller.
%
'$module_u_vars'(M, H, UVars) :-
'$do_module_u_vars'(M:H,UVars).
'$do_module_u_vars'(M:H,UVars) :-
functor(H,F,N),
'$meta_predicate'(F,M,N,D), !,
'$do_module_u_vars'(N,D,H,UVars).
'$do_module_u_vars'(_,[]).
'$do_module_u_vars'(0,_,_,[]) :- !.
'$do_module_u_vars'(I,D,H,LF) :-
arg(I,D,X), ( X=':' -> true ; integer(X)),
arg(I,H,A), '$uvar'(A, LF, L), !,
I1 is I-1,
'$do_module_u_vars'(I1,D,H,L).
'$do_module_u_vars'(I,D,H,L) :-
I1 is I-1,
'$do_module_u_vars'(I1,D,H,L).
'$uvar'(Y, [Y|L], L) :- var(Y), !.
% support all/3
'$uvar'(same( G, _), LF, L) :-
'$uvar'(G, LF, L).
'$uvar'('^'( _, G), LF, L) :-
'$uvar'(G, LF, L).
/**
* @pred '$meta_expand'( _Input_, _HeadModule_, _BodyModule_, _SourceModule_, _HVars_-_Head_, _OutGoal_)
*
* expand Input if a metapredicate, otherwF,MI,Arity,PredDefise ignore
*
* @return
*/
'$meta_expand'(G, _, CM, HVars, OG) :-
var(G),
!,
(
lists:identical_member(G, HVars)
->
OG = G
;
OG = CM:G
).
% nothing I can do here:
'$meta_expand'(G0, PredDef, CM, HVars, NG) :-
G0 =.. [Name|GArgs],
PredDef =.. [Name|GDefs],
functor(PredDef, Name, Arity ),
length(NGArgs, Arity),
NG =.. [Name|NGArgs],
'$expand_args'(GArgs, CM, GDefs, HVars, NGArgs).
'$expand_args'([], _, [], _, []).
'$expand_args'([A|GArgs], CM, [M|GDefs], HVars, [NA|NGArgs]) :-
( M == ':' -> true ; number(M) ),
!,
'$expand_arg'(A, CM, HVars, NA),
'$expand_args'(GArgs, CM, GDefs, HVars, NGArgs).
'$expand_args'([A|GArgs], CM, [_|GDefs], HVars, [A|NGArgs]) :-
'$expand_args'(GArgs, CM, GDefs, HVars, NGArgs).
% check if an argument should be expanded
'$expand_arg'(G, CM, HVars, OG) :-
var(G),
!,
( lists:identical_member(G, HVars) -> OG = G; OG = CM:G).
'$expand_arg'(G, CM, _HVars, NCM:NG) :-
'$yap_strip_module'(CM:G, NCM, NG).
% expand module names in a body
% args are:
% goals to expand
% code to pass to listing
% code to pass to compiler
% head module HM
% source module SM
% current module for looking up preds M
%
% to understand the differences, you can consider:
%
% a:(d:b(X)) :- g:c(X), d(X), user:hello(X)).
%
% when we process meta-predicate c, HM=d, DM=a, BM=a, M=g and we should get:
%
% d:b(X) :- g:c(g:X), a:d(X), user:hello(X).
%
% on the other hand,
%
% a:(d:b(X) :- c(X), d(X), d:e(X)).
%
% will give
%
% d:b(X) :- a:c(a:X), a:d(X), e(X).
%
%
% head variab'$expand_goals'(M:G,G1,GO,HM,SM,,_M,HVars)les.
% goals or arguments/sub-arguments?
% I cannot use call here because of format/3
% modules:
% A4: module for body of clause (this is the one used in looking up predicates)
% A5: context module (this is the current context
% A6: head module (this is the one used in compiling and accessing).
%
%
%'$expand_goals'(V,NG,NG,HM,SM,BM,HVars):- writeln(V), fail.
'$expand_goals'(V,NG,NGO,HM,SM,BM,HVars-H) :-
var(V),
!,
( lists:identical_member(V, HVars)
->
'$expand_goals'(call(V),NG,NGO,HM,SM,BM,HVars-H)
;
( atom(BM)
->
NG = call(BM:V),
NGO = '$execute_in_mod'(V,BM)
;
'$expand_goals'(call(BM:V),NG,NGO,HM,SM,BM,HVars-H)
)
).
'$expand_goals'(BM:V,NG,NGO,HM,SM,_BM,HVarsH) :-
'$yap_strip_module'( BM:V, CM, G),
nonvar(CM),
!,
'$expand_goals'(G,NG,NGO,HM,SM,CM,HVarsH).
'$expand_goals'(CM0:V,NG,NGO,HM,SM,BM,HVarsH) :-
strip_module( CM0:V, CM, G),
!,
'$expand_goals'(call(CM:G),NG,NGO,HM,SM,BM,HVarsH).
% if I don't know what the module is, I cannot do anything to the goal,
% so I just put a call for later on.
'$expand_goals'(V,NG,NGO,_HM,_SM,BM,_HVarsH) :-
var(BM),
!,
NG = call(BM:V),
NGO = '$execute_wo_mod'(V,BM).
'$expand_goals'(depth_bound_call(G,D),
depth_bound_call(G1,D),
('$set_depth_limit_for_next_call'(D),GO),
HM,SM,BM,HVars) :-
'$expand_goals'(G,G1,GO,HM,SM,BM,HVars),
'$composed_built_in'(GO), !.
'$expand_goals'((A,B),(A1,B1),(AO,BO),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO,HM,SM,BM,HVars),
'$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
'$expand_goals'((A;B),(A1;B1),(AO;BO),HM,SM,BM,HVars) :- var(A), !,
'$expand_goals'(A,A1,AO,HM,SM,BM,HVars),
'$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
'$expand_goals'((A*->B;C),(A1*->B1;C1),
(
yap_hacks:current_choicepoint(DCP),
AO,
yap_hacks:cut_at(DCP),BO
;
CO
),
HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AOO,HM,SM,BM,HVars),
'$clean_cuts'(AOO, AO),
'$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
'$expand_goals'(C,C1,CO,HM,SM,BM,HVars).
'$expand_goals'((A;B),(A1;B1),(AO;BO),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO,HM,SM,BM,HVars),
'$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
'$expand_goals'((A|B),(A1|B1),(AO|BO),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO,HM,SM,BM,HVars),
'$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
'$expand_goals'((A->B),(A1->B1),(AO->BO),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AOO,HM,SM,BM,HVars),
'$clean_cuts'(AOO, AO),
'$expand_goals'(B,B1,BO,HM,SM,BM,HVars).
'$expand_goals'(\+G,\+G,A\=B,_HM,_BM,_SM,_HVars) :-
nonvar(G),
G = (A = B),
!.
'$expand_goals'(\+A,\+A1,('$current_choice_point'(CP),AO,'$$cut_by'(CP)-> false;true),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO,HM,SM,BM,HVars).
'$expand_goals'(once(A),once(A1),
('$current_choice_point'(CP),AO,'$$cut_by'(CP)),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
'$clean_cuts'(AO0, CP, AO).
'$expand_goals'(ignore(A),ignore(A1),
('$current_choice_point'(CP),AO,'$$cut_by'(CP)-> true ; true),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
'$clean_cuts'(AO0, AO).
'$expand_goals'(forall(A,B),forall(A1,B1),
((AO, ( BO-> false ; true)) -> false ; true),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
'$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
'$clean_cuts'(AO0, AO).
'$expand_goals'(not(A),not(A1),('$current_choice_point'(CP),AO,'$$cut_by'(CP) -> fail; true),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO,HM,SM,BM,HVars).
'$expand_goals'(if(A,B,C),if(A1,B1,C1),
('$current_choicepoint'(DCP),AO,yap_hacks:cut_at(DCP),BO; CO),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
'$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
'$expand_goals'(C,C1,CO,HM,SM,BM,HVars),
'$clean_cuts'(AO0, DCP, AO).
'$expand_goals'((A*->B;C),(A1*->B1;C1),
('$current_choicepoint'(DCP),AO,yap_hacks:cut_at(DCP),BO; CO),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
'$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
'$expand_goals'(C,C1,CO,HM,SM,BM,HVars),
'$clean_cuts'(AO0, DCP, AO).
'$expand_goals'((A*->B),(A1*->B1),
('$current_choicepoint'(DCP),AO,BO),HM,SM,BM,HVars) :- !,
'$expand_goals'(A,A1,AO0,HM,SM,BM,HVars),
'$expand_goals'(B,B1,BO,HM,SM,BM,HVars),
'$clean_cuts'(AO0, DCP, AO).
'$expand_goals'(true,true,true,_,_,_,_) :- !.
'$expand_goals'(fail,fail,fail,_,_,_,_) :- !.
'$expand_goals'(false,false,false,_,_,_,_) :- !.
'$expand_goals'(G, G1, GO, HM, SM, BM, HVars) :-
'$yap_strip_module'(BM:G, NBM, GM),
'$expand_goal'(GM, G1, GO, HM, SM, NBM, HVars).
'$import_expansion'(M:G, M1:G1) :-
'$imported_predicate'(G, M, G1, M1),
!.
'$import_expansion'(MG, MG).
'$meta_expansion'(GMG, BM, HVars, GM:GF) :-
'$yap_strip_module'(GMG, GM, G ),
functor(G, F, Arity ),
'$meta_predicate'(F, GM, Arity, PredDef),
!,
'$meta_expand'(G, PredDef, BM, HVars, GF).
'$meta_expansion'(GMG, _BM, _HVars, GM:G) :-
'$yap_strip_module'(GMG, GM, G ).
/**
* @brief Perform meta-variable and user expansion on a goal _G_
*
* given the example
~~~~~
:- module(m, []).
o:p(B) :- n:g, X is 2+3, call(B).
~~~~~
*
* @param G input goal, without module quantification.
* @param G1F output, non-optimised for debugging
* @param GOF output, optimised, ie, `n:g`, `prolog:(X is 2+3)`, `call(m:B)`, where `prolog` does not need to be explicit
* @param GOF output, optimised, `n:g`, `prolog:(X=5)`, `call(m:B)`
* @param HM head module, input, o
* @param HM source module, input, m
* @param M current module, input, `n`, `m`, `m`
* @param HVars-H, list of meta-variables and initial head, `[]` and `p(B)`
*
*
*/
'$expand_goal'(G0, G1F, GOF, HM, SM, BM, HVars-H) :-
'$yap_strip_module'( BM:G0, M0N, G0N),
'$user_expansion'(M0N:G0N, M1:G1),
'$import_expansion'(M1:G1, M2:G2),
'$meta_expansion'(M2:G2, M1, HVars, M2:B1F),
'$end_goal_expansion'(B1F, G1F, GOF, HM, SM, M2, H).
'$end_goal_expansion'(G, G1F, GOF, HM, SM, BM, H) :-
'$match_mod'(G, HM, SM, BM, G1F),
'$c_built_in'(G1F, BM, H, GO),
'$yap_strip_module'(BM:GO, MO, IGO),
'$match_mod'(IGO, HM, SM, MO, GOF).
'$user_expansion'(M0N:G0N, M1:G1) :-
'_user_expand_goal'(M0N:G0N, M:G),
!,
( M:G == M0N:G0N
->
M1:G1 = M:G
;
'$user_expansion'(M:G, M1:G1)
).
'$user_expansion'(MG, MG).
'$match_mod'(G, HMod, SMod, M, O) :-
(
% \+ '$is_multifile'(G1,M),
%->
'$is_system_predicate'(G,prolog)
->
O = G
;
M == HMod, M == SMod
->
O = G
;
O = M:G
).
'$build_up'(HM, NH, SM, true, NH, true, NH) :- HM == SM, !.
'$build_up'(HM, NH, _SM, true, HM:NH, true, HM:NH) :- !.
'$build_up'(HM, NH, SM, B1, (NH :- B1), BO, ( NH :- BO)) :- HM == SM, !.
'$build_up'(HM, NH, _SM, B1, (NH :- B1), BO, ( HM:NH :- BO)) :- !.
'$expand_clause_body'(V, _NH1, _HM1, _SM, M, call(M:V), call(M:V) ) :-
var(V), !.
'$expand_clause_body'(true, _NH1, _HM1, _SM, _M, true, true ) :- !.
'$expand_clause_body'(B, H, HM, SM, M, B1, BO ) :-
'$module_u_vars'(HM , H, UVars), % collect head variables in
% expanded positions
% support for SWI's meta primitive.
'$is_mt'(H, B, HM, SM, M, IB, BM),
'$expand_goals'(IB, B1, BO1, HM, SM, BM, UVars-H),
(
'$full_clause_optimisation'(H, BM, BO1, BO)
->
true
;
BO = BO1
).
%
% check if current module redefines an imported predicate.
% and remove import.
%
'$not_imported'(H, Mod) :-
recorded('$import','$import'(NM,Mod,NH,H,_,_),R),
NM \= Mod,
functor(NH,N,Ar),
print_message(warning,redefine_imported(Mod,NM,N/Ar)),
erase(R),
fail.
'$not_imported'(_, _).
'$verify_import'(_M:G, prolog:G) :-
'$is_system_predicate'(G, prolog).
'$verify_import'(M:G, NM:NG) :-
'$get_undefined_pred'(G, M, NG, NM),
!.
'$verify_import'(MG, MG).
% expand arguments of a meta-predicate
% $meta_expansion(ModuleWhereDefined,CurrentModule,Goal,ExpandedGoal,MetaVariables)
% expand module names in a clause (interface predicate).
% A1: Input Clause
% A2: Output Class to Compiler (lives in module HM)
% A3: Output Class to clause/2 and listing (lives in module HM)
%
% modules:
% A6: head module (this is the one used in compiling and accessing).
% A5: context module (this is the current context
% A4: module for body of clause (this is the one used in looking up predicates)
%
% has to be last!!!
'$expand_a_clause'(MHB, SM0, Cl1, ClO) :- % MHB is the original clause, SM0 the current source, Cl1 and ClO output clauses
'$yap_strip_module'(SM0:MHB, SM, HB), % remove layers of modules over the clause. SM is the source module.
'$head_and_body'(HB, H, B), % HB is H :- B.
'$yap_strip_module'(SM:H, HM, NH), % further module expansion
'$not_imported'(NH, HM),
'$yap_strip_module'(SM:B, BM, B0), % further module expansion
'$expand_clause_body'(B0, NH, HM, SM0, BM, B1, BO),
'$build_up'(HM, NH, SM0, B1, Cl1, BO, ClO).
expand_goal(Input, Output) :-
'$expand_meta_call'(Input, [], Output ).
'$expand_meta_call'(G, HVars, MF:GF ) :-
source_module(SM),
'$yap_strip_module'(SM:G, M, IG),
'$expand_goals'(IG, _, GF0, M, SM, M, HVars-G),
'$yap_strip_module'(M:GF0, MF, GF).
:- '$meta_predicate'(prolog:(
abolish(:),
abolish(:,+),
all(?,0,-),
assert(:),
assert(:,+),
assert_static(:),
asserta(:),
asserta(:,+),
asserta_static(:),
assertz(:),
assertz(:,+),
assertz_static(:),
at_halt(0),
bagof(?,0,-),
bb_get(:,-),
bb_put(:,+),
bb_delete(:,?),
bb_update(:,?,?),
call(0),
call(1,?),
call(2,?,?),
call(3,?,?,?),
call_with_args(0),
call_with_args(1,?),
call_with_args(2,?,?),
call_with_args(3,?,?,?),
call_with_args(4,?,?,?,?),
call_with_args(5,?,?,?,?,?),
call_with_args(6,?,?,?,?,?,?),
call_with_args(7,?,?,?,?,?,?,?),
call_with_args(8,?,?,?,?,?,?,?,?),
call_with_args(9,?,?,?,?,?,?,?,?,?),
call_cleanup(0,0),
call_cleanup(0,?,0),
call_residue(0,?),
call_residue_vars(0,?),
call_shared_object_function(:,+),
catch(0,?,0),
clause(:,?),
clause(:,?,?),
compile(:),
consult(:),
current_predicate(:),
current_predicate(?,:),
db_files(:),
depth_bound_call(0,+),
discontiguous(:),
ensure_loaded(:),
exo_files(:),
findall(?,0,-),
findall(?,0,-,?),
forall(0,0),
format(+,:),
format(+,+,:),
freeze(?,0),
hide_predicate(:),
if(0,0,0),
ignore(0),
incore(0),
multifile(:),
nospy(:),
not(0),
notrace(0),
once(0),
phrase(2,?),
phrase(2,?,+),
predicate_property(:,?),
predicate_statistics(:,-,-,-),
on_exception(+,0,0),
qsave_program(+,:),
reconsult(:),
retract(:),
retract(:,?),
retractall(:),
reconsult(:),
setof(?,0,-),
setup_call_cleanup(0,0,0),
setup_call_catcher_cleanup(0,0,?,0),
spy(:),
stash_predicate(:),
use_module(:),
use_module(:,?),
use_module(?,:,?),
when(+,0),
with_mutex(+,0),
with_output_to(?,0),
'->'(0 , 0),
'*->'(0 , 0),
';'(0 , 0),
% ','(0 , 0),
^(+,0),
{}(0,?,?),
','(2,2,?,?),
;(2,2,?,?),
'|'(2,2,?,?),
->(2,2,?,?),
\+(2,?,?),
\+( 0 )
)).

View File

@@ -1,785 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: modules.pl *
* Last rev: *
* mods: *
* comments: module support *
* *
*************************************************************************/
/**
@file modules.yap
**/
:- system_module( '$_modules', [abolish_module/1,
add_import_module/3,
current_module/1,
current_module/2,
delete_import_module/2,
expand_goal/2,
export/1,
export_list/2,
export_resource/1,
import_module/2,
ls_imports/0,
module/1,
module_property/2,
set_base_module/1,
source_module/1,
use_module/1,
use_module/2,
use_module/3], ['$add_to_imports'/3,
'$clean_cuts'/2,
'$convert_for_export'/7,
'$do_import'/3,
'$extend_exports'/3,
'$get_undefined_pred'/4,
'$imported_predicate'/4,
'$meta_expand'/6,
'$meta_predicate'/2,
'$meta_predicate'/4,
'$module'/3,
'$module'/4,
'$module_expansion'/6,
'$module_transparent'/2,
'$module_transparent'/4]).
:- use_system_module( '$_arith', ['$c_built_in'/3]).
:- use_system_module( '$_consult', ['$lf_opt'/3,
'$load_files'/3]).
:- use_system_module( '$_debug', ['$skipeol'/1]).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_eval', ['$full_clause_optimisation'/4]).
:- multifile '$system_module'/1.
:- '$purge_clauses'(module(_,_), prolog).
:- '$purge_clauses'('$module'(_,_), prolog).
:- '$purge_clauses'(use_module(_), prolog).
:- '$purge_clauses'(use_module(_,_), prolog).
%
% start using default definition of module.
%
/**
\pred use_module( +Files ) is directive
@load a module file
This predicate loads the file specified by _Files_, importing all
their public predicates into the current type-in module. It is
implemented as if by:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~pl
use_module(F) :-
load_files(F, [if(not_loaded),must_be_module(true)]).
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Notice that _Files_ may be a single file, or a list with a number
files. The _Files_ are loaded in YAP only once, even if they have been
updated meanwhile. YAP should also verify whether the files actually
define modules. Please consult load_files/3 for other options when
loading a file.
Predicate name clashes between two different modules may arise, either
when trying to import predicates that are also defined in the current
type-in module, or by trying to import the same predicate from two
different modules.
In the first case, the local predicate is considered to have priority
and use_module/1 simply gives a warning. As an example, if the file
`a.pl` contains:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~pl
:- module( a, [a/1] ).
:- use_module(b).
a(1).
a(X) :- b(X).
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
and the file `b.pl` contains:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~pl
:- module( b, [a/1,b/1] ).
a(2).
b(1).
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
YAP will execute as follows:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~pl
?- [a].
% consulting .../a.pl...
% consulting .../b.pl...
% consulted .../b.pl in module b, 0 msec 0 bytes
% consulted .../a.pl in module a, 1 msec 0 bytes
true.
?- a(X).
X = 1 ? ;
X = 1.
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The example shows that the query `a(X)`has a single answer, the one
defined in `a.pl`. Calls to `a(X)`succeed in the top-level, because
the module `a` was loaded into `user`. On the other hand, `b(X)`is not
exported by `a.pl`, and is not available to calls, although it can be
accessed as a predicate in the module 'a' by using the `:` operator.
Next, consider the three files `c.pl`, `d1.pl`, and `d2.pl`:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~pl
% c.pl
:- module( c, [a/1] ).
:- use_module([d1, d2]).
a(X) :-
b(X).
a(X) :-
c(X).
a(X) :-
d(X).
% d1.pl
:- module( d1, [b/1,c/1] ).
vvb(2).
c(3).
% d2.pl
:- module( d2, [b/1,d/1] ).
b(1).
d(4).
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The result is as follows:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~pl
./yap -l c
YAP 6.3.4 (x86_64-darwin13.3.0): Tue Jul 15 10:42:11 CDT 2014
ERROR!!
at line 3 in o/d2.pl,
PERMISSION ERROR- loading .../c.pl: modules d1 and d2 both define b/1
?- a(X).
X = 2 ? ;
ERROR!!
EXISTENCE ERROR- procedure c/1 is undefined, called from context prolog:$user_call/2
Goal was c:c(_131290)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The state of the module system after this error is undefined.
**/
use_module(F) :- '$load_files'(F,
[if(not_loaded),must_be_module(true)], use_module(F)).
/**
\pred use_module(+Files, +Imports)
loads a module file but only imports the named predicates
This predicate loads the file specified by _Files_, importing their
public predicates specified by _Imports_ into the current type-in
module. It is implemented as if by:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~pl
use_module(Files, Imports) :-
load_files(Files, [if(not_loaded),must_be_module(true),imports(Imports)]).
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The _Imports_ argument may be use to specify which predicates one
wants to load. It can also be used to give the predicates a different name. As an example,
the graphs library is implemented on top of the red-black trees library, and some predicates are just aliases:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~pl
:- use_module(library(rbtrees), [
rb_min/3 as min_assoc,
rb_max/3 as max_assoc,
...]).
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Unfortunately it is still not possible to change argument order.
**/
use_module(F,Is) :-
'$load_files'(F, [if(not_loaded),must_be_module(true),imports(Is)], use_module(F,Is)).
'$module'(O,N,P,Opts) :- !,
'$module'(O,N,P),
'$process_module_decls_options'(Opts,module(Opts,N,P)).
'$process_module_decls_options'(Var,Mod) :-
var(Var), !,
'$do_error'(instantiation_error,Mod).
'$process_module_decls_options'([],_) :- !.
'$process_module_decls_options'([H|L],M) :- !,
'$process_module_decls_option'(H,M),
'$process_module_decls_options'(L,M).
'$process_module_decls_options'(T,M) :-
'$do_error'(type_error(list,T),M).
'$process_module_decls_option'(Var,M) :-
var(Var),
'$do_error'(instantiation_error,M).
'$process_module_decls_option'(At,M) :-
atom(At), !,
use_module(M:At).
'$process_module_decls_option'(library(L),M) :- !,
use_module(M:library(L)).
'$process_module_decls_option'(hidden(Bool),M) :- !,
'$process_hidden_module'(Bool, M).
'$process_module_decls_option'(Opt,M) :-
'$do_error'(domain_error(module_decl_options,Opt),M).
'$process_hidden_module'(TNew,M) :-
'$convert_true_off_mod3'(TNew, New, M),
source_mode(Old, New),
'$prepare_restore_hidden'(Old,New).
'$convert_true_off_mod3'(true, off, _) :- !.
'$convert_true_off_mod3'(false, on, _) :- !.
'$convert_true_off_mod3'(X, _, M) :-
'$do_error'(domain_error(module_decl_options,hidden(X)),M).
'$prepare_restore_hidden'(Old,Old) :- !.
'$prepare_restore_hidden'(Old,New) :-
recorda('$system_initialization', source_mode(New,Old), _).
'$extend_exports'(HostF, Exports, DonorF ) :-
( recorded('$module','$module'( DonorF, DonorM, _,DonorExports, _),_) -> true ; DonorF = user_input ),
( recorded('$module','$module'( HostF, HostM, SourceF, _, _),_) -> true ; HostF = user_input ),
recorded('$module','$module'(HostF, HostM, _, AllExports, _Line), R), erase(R),
'$convert_for_export'(Exports, DonorExports, DonorM, HostM, _TranslationTab, AllReExports, reexport(DonorF, Exports)),
lists:append( AllReExports, AllExports, Everything0 ),
sort( Everything0, Everything ),
( source_location(_, Line) -> true ; Line = 0 ),
recorda('$module','$module'(HostF,HostM,SourceF, Everything, Line),_).
'$module_produced by'(M, M0, N, K) :-
recorded('$import','$import'(M,M0,_,_,N,K),_), !.
'$module_produced by'(M, M0, N, K) :-
recorded('$import','$import'(MI,M0,G1,_,N,K),_),
functor(G1, N1, K1),
'$module_produced by'(M,MI,N1,K1).
/** @pred current_module( ? Mod:atom) is nondet
Succeeds if _M_ is a user-visible modules. A module is defined as soon as some
predicate defined in the module is loaded, as soon as a goal in the
module is called, or as soon as it becomes the current type-in module.
*/
current_module(Mod) :-
'$all_current_modules'(Mod),
\+ '$hidden_atom'(Mod).
/** @pred current_module( ? Mod:atom, ? _F_ : file ) is nondet
Succeeds if _M_ is a module associated with the file _F_, that is, if _File_ is the source for _M_. If _M_ is not declared in a file, _F_ unifies with `user`.
*/
current_module(Mod,TFN) :-
( atom(Mod) -> true ; '$all_current_modules'(Mod) ),
( recorded('$module','$module'(TFN,Mod,_,_Publics, _),_) -> true ; TFN = user ).
system_module(Mod) :-
( atom(Mod) -> true ; '$all_current_modules'(Mod) ),
'$is_system_module'(Mod).
'$trace_module'(X) :-
telling(F),
tell('P0:debug'),
write(X),nl,
tell(F), fail.
'$trace_module'(_).
'$trace_module'(X,Y) :- X==Y, !.
'$trace_module'(X,Y) :-
telling(F),
tell('~/.dbg.modules'),
write('***************'), nl,
portray_clause(X),
portray_clause(Y),
tell(F),fail.
'$trace_module'(_,_).
'$continue_imported'(Mod,Mod,Pred,Pred) :-
'$pred_exists'(Pred, Mod),
!.
'$continue_imported'(FM,Mod,FPred,Pred) :-
recorded('$import','$import'(IM,Mod,IPred,Pred,_,_),_),
'$continue_imported'(FM, IM, FPred, IPred), !.
'$continue_imported'(FM,Mod,FPred,Pred) :-
prolog:'$parent_module'(Mod,IM),
'$continue_imported'(FM, IM, FPred, Pred).
% be careful here not to generate an undefined exception.
'$imported_predicate'(G, _ImportingMod, G, prolog) :-
nonvar(G), '$is_system_predicate'(G, prolog), !.
'$imported_predicate'(G, ImportingMod, G0, ExportingMod) :-
( var(G) -> true ;
var(ImportingMod) -> true ;
'$undefined'(G, ImportingMod)
),
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod),
ExportingMod \= ImportingMod,
!.
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :-
recorded('$import','$import'(ExportingModI,ImportingMod,G0I,G,_,_),_),
'$continue_imported'(ExportingMod, ExportingModI, G0, G0I),
!.
% SWI builtin
'$get_undefined_pred'(G, _ImportingMod, G, user) :-
nonvar(G),
'$pred_exists'(G, user), !.
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :-
recorded('$dialect',swi,_),
prolog_flag(autoload, true),
prolog_flag(unknown, OldUnk, fail),
(
'$autoload'(G, ImportingMod, ExportingModI, swi)
->
prolog_flag(unknown, _, OldUnk)
;
prolog_flag(unknown, _, OldUnk),
fail
),
'$continue_imported'(ExportingMod, ExportingModI, G0, G).
% autoload
% parent module mechanism
'$get_undefined_pred'(G, ImportingMod, G0, ExportingMod) :-
'$parent_module'(ImportingMod,ExportingModI),
'$continue_imported'(ExportingMod, ExportingModI, G0, G).
'$autoload'(G, _ImportingMod, ExportingMod, Dialect) :-
functor(G, Name, Arity),
'$pred_exists'(index(Name,Arity,ExportingMod,_),Dialect),
call(Dialect:index(Name,Arity,ExportingMod,_)),
!.
'$autoload'(G, ImportingMod, ExportingMod, _Dialect) :-
functor(G, N, K),
functor(G0, N, K),
'$autoloader_find_predicate'(G0,ExportingMod),
ExportingMod \= ImportingMod,
(recordzifnot('$import','$import'(ExportingMod,ImportingMod,G0,G0, N ,K),_) -> true ; true ).
'$autoloader_find_predicate'(G,ExportingModI) :-
'$nb_getval'('$autoloader_set', true, false), !,
autoloader:find_predicate(G,ExportingModI).
'$autoloader_find_predicate'(G,ExportingModI) :-
yap_flag(autoload, true, false),
yap_flag( unknown, Unknown, fail),
yap_flag(debug, Debug, false), !,
load_files([library(autoloader),
autoloader:library('INDEX'),
swi:library('dialect/swi/INDEX')],
[autoload(true),if(not_loaded)]),
nb_setval('$autoloader_set', true),
yap_flag(autoload, _, true),
yap_flag( unknown, _, Unknown),
yap_flag( debug, _, Debug),
autoloader:find_predicate(G,ExportingModI).
/**
be associated to a new file.
\param[in] _Module_ is the name of the module to declare
\param[in] _MSuper_ is the name of the context module. Use `prolog`or `system`
if you do not need a context.
\param[in] _File_ is the canonical name of the file from which the module is loaded
\param[in] Line is the line-number of the :- module/2 directive.
\param[in] If _Redefine_ `true`, allow associating the module to a new file
*/
'$declare_module'(Name, _Super, Context, _File, _Line) :-
add_import_module(Name, Context, start).
/**
\pred abolish_module( + Mod) is det
get rid of a module and of all predicates included in the module.
*/
abolish_module(Mod) :-
recorded('$module','$module'(_,Mod,_,_,_),R), erase(R),
fail.
abolish_module(Mod) :-
recorded('$import','$import'(Mod,_,_,_,_,_),R), erase(R),
fail.
abolish_module(Mod) :-
'$current_predicate'(Na,Mod,S,_),
functor(S, Na, Ar),
abolish(Mod:Na/Ar),
fail.
abolish_module(_).
export(Resource) :-
var(Resource),
'$do_error'(instantiation_error,export(Resource)).
export([]) :- !.
export([Resource| Resources]) :- !,
export_resource(Resource),
export(Resources).
export(Resource) :-
export_resource(Resource).
export_resource(Resource) :-
var(Resource), !,
'$do_error'(instantiation_error,export(Resource)).
export_resource(P) :-
P = F/N, atom(F), number(N), N >= 0, !,
'$current_module'(Mod),
( recorded('$module','$module'(File,Mod,SourceF,ExportedPreds,Line),R) ->
erase(R),
recorda('$module','$module'(File,Mod,SourceF,[P|ExportedPreds],Line),_)
; prolog_load_context(file, File) ->
recorda('$module','$module'(File,Mod,SourceF,[P],Line),_)
; recorda('$module','$module'(user_input,Mod,user_input,[P],1),_)
).
export_resource(P0) :-
P0 = F//N, atom(F), number(N), N >= 0, !,
N1 is N+2, P = F/N1,
'$current_module'(Mod),
( recorded('$module','$module'(File,Mod,SourceF,ExportedPreds,Line),R) ->
erase(R),
recorda('$module','$module'(File,Mod,SourceF,[P|ExportedPreds],Line ),_)
; prolog_load_context(file, File) ->
recorda('$module','$module'(File,Mod,SourceF,[P],Line),_)
; recorda('$module','$module'(user_input,Mod,user_input,[P],1),_)
).
export_resource(op(Prio,Assoc,Name)) :- !,
op(Prio,Assoc,prolog:Name).
export_resource(op(Prio,Assoc,Name)) :- !,
op(Prio,Assoc,user:Name).
export_resource(Resource) :-
'$do_error'(type_error(predicate_indicator,Resource),export(Resource)).
export_list(Module, List) :-
recorded('$module','$module'(_,Module,_,List,_),_).
'$add_to_imports'([], _, _).
% no need to import from the actual module
'$add_to_imports'([T|Tab], Module, ContextModule) :-
'$do_import'(T, Module, ContextModule),
'$add_to_imports'(Tab, Module, ContextModule).
'$do_import'(op(Prio,Assoc,Name), _Mod, ContextMod) :-
op(Prio,Assoc,ContextMod:Name).
'$do_import'(N0/K0-N0/K0, Mod, Mod) :- !.
'$do_import'(N0/K0-N0/K0, _Mod, prolog) :- !.
'$do_import'(_N/K-N1/K, _Mod, ContextMod) :-
recorded('$module','$module'(_F, ContextMod, _SourceF, MyExports,_),_),
once(lists:member(N1/K, MyExports)),
functor(S, N1, K),
% reexport predicates if they are undefined in the current module.
\+ '$undefined'(S,ContextMod), !.
'$do_import'( N/K-N1/K, Mod, ContextMod) :-
functor(G,N,K),
'$follow_import_chain'(Mod,G,M0,G0),
G0=..[_N0|Args],
G1=..[N1|Args],
( '$check_import'(M0,ContextMod,N1,K) ->
( ContextMod == prolog ->
recordzifnot('$import','$import'(M0,user,G0,G1,N1,K),_),
fail
;
recordaifnot('$import','$import'(M0,ContextMod,G0,G1,N1,K),_),
fail
;
true
)
;
true
).
'$follow_import_chain'(M,G,M0,G0) :-
recorded('$import','$import'(M1,M,G1,G,_,_),_), M \= M1, !,
'$follow_import_chain'(M1,G1,M0,G0).
'$follow_import_chain'(M,G,M,G).
% trying to import Mod:N/K into ContextM
'$check_import'(Mod, ContextM, N, K) :-
recorded('$import','$import'(MI, ContextM, _, _, N,K),_R),
% dereference MI to M1, in order to find who
% is actually generating
( '$module_produced by'(M1, MI, N, K) -> true ; MI = M1 ),
( '$module_produced by'(M2, Mod, N, K) -> true ; Mod = M2 ),
M2 \= M1, !,
'$redefine_import'( M1, M2, Mod, ContextM, N/K).
'$check_import'(_,_,_,_).
'$redefine_import'( M1, M2, Mod, ContextM, N/K) :-
'$nb_getval'('$lf_status', TOpts, fail),
'$lf_opt'(redefine_module, TOpts, Action), !,
'$redefine_action'(Action, M1, M2, Mod, ContextM, N/K).
'$redefine_import'( M1, M2, Mod, ContextM, N/K) :-
'$redefine_action'(false, M1, M2, Mod, ContextM, N/K).
'$redefine_action'(ask, M1, M2, M, _, N/K) :-
stream_property(user_input,tty(true)), !,
format(user_error,'NAME CLASH: ~w was already imported to module ~w;~n',[M1:N/K,M2]),
format(user_error,' Do you want to import it from ~w ? [y, n, e or h] ',M),
'$mod_scan'(C),
( C == e -> halt(1) ;
C == y ).
'$redefine_action'(true, M1, _, _, _, _) :- !,
recorded('$module','$module'(F, M1, _, _MyExports,_Line),_),
unload_file(F).
'$redefine_action'(false, M1, M2, _M, ContextM, N/K) :-
recorded('$module','$module'(F, ContextM, _, _MyExports,_Line),_),
'$current_module'(_, M2),
'$do_error'(permission_error(import,M1:N/K,redefined,M2),F).
'$mod_scan'(C) :-
get_char(C),
'$skipeol'(C),
(C == y -> true; C == n).
/**
@pred set_base_module( +ExportingModule ) is det
All exported predicates from _ExportingModule_ are automatically available to the
current source module.
This built-in was introduced by SWI-Prolog. In YAP, by default, modules only
inherit from `prolog`. This extension allows predicates in the current
module (see module/2 and module/1) to inherit from `user` or other modules.
*/
set_base_module(ExportingModule) :-
var(ExportingModule),
'$do_error'(instantiation_error,set_base_module(ExportingModule)).
set_base_module(ExportingModule) :-
atom(ExportingModule), !,
'$current_module'(Mod),
retractall(prolog:'$parent_module'(Mod,_)),
asserta(prolog:'$parent_module'(Mod,ExportingModule)).
set_base_module(ExportingModule) :-
'$do_error'(type_error(atom,ExportingModule),set_base_module(ExportingModule)).
/**
* @pred import_module( +ImportingModule, +ExportingModule ) is det
* All exported predicates from _ExportingModule_
* are automatically available to the
* source module _ImportModule_.
This innovation was introduced by SWI-Prolog. By default, modules only
inherit from `prolog` and `user`. This extension allows predicates in
any module to inherit from `user` and other modules.
*/
import_module(Mod, ImportModule) :-
var(Mod),
'$do_error'(instantiation_error,import_module(Mod, ImportModule)).
import_module(Mod, ImportModule) :-
atom(Mod), !,
prolog:'$parent_module'(Mod,ImportModule).
import_module(Mod, EM) :-
'$do_error'(type_error(atom,Mod),import_module(Mod, EM)).
/**
@pred add_import_module( + _Module_, + _ImportModule_ , +_Pos_) is det
Add all exports in _ImportModule_ as available to _Module_.
All exported predicates from _ExportModule_ are made available to the
source module _ImportModule_. If _Position_ is bound to `start` the
module _ImportModule_ is tried first, if _Position_ is bound to `end`,
the module is consulted last.
*/
add_import_module(Mod, ImportModule, Pos) :-
var(Mod),
'$do_error'(instantiation_error,add_import_module(Mod, ImportModule, Pos)).
add_import_module(Mod, ImportModule, Pos) :-
var(Pos),
'$do_error'(instantiation_error,add_import_module(Mod, ImportModule, Pos)).
add_import_module(Mod, ImportModule, start) :-
atom(Mod), !,
retractall(prolog:'$parent_module'(Mod,ImportModule)),
asserta(prolog:'$parent_module'(Mod,ImportModule)).
add_import_module(Mod, ImportModule, end) :-
atom(Mod), !,
retractall(prolog:'$parent_module'(Mod,ImportModule)),
assertz(prolog:'$parent_module'(Mod,ImportModule)).
add_import_module(Mod, ImportModule, Pos) :-
\+ atom(Mod), !,
'$do_error'(type_error(atom,Mod),add_import_module(Mod, ImportModule, Pos)).
add_import_module(Mod, ImportModule, Pos) :-
'$do_error'(domain_error(start_end,Pos),add_import_module(Mod, ImportModule, Pos)).
/**
@pred delete_import_module( + _ExportModule_, + _ImportModule_ ) is det
Exports in _ImportModule_ are no longer available to _Module_.
All exported predicates from _ExportModule_ are discarded from the
ones used vy the source module _ImportModule_.
*/
delete_import_module(Mod, ImportModule) :-
var(Mod),
'$do_error'(instantiation_error,delete_import_module(Mod, ImportModule)).
delete_import_module(Mod, ImportModule) :-
var(ImportModule),
'$do_error'(instantiation_error,delete_import_module(Mod, ImportModule)).
delete_import_module(Mod, ImportModule) :-
atom(Mod),
atom(ImportModule), !,
retractall(prolog:'$parent_module'(Mod,ImportModule)).
delete_import_module(Mod, ImportModule) :-
\+ atom(Mod), !,
'$do_error'(type_error(atom,Mod),delete_import_module(Mod, ImportModule)).
delete_import_module(Mod, ImportModule) :-
'$do_error'(type_error(atom,ImportModule),delete_import_module(Mod, ImportModule)).
'$set_source_module'(Source0, SourceF) :-
prolog_load_context(module, Source0), !,
module(SourceF).
'$set_source_module'(Source0, SourceF) :-
current_module(Source0, SourceF).
/**
@pred module_property( +Module, ? _Property_ ) is nondet
Enumerate non-deterministically the main properties of _Module_ .
Reports the following properties of _Module_:
+ `class`( ?_Class_ ): whether it is a `system`, `library`, or `user` module.
+ `line_count`(?_Ls_): number of lines in source file (if there is one).
+ `file`(?_F_): source file for _Module_ (if there is one).
+ `exports`(-Es): list of all predicate symbols and
operator symbols exported or re-exported by this module.
*/
module_property(Mod, Prop) :-
var(Mod),
!,
recorded('$module','$module'(_,Mod,_,_Es,_),_),
module_property(Mod, Prop).
module_property(Mod, class(L)) :-
'$module_class'(Mod, L).
module_property(Mod, line_count(L)) :-
recorded('$module','$module'(_F,Mod,_,_,L),_).
module_property(Mod, file(F)) :-
recorded('$module','$module'(F,Mod,_,_,_),_).
module_property(Mod, exports(Es)) :-
(
recorded('$module','$module'(_,Mod,_,Es,_),_)
->
true
;
Mod==user
->
findall( P, (current_predicate(user:P)), Es)
;
Mod==prolog
->
findall( N/A, (predicate_property(Mod:P0, public),functor(P0,N,A)), Es)
).
'$module_class'( Mod, system) :- '$is_system_module'( Mod ), !.
'$module_class'( Mod, library) :- '$library_module'( Mod ), !.
'$module_class'(_Mod, user) :- !.
'$module_class'( _, temporary) :- fail.
'$module_class'( _, test) :- fail.
'$module_class'( _, development) :- fail.
'$library_module'(M1) :-
recorded('$module','$module'(_, M1, library(_), _MyExports,_Line),_).
ls_imports :-
recorded('$import','$import'(M0,M,G0,G,_N,_K),_R),
numbervars(G0+G, 0, _),
format('~a:~w <- ~a:~w~n', [M, G, M0, G0]),
fail.
ls_imports.
unload_module(Mod) :-
clause( '$meta_predicate'(_F,Mod,_N,_P), _, R),
erase(R),
fail.
unload_module(Mod) :-
recorded('$multifile_defs','$defined'(_FileName,_Name,_Arity,Mod), R),
erase(R),
fail.
unload_module(Mod) :-
recorded( '$foreign', Mod:_Foreign, R),
erase(R),
fail.
% remove imported modules
unload_module(Mod) :-
setof( M, recorded('$import',_G0^_G^_N^_K^_R^'$import'(Mod,M,_G0,_G,_N,_K),_R), Ms),
recorded('$module','$module'( _, Mod, _, _, Exports), _),
lists:member(M, Ms),
current_op(X, Y, M:Op),
lists:member( op(X, Y, Op), Exports ),
op(X, 0, M:Op),
fail.
unload_module(Mod) :-
recorded('$module','$module'( _, Mod, _, _, Exports), _),
lists:member( op(X, _Y, Op), Exports ),
op(X, 0, Mod:Op),
fail.
unload_module(Mod) :-
current_predicate(Mod:P),
abolish(P),
fail.
unload_module(Mod) :-
recorded('$import','$import'(Mod,_M,_G0,_G,_N,_K),R),
erase(R),
fail.
unload_module(Mod) :-
recorded('$module','$module'( _, Mod, _, _, _), R),
erase(R),
fail.
/* debug */
module_state :-
recorded('$module','$module'(HostF,HostM,SourceF, Everything, Line),_),
format('HostF ~a, HostM ~a, SourceF ~w, Line ~d,~n Everything ~w.~n', [HostF,HostM,SourceF, Line, Everything]),
recorded('$import','$import'(HostM,M,G0,G,_N,_K),_R),
format(' ~w:~w :- ~w:~w.~n',[M,G,HostM,G0]),
fail.
module_state.

View File

@@ -1,246 +0,0 @@
/**
@pred module(+M) is det
set the type-in module
Defines _M_ to be the current working or type-in module. All files
which are not bound to a module are assumed to belong to the working
module (also referred to as type-in module). To compile a non-module
file into a module which is not the working one, prefix the file name
with the module name, in the form ` _Module_: _File_`, when
loading the file.
**/
module(N) :-
var(N),
'$do_error'(instantiation_error,module(N)).
module(N) :-
atom(N), !,
% set it as current module.
'$current_module'(_,N).
module(N) :-
'$do_error'(type_error(atom,N),module(N)).
/**
\pred module(+ Module:atom, +ExportList:list) is directive
define a new module
This directive defines the file where it appears as a _module file_;
it must be the first declaration in the file. _Module_ must be an
atom specifying the module name; _ExportList_ must be a list
containing the module's public predicates specification, in the form
`[predicate_name/arity,...]`. The _ExportList_ can include
operator declarations for operators that are exported by the module.
The public predicates of a module file can be made accessible to other
files through loading the source file, using the directives
use_module/1 or use_module/2,
ensure_loaded/1 and the predicates
consult/1 or reconsult/1. The
non-public predicates of a module file are not supposed to be visible
to other modules; they can, however, be accessed by prefixing the module
name with the `:/2` operator.
**/
'$module_dec'(system(N, Ss), Ps) :- !,
new_system_module(N),
'$mk_system_predicates'( Ss , N ),
'$module_dec'(N, Ps).
'$module_dec'(system(N), Ps) :- !,
new_system_module(N),
% '$mk_system_predicates'( Ps , N ),
'$module_dec'(N, Ps).
'$module_dec'(N, Ps) :-
source_location(F,Line),
'$nb_getval'( '$user_source_file', F0 , fail),
'$add_module_on_file'(N, F, Line,F0, Ps),
'$current_module'(_M0,N).
'$mk_system_predicates'( Ps, _N ) :-
lists:member(Name/A , Ps),
'$new_system_predicate'(Name, A, prolog),
fail.
'$mk_system_predicates'( _Ps, _N ).
/*
declare_module(Mod) -->
arguments(file(+file:F),
line(+integer:L),
parent(+module:P),
type(+module_type:T),
exports(+list(exports):E),
Props, P0) -> true ; Props = P0),
( deleteline(L), P0, P1) -> true ; P0 == P1),
( delete(parent(P), P1, P2) -> true ; P1 == P2),
( delete(line(L), P2, P3) -> true ; P3 == P4),
( delete(file(F), Props, P0) -> true ; Props = P0),
( delete(file(F), Props, P0) -> true ; Props = P0),
( delete(file(F), Props, P0) -> true ; Props = P0),
de
*/
'$module'(_,N,P) :-
'$module_dec'(N,P).
/** set_module_property( +Mod, +Prop)
Set a property for a module. Currently this includes:
- base module, a module from where we automatically import all definitions, see add_import_module/2.
- the export list
- module class is currently ignored.
*/
set_module_property(Mod, base(Base)) :-
must_be_of_type( module, Mod),
add_import_module(Mod, Base, start).
set_module_property(Mod, exports(Exports)) :-
must_be_of_type( module, Mod),
'$add_module_on_file'(Mod, user_input, 1, '/dev/null', Exports).
set_module_property(Mod, exports(Exports, File, Line)) :-
must_be_of_type( module, Mod),
'$add_module_on_file'(Mod, File, Line, '/dev/null', Exports).
set_module_property(Mod, class(Class)) :-
must_be_of_type( module, Mod),
must_be_of_type( atom, Class).
'$add_module_on_file'(DonorMod, DonorF, _LineF, SourceF, Exports) :-
recorded('$module','$module'(OtherF, DonorMod, _, _, _, _),R),
% the module has been found, are we reconsulting?
(
DonorF \= OtherF
->
'$do_error'(permission_error(module,redefined,DonorMod, OtherF, DonorF),module(DonorMod,Exports))
;
recorded('$module','$module'(DonorF,DonorMod, SourceF, _, _, _), R),
erase( R ),
fail
).
'$add_module_on_file'(DonorM, DonorF, Line, SourceF, Exports) :-
'$current_module'( HostM ),
( recorded('$module','$module'( HostF, HostM, _, _, _, _),_) -> true ; HostF = user_input ),
% first build the initial export table
'$convert_for_export'(all, Exports, DonorM, HostM, TranslationTab, AllExports0, load_files),
sort( AllExports0, AllExports ),
'$add_to_imports'(TranslationTab, DonorM, DonorM), % insert ops, at least for now
% last, export everything to the host: if the loading crashed you didn't actually do
% no evil.
recorda('$module','$module'(DonorF,DonorM,SourceF, AllExports, Line),_),
( recorded('$source_file','$source_file'( DonorF, Time, _), R), erase(R),
recorda('$source_file','$source_file'( DonorF, Time, DonorM), _) ).
'$convert_for_export'(all, Exports, _Module, _ContextModule, Tab, MyExports, _) :-
'$simple_conversion'(Exports, Tab, MyExports).
'$convert_for_export'([], Exports, Module, ContextModule, Tab, MyExports, Goal) :-
'$clean_conversion'([], Exports, Module, ContextModule, Tab, MyExports, Goal).
'$convert_for_export'([P1|Ps], Exports, Module, ContextModule, Tab, MyExports, Goal) :-
'$clean_conversion'([P1|Ps], Exports, Module, ContextModule, Tab, MyExports, Goal).
'$convert_for_export'(except(Excepts), Exports, Module, ContextModule, Tab, MyExports, Goal) :-
'$neg_conversion'(Excepts, Exports, Module, ContextModule, MyExports, Goal),
'$simple_conversion'(MyExports, Tab, _).
'$simple_conversion'([], [], []).
'$simple_conversion'([F/N|Exports], [F/N-F/N|Tab], [F/N|E]) :-
'$simple_conversion'(Exports, Tab, E).
'$simple_conversion'([F//N|Exports], [F/N2-F/N2|Tab], [F/N2|E]) :-
N2 is N+1,
'$simple_conversion'(Exports, Tab, E).
'$simple_conversion'([F/N as NF|Exports], [F/N-NF/N|Tab], [NF/N|E]) :-
'$simple_conversion'(Exports, Tab, E).
'$simple_conversion'([F//N as NF|Exports], [F/N2-NF/N2|Tab], [NF/N2|E]) :-
N2 is N+1,
'$simple_conversion'(Exports, Tab, E).
'$simple_conversion'([op(Prio,Assoc,Name)|Exports], [op(Prio,Assoc,Name)|Tab], [op(Prio,Assoc,Name)|E]) :-
'$simple_conversion'(Exports, Tab, E).
'$clean_conversion'([], _, _, _, [], [], _).
'$clean_conversion'([(N1/A1 as N2)|Ps], List, Module, ContextModule, [N1/A1-N2/A1|Tab], [N2/A1|MyExports], Goal) :- !,
( lists:memberchk(N1/A1, List)
->
true
;
'$bad_export'((N1/A1 as N2), Module, ContextModule)
),
'$clean_conversion'(Ps, List, Module, ContextModule, Tab, MyExports, Goal).
'$clean_conversion'([N1/A1|Ps], List, Module, ContextModule, [N1/A1-N1/A1|Tab], [N1/A1|MyExports], Goal) :- !,
(
lists:memberchk(N1/A1, List)
->
true
;
'$bad_export'(N1/A1, Module, ContextModule)
),
'$clean_conversion'(Ps, List, Module, ContextModule, Tab, MyExports, Goal).
'$clean_conversion'([N1//A1|Ps], List, Module, ContextModule, [N1/A2-N1/A2|Tab], [N1/A2|MyExports], Goal) :- !,
A2 is A1+2,
(
lists:memberchk(N1/A2, List)
->
true
;
'$bad_export'(N1//A1, Module, ContextModule)
),
'$clean_conversion'(Ps, List, Module, ContextModule, Tab, MyExports, Goal).
'$clean_conversion'([N1//A1 as N2|Ps], List, Module, ContextModule, [N2/A2-N1/A2|Tab], [N2/A2|MyExports], Goal) :- !,
A2 is A1+2,
(
lists:memberchk(N2/A2, List)
->
true
;
'$bad_export'((N1//A1 as A2), Module, ContextModule)
),
'$clean_conversion'(Ps, List, Module, ContextModule, Tab, MyExports, Goal).
'$clean_conversion'([op(Prio,Assoc,Name)|Ps], List, Module, ContextModule, [op(Prio,Assoc,Name)|Tab], [op(Prio,Assoc,Name)|MyExports], Goal) :- !,
(
lists:memberchk(op(Prio,Assoc,Name), List)
->
true
;
'$bad_export'(op(Prio,Assoc,Name), Module, ContextModule)
),
'$clean_conversion'(Ps, List, Module, ContextModule, Tab, MyExports, Goal).
'$clean_conversion'([P|_], _List, _, _, _, _, Goal) :-
'$do_error'(domain_error(module_export_predicates,P), Goal).
'$bad_export'(_, _Module, _ContextModule) :- !.
'$bad_export'(Name/Arity, Module, ContextModule) :-
functor(P, Name, Arity),
predicate_property(Module:P, _), !,
print_message(warning, declaration(Name/Arity, Module, ContextModule, private)).
'$bad_export'(Name//Arity, Module, ContextModule) :-
Arity2 is Arity+2,
functor(P, Name, Arity2),
predicate_property(Module:P, _), !,
print_message(warning, declaration(Name/Arity, Module, ContextModule, private)).
'$bad_export'(Indicator, Module, ContextModule) :- !,
print_message(warning, declaration( Indicator, Module, ContextModule, undefined)).
'$neg_conversion'([], Exports, _, _, Exports, _).
'$neg_conversion'([N1/A1|Ps], List, Module, ContextModule, MyExports, Goal) :- !,
(
lists:delete(List, N1/A1, RList)
->
'$neg_conversion'(Ps, RList, Module, ContextModule, MyExports, Goal)
;
'$bad_export'(N1/A1, Module, ContextModule)
).
'$neg_conversion'([N1//A1|Ps], List, Module, ContextModule, MyExports, Goal) :- !,
A2 is A1+2,
(
lists:delete(List, N1/A2, RList)
->
'$neg_conversion'(Ps, RList, Module, ContextModule, MyExports, Goal)
;
'$bad_export'(N1//A1, Module, ContextModule)
).
'$neg_conversion'([op(Prio,Assoc,Name)|Ps], List, Module, ContextModule, MyExports, Goal) :- !,
(
lists:delete(List, op(Prio,Assoc,Name), RList)
->
'$neg_conversion'(Ps, RList, Module, ContextModule, MyExports, Goal)
;
'$bad_export'(op(Prio,Assoc,Name), Module, ContextModule)
).
'$clean_conversion'([P|_], _List, _, _, _, Goal) :-
'$do_error'(domain_error(module_export_predicates,P), Goal).

View File

@@ -1,222 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
*************************************************************************/
:- system_module( '$os', [
cd/0,
cd/1,
getcwd/1,
ls/0,
pwd/0,
unix/1,
putenv/2,
getenv/2,
setenv/2
], [] ).
:- use_system_module( '$_errors', ['$do_error'/2]).
/**
@defgroup YAPOS Access to Operating System Functionality
@ingroup builtins
The following built-in predicates allow access to underlying
Operating System functionality.
%% @{
*/
/** @pred cd
Changes the current directory (on UNIX environments) to the user's home directory.
*/
cd :-
cd('~').
/** @pred cd(+ _D_)
Changes the current directory (on UNIX environments).
*/
cd(F) :-
absolute_file_name(F, Dir, [file_type(directory),file_errors(fail),access(execute),expand(true)]),
working_directory(_, Dir).
/** @pred getcwd(- _D_)
Unify the current directory, represented as an atom, with the argument
_D_.
*/
getcwd(Dir) :- working_directory(Dir, Dir).
/** @pred ls
Prints a list of all files in the current directory.
*/
ls :-
getcwd(X),
'$load_system_ls'(X,L),
'$do_print_files'(L).
'$load_system_ls'(X,L) :-
'$undefined'(directory_files(X, L), system),
load_files(library(system),[silent(true)]),
fail.
'$load_system_ls'(X,L) :-
system:directory_files(X, L).
'$do_print_files'([]) :-
nl.
'$do_print_files'([F| Fs]) :-
'$do_print_file'(F),
'$do_print_files'(Fs).
'$do_print_file'('.') :- !.
'$do_print_file'('..') :- !.
'$do_print_file'(F) :- atom_concat('.', _, F), !.
'$do_print_file'(F) :-
write(F), write(' ').
/** @pred pwd
Prints the current directory.
*/
pwd :-
getcwd(X),
write(X), nl.
/** @pred unix(+ _S_)
Access to Unix-like functionality:
+ argv/1
Return a list of arguments to the program. These are the arguments that
follow a `--`, as in the usual Unix convention.
+ cd/0
Change to home directory.
+ cd/1
Change to given directory. Acceptable directory names are strings or
atoms.
+ environ/2
If the first argument is an atom, unify the second argument with the
value of the corresponding environment variable.
+ getcwd/1
Unify the first argument with an atom representing the current directory.
+ putenv/2
Set environment variable _E_ to the value _S_. If the
environment variable _E_ does not exist, create a new one. Both the
environment variable and the value must be atoms.
+ shell/1
Execute command under current shell. Acceptable commands are strings or
atoms.
+ system/1
Execute command with `/bin/sh`. Acceptable commands are strings or
atoms.
+ shell/0
Execute a new shell.
*/
unix(V) :- var(V), !,
'$do_error'(instantiation_error,unix(V)).
unix(argv(L)) :-
current_prolog_flag(argv, L).
unix(cd) :- cd('~').
unix(cd(A)) :- cd(A).
unix(environ(X,Y)) :- '$do_environ'(X,Y).
unix(getcwd(X)) :- getcwd(X).
unix(shell(V)) :- var(V), !,
'$do_error'(instantiation_error,unix(shell(V))).
unix(shell(A)) :- atom(A), !, '$shell'(A).
unix(shell(A)) :- string(A), !, '$shell'(A).
unix(shell(V)) :-
'$do_error'(type_error(atomic,V),unix(shell(V))).
unix(system(V)) :- var(V), !,
'$do_error'(instantiation_error,unix(system(V))).
unix(system(A)) :- atom(A), !, system(A).
unix(system(A)) :- string(A), !, system(A).
unix(system(V)) :-
'$do_error'(type_error(atom,V),unix(system(V))).
unix(shell) :- sh.
unix(putenv(X,Y)) :- '$putenv'(X,Y).
'$is_list_of_atoms'(V,_) :- var(V),!.
'$is_list_of_atoms'([],_) :- !.
'$is_list_of_atoms'([H|L],L0) :- !,
'$check_if_head_may_be_atom'(H,L0),
'$is_list_of_atoms'(L,L0).
'$is_list_of_atoms'(H,L0) :-
'$do_error'(type_error(list,H),unix(argv(L0))).
'$check_if_head_may_be_atom'(H,_) :-
var(H), !.
'$check_if_head_may_be_atom'(H,_) :-
atom(H), !.
'$check_if_head_may_be_atom'(H,L0) :-
'$do_error'(type_error(atom,H),unix(argv(L0))).
'$do_environ'(X, Y) :-
var(X), !,
'$do_error'(instantiation_error,unix(environ(X,Y))).
'$do_environ'(X, Y) :- atom(X), !,
'$getenv'(X,Y).
'$do_environ'(X, Y) :-
'$do_error'(type_error(atom,X),unix(environ(X,Y))).
/** @pred putenv(+ _E_,+ _S_)
Set environment variable _E_ to the value _S_. If the
environment variable _E_ does not exist, create a new one. Both the
environment variable and the value must be atoms.
*/
putenv(Na,Val) :-
'$putenv'(Na,Val).
getenv(Na,Val) :-
'$getenv'(Na,Val).
/** @pred setenv(+ _Name_,+ _Value_)
Set environment variable. _Name_ and _Value_ should be
instantiated to atoms or integers. The environment variable will be
passed to `shell/[0-2]` and can be requested using `getenv/2`.
They also influence expand_file_name/2.
*/
setenv(Na,Val) :-
'$putenv'(Na,Val).
/**
@}
*/

View File

@@ -1,189 +0,0 @@
/**
@defgroup pathconf Configuration of the Prolog file search path
@ingroup AbsoluteFileName
Prolog systems search follow a complex search on order to track down files.
@{
**/
:- module(user).
/**
@pred library_directory(?Directory:atom) is nondet, dynamic
Dynamic, multi-file predicate that succeeds when _Directory_ is a
current library directory name. Asserted in the user module.
Library directories are the places where files specified in the form
`library( _File_ )` are searched by the predicates consult/1,
reconsult/1, use_module/1, ensure_loaded/1, and load_files/2.
This directory is initialized by a rule that calls the system predicate
system_library/1.
*/
:- multifile library_directory/1.
:- dynamic library_directory/1.
%% Specifies the set of directories where
% one can find Prolog libraries.
%
library_directory(Home) :-
current_prolog_flag(prolog_library_directory, Home),
Home \= ''.
% 1. honor YAPSHAREDIR
library_directory( Dir ) :-
getenv( 'YAPSHAREDIR', Dir).
%% 2. honor user-library
library_directory( '~/share/Yap' ).
%% 3. honor current directory
library_directory( '.' ).
%% 4. honor default location.
library_directory( Dir ) :-
system_library( Dir ).
/**
@pred commons_directory(? _Directory_:atom) is nondet, dynamic
State the location of the Commons Prolog Initiative.
This directory is initialized as a rule that calls the system predicate
library_directories/2.
*/
:- dynamic commons_directory/1.
:- multifile commons_directory/1.
commons_directory( Path ):-
system_commons( Path ).
/**
@pred foreign_directory(? _Directory_:atom) is nondet, dynamic
State the location of the Foreign Prolog Initiative.
This directory is initialized as a rule that calls the system predicate
library_directories/2.
*/
:- multifile foreign_directory/1.
:- dynamic foreign_directory/1.
%foreign_directory( Path ):-
foreign_directory(Home) :-
current_prolog_flag(prolog_foreign_directory, Home),
Home \= ''.
foreign_directory( '.').
foreign_directory(yap('lib/Yap')).
foreign_directory( Path ):-
system_foreign( Path ).
/**
@pred prolog_file_type(?Suffix:atom, ?Handler:atom) is nondet, dynamic
This multifile/dynamic predicate relates a file extension _Suffix_
to a language or file type _Handler_. By
default, it supports the extensions yap, pl, and prolog for prolog files and
uses one of dll, so, or dylib for shared objects. Initial definition is:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~prolog
prolog_file_type(yap, prolog).
prolog_file_type(pl, prolog).
prolog_file_type(prolog, prolog).
prolog_file_type(qly, prolog).
prolog_file_type(qly, qly).
prolog_file_type(A, prolog) :-
current_prolog_flag(associate, A),
A \== prolog,
A \==pl,
A \== yap.
prolog_file_type(A, executable) :-
current_prolog_flag(shared_object_extension, A).
prolog_file_type(pyd, executable).
~~~~~~~~~~~~~~~~~~~~~
*/
:- dynamic prolog_file_type/2.
prolog_file_type(yap, prolog).
prolog_file_type(pl, prolog).
prolog_file_type(prolog, prolog).
prolog_file_type(A, prolog) :-
current_prolog_flag(associate, A),
A \== prolog,
A \== pl,
A \== yap.
prolog_file_type(qly, qly).
prolog_file_type(A, executable) :-
current_prolog_flag(shared_object_extension, A).
prolog_file_type(pyd, executable).
/**
@pred file_search_path(+Name:atom, -Directory:atom) is nondet
Allows writing file names as compound terms. The _Name_ and
_DIRECTORY_ must be atoms. The predicate may generate multiple
solutions. The predicate is originally defined as follows:
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~prolog
file_search_path(library, Dir) :-
library_directory(Dir).
file_search_path(commons, Dir) :-
commons_directory(Dir).
file_search_path(swi, Home) :-
current_prolog_flag(home, Home).
file_search_path(yap, Home) :-
current_prolog_flag(home, Home).
file_search_path(system, Dir) :-
prolog_flag(host_type, Dir).
file_search_path(foreign, Dir) :-
foreign_directory(Dir).
file_search_path(executable, Dir) :-
foreign_directory(Dir).
file_search_path(path, C) :-
( getenv('PATH', A),
( current_prolog_flag(windows, true)
-> atomic_list_concat(B, ;, A)
; atomic_list_concat(B, :, A)
),
lists:member(C, B)
).
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Thus, `compile(library(A))` will search for a file using
library_directory/1 to obtain the prefix,
whereas 'compile(system(A))` would look at the `host_type` flag.
*/
:- multifile file_search_path/2.
:- dynamic file_search_path/2.
file_search_path(library, Dir) :-
library_directory(Dir).
file_search_path(commons, Dir) :-
commons_directory(Dir).
file_search_path(swi, Home) :-
current_prolog_flag(home, Home).
file_search_path(yap, Home) :-
current_prolog_flag(home, Home).
file_search_path(system, Dir) :-
prolog_flag(host_type, Dir).
file_search_path(foreign, Dir) :-
foreign_directory(Dir).
file_search_path(executable, Dir) :-
foreign_directory(Dir).
file_search_path(path, C) :-
( getenv('PATH', A),
( current_prolog_flag(windows, true)
-> atomic_list_concat(B, ;, A)
; atomic_list_concat(B, :, A)
),
lists:member(C, B)
).
%% @}

View File

@@ -1,270 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: preds.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: Predicate Manipulation for YAP: declaration support *
* *
*************************************************************************/
:- system_module( '$_preddecls', [(discontiguous)/1,
(dynamic)/1,
(multifile)/1,
(discontiguous)/1], ['$check_multifile_pred'/3,
'$discontiguous'/2,
'$dynamic'/2]).
:- use_system_module( '$_consult', ['$add_multifile'/3]).
:- use_system_module( '$_errors', ['$do_error'/2]).
'$log_upd'(1).
/**
@defgroup YAPPredDecls Declaring Properties of Predicates
@ingroup YAPCompilerSettings
The YAP Compiler allows the programmer to include declarations with
important pproprties of predicates, such as where they can be modified
during execution time, whether they are meta-predicates, or whether they can be
defined across multiple files. We next join some of these declarations.
*/
%
% can only do as goal in YAP mode.
%
/** @pred dynamic( + _P_ )
Declares predicate _P_ or list of predicates [ _P1_,..., _Pn_]
as a dynamic predicate. _P_ must be written as a predicate indicator, that is in form
_Name/Arity_ or _Module:Name/Arity_.
~~~~~
:- dynamic god/1.
~~~~~
a more convenient form can be used:
~~~~~
:- dynamic son/3, father/2, mother/2.
~~~~~
or, equivalently,
~~~~~
:- dynamic [son/3, father/2, mother/2].
~~~~~
Note:
a predicate is assumed to be dynamic when
asserted before being defined.
*/
dynamic(X) :-
current_prolog_flag(language, yap), !,
'$current_module'(M),
'$dynamic'(X, M).
dynamic(X) :-
'$do_error'(context_error(dynamic(X),declaration),query).
'$dynamic'(X,M) :- var(X), !,
'$do_error'(instantiation_error,dynamic(M:X)).
'$dynamic'(X,M) :- var(M), !,
'$do_error'(instantiation_error,dynamic(M:X)).
'$dynamic'(Mod:Spec,_) :- !,
'$dynamic'(Spec,Mod).
'$dynamic'([], _) :- !.
'$dynamic'([H|L], M) :- !, '$dynamic'(H, M), '$dynamic'(L, M).
'$dynamic'((A,B),M) :- !, '$dynamic'(A,M), '$dynamic'(B,M).
'$dynamic'(A//N,Mod) :- integer(N), !,
N1 is N+2,
'$dynamic'(A/N1,Mod).
'$dynamic'(A/N,Mod) :-
functor(G, A, N),
'$mk_d'(G,Mod).
/** @pred public( _P_ ) is iso
Instructs the compiler that the source of a predicate of a list of
predicates _P_ must be kept. This source is then accessible through
the clause/2 procedure and through the `listing` family of
built-ins.
Note that all dynamic procedures are public. The `source` directive
defines all new or redefined predicates to be public.
**/
'$public'(X, _) :- var(X), !,
'$do_error'(instantiation_error,public(X)).
'$public'(Mod:Spec, _) :- !,
'$public'(Spec,Mod).
'$public'((A,B), M) :- !, '$public'(A,M), '$public'(B,M).
'$public'([],_) :- !.
'$public'([H|L], M) :- !, '$public'(H, M), '$public'(L, M).
'$public'(A//N1, Mod) :- integer(N1), !,
N is N1+2,
'$public'(A/N, Mod).
'$public'(A/N, Mod) :- integer(N), atom(A), !,
functor(T,A,N),
'$do_make_public'(T, Mod).
'$public'(X, Mod) :-
'$do_pi_error'(type_error(callable,X),dynamic(Mod:X)).
'$do_make_public'(T, Mod) :-
'$is_dynamic'(T, Mod), !. % all dynamic predicates are public.
'$do_make_public'(T, Mod) :-
'$predicate_flags'(T,Mod,F,F),
NF is F\/0x00400000,
'$predicate_flags'(T,Mod,F,NF).
/** @pred multifile( _P_ ) is iso
Declares that a predicate or several predicates may be defined
throughout several files. _P_ is a collection of one or more predicate
indicators:
~~~~~~~
:- multifile user:portray_message/2, multifile user:message_hook/3.
~~~~~~~
Instructs the compiler about the declaration of a predicate _P_ in
more than one file. It must appear in the first of the loaded files
where the predicate is declared, and before declaration of any of its
clauses.
Multifile declarations must be supported by reconsult/1 and
compile/1: when a multifile predicate is reconsulted,
only the clauses from the same file are removed.
Since YAP4.3.0 multifile procedures can be static or dynamic.
**/
multifile(P) :-
strip_module(P, OM, Pred),
'$multifile'(Pred, OM).
'$multifile'(V, _) :-
var(V),
!,
'$do_error'(instantiation_error,multifile(V)).
'$multifile'((X,Y), M) :-
!,
'$multifile'(X, M),
'$multifile'(Y, M).
'$multifile'(Mod:PredSpec, _) :-
!,
'$multifile'(PredSpec, Mod).
'$multifile'(N//A, M) :- !,
integer(A),
A1 is A+2,
'$multifile'(N/A1, M).
'$multifile'(N/A, M) :-
'$add_multifile'(N,A,M),
fail.
'$multifile'(N/A, M) :-
functor(S,N,A),
'$is_multifile'(S, M), !.
'$multifile'(N/A, M) :- !,
'$new_multifile'(N,A,M).
'$multifile'([H|T], M) :- !,
'$multifile'(H,M),
'$multifile'(T,M).
'$multifile'(P, M) :-
'$do_error'(type_error(predicate_indicator,P),multifile(M:P)).
discontiguous(V) :-
var(V), !,
'$do_error'(instantiation_error,discontiguous(V)).
discontiguous(M:F) :- !,
'$discontiguous'(F,M).
discontiguous(F) :-
'$current_module'(M),
'$discontiguous'(F,M).
'$discontiguous'(V,M) :- var(V), !,
'$do_error'(instantiation_error,M:discontiguous(V)).
'$discontiguous'((X,Y),M) :- !,
'$discontiguous'(X,M),
'$discontiguous'(Y,M).
'$discontiguous'(M:A,_) :- !,
'$discontiguous'(A,M).
'$discontiguous'(N//A1, M) :- !,
integer(A1), !,
A is A1+2,
'$discontiguous'(N/A, M).
'$discontiguous'(N/A, M) :- !,
'$new_discontiguous'(N,A,M).
'$discontiguous'(P,M) :-
'$do_error'(type_error(predicate_indicator,P),M:discontiguous(P)).
%
% did we declare multifile properly?
%
'$check_multifile_pred'(Hd, M, _) :-
functor(Hd,Na,Ar),
source_location(F, _),
recorded('$multifile_defs','$defined'(F,Na,Ar,M),_), !.
% oops, we did not.
'$check_multifile_pred'(Hd, M, Fl) :-
% so this is not a multi-file predicate any longer.
functor(Hd,Na,Ar),
NFl is \(0x20000000) /\ Fl,
'$predicate_flags'(Hd,M,Fl,NFl),
'$warn_mfile'(Na,Ar).
'$warn_mfile'(F,A) :-
write(user_error,'% Warning: predicate '),
write(user_error,F/A), write(user_error,' was a multifile predicate '),
write(user_error,' (line '),
'$start_line'(LN), write(user_error,LN),
write(user_error,')'),
nl(user_error).
'$is_public'(T, Mod) :-
'$is_dynamic'(T, Mod), !. % all dynamic predicates are public.
'$is_public'(T, Mod) :-
'$predicate_flags'(T,Mod,F,F),
F\/0x00400000 =\= 0.
/**
@pred module_transparent( + _Preds_ ) is directive
_Preds_ is a list of predicates that can access the calling context.
This predicate was implemented to achieve compatibility with the older
module expansion system in SWI-Prolog. Please use meta_predicate/1 for
new code.
_Preds_ is a comma separated sequence of name/arity predicate
indicators (like in dynamic/1). Each goal associated with a
transparent declared predicate will inherit the context module from
its caller.
*/
:- dynamic('$module_transparent'/4).
'$module_transparent'((P,Ps), M) :- !,
'$module_transparent'(P, M),
'$module_transparent'(Ps, M).
'$module_transparent'(M:D, _) :- !,
'$module_transparent'(D, M).
'$module_transparent'(F/N, M) :-
'$module_transparent'(F,M,N,_), !.
'$module_transparent'(F/N, M) :-
functor(P,F,N),
asserta(prolog:'$module_transparent'(F,M,N,P)),
'$predicate_flags'(P, M, Fl, Fl),
NFlags is Fl \/ 0x200004,
'$predicate_flags'(P, M, Fl, NFlags).

View File

@@ -1,350 +0,0 @@
% The next predicates are applicable only
% to dynamic code
/** @file preddyns.yap */
/**
* @ingroup Database
* @{
Next follow the main operations on dynamic predicates.
*/
/** @pred asserta(+ _C_) is iso
Adds clause _C_ to the beginning of the program. If the predicate is
undefined, it is declared dynamic (see dynamic/1).
*/
asserta(Clause) :-
'$assert'(Clause, asserta, _).
/** @pred assertz(+ _C_) is iso
Adds clause _C_ to the end of the program. If the predicate is
undefined, it is declared dynamic (see dynamic/1).
Most Prolog systems only allow asserting clauses for dynamic
predicates. This is also as specified in the ISO standard. YAP also allows
asserting clauses for static predicates, under the restriction that the static predicate may not be live in the stacks.
*/
assertz(Clause) :-
'$assert'(Clause, assertz, _).
/** @pred assert(+ _C_)
Same as assertz/1. Adds clause _C_ to the program. If the predicate is undefined,
declare it as dynamic. New code should use assertz/1 for better portability.
Most Prolog systems only allow asserting clauses for dynamic
predicates. This is also as specified in the ISO standard. YAP allows
asserting clauses for static predicates, as long as the predicate is not
in use and the language flag is <tt>cprolog</tt>. Note that this feature is
deprecated, if you want to assert clauses for static procedures you
should use assert_static/1.
*/
assert(Clause) :-
'$assert'(Clause, assertz, _).
'$assert'(Clause, Where, R) :-
'$yap_strip_clause'(Clause, _, _Clause0),
'$expand_clause'(Clause,C0,C),
'$$compile'(C, Where, C0, R).
/** @pred asserta(+ _C_,- _R_)
The same as `asserta(C)` but unifying _R_ with
the database reference that identifies the new clause, in a
one-to-one way. Note that `asserta/2` only works for dynamic
predicates. If the predicate is undefined, it will automatically be
declared dynamic.
*/
asserta(Clause, Ref) :-
'$assert'(Clause, asserta, Ref).
/** @pred assertz(+ _C_,- _R_)
The same as `assertz(C)` but unifying _R_ with
the database reference that identifies the new clause, in a
one-to-one way. Note that `asserta/2` only works for dynamic
predicates. If the predicate is undefined, it will automatically be
declared dynamic.
*/
assertz(Clause, Ref) :-
'$assert'(Clause, assertz, Ref).
/** @pred assert(+ _C_,- _R_)
The same as `assert(C)` ( (see Modifying the Database)) but
unifies _R_ with the database reference that identifies the new
clause, in a one-to-one way. Note that `asserta/2` only works for dynamic
predicates. If the predicate is undefined, it will automatically be
declared dynamic.
*/
assert(Clause, Ref) :-
'$assert'(Clause, assertz, Ref).
'$assertz_dynamic'(X, C, C0, Mod) :-
(X/\4)=:=0,
!,
'$head_and_body'(C,H,B),
'$assertat_d'(assertz,H,B,C0,Mod,_).
'$assertz_dynamic'(X,C,C0,Mod) :-
'$head_and_body'(C,H,B),
functor(H,N,A),
('$check_if_reconsulted'(N,A) ->
true
;
(X/\8)=:=0 ->
'$inform_as_reconsulted'(N,A),
'$remove_all_d_clauses'(H,Mod)
;
true
),
'$assertat_d'(assertz,H,B,C0,Mod,_).
'$remove_all_d_clauses'(H,M) :-
'$is_multifile'(H, M), !,
functor(H, Na, A),
'$erase_all_mf_dynamic'(Na,A,M).
'$remove_all_d_clauses'(H,M) :-
'$recordedp'(M:H,_,R), erase(R), fail.
'$remove_all_d_clauses'(_,_).
'$erase_all_mf_dynamic'(Na,A,M) :-
source_location( F , _),
recorded('$multifile_dynamic'(_,_,_), '$mf'(Na,A,M,F,R), R1),
erase(R1),
erase(R),
fail.
'$erase_all_mf_dynamic'(_,_,_).
'$assertat_d'(asserta,Head,Body,C0,Mod,R) :- !,
'$compile_dynamic'((Head:-Body), asserta, C0, Mod, CR),
( get_value('$abol',true)
->
'$predicate_flags'(Head,Mod,Fl,Fl),
( Fl /\ 0x20000000 =\= 0 -> '$check_multifile_pred'(Head,Mod,Fl) ; true )
;
true
),
'$head_and_body'(C0, H0, B0),
'$recordap'(Mod:Head,(H0 :- B0),R,CR),
( '$is_multifile'(Head, Mod) ->
source_location(F, _),
functor(H0, Na, Ar),
recorda('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
;
true
).
'$assertat_d'(assertz,Head,Body,C0,Mod,R) :-
'$compile_dynamic'((Head:-Body), assertz, C0, Mod, CR),
( get_value('$abol',true)
->
'$predicate_flags'(Head,Mod,Fl,Fl),
( Fl /\ 0x20000000 =\= 0 -> '$check_multifile_pred'(Head,Mod,Fl) ; true )
;
true
),
'$head_and_body'(C0, H0, B0),
'$recordzp'(Mod:Head,(H0 :- B0),R,CR),
( '$is_multifile'(H0, Mod) ->
source_location(F, _),
functor(H0, Na, Ar),
recordz('$multifile_dynamic'(_,_,_), '$mf'(Na,Ar,Mod,F,R), _)
;
true
).
/** @pred retract(+ _C_) is iso
Erases the first clause in the program that matches _C_. This
predicate may also be used for the static predicates that have been
compiled when the source mode was `on`. For more information on
source/0 ( (see Setting the Compiler)).
*/
retract( C ) :-
strip_module( C, M, C0),
'$check_head_and_body'(M:C0,M1,H,B,retract(M:C)),
'$predicate_flags'(H, M1, F, F),
'$retract2'(F, H, M1, B,_).
'$retract2'(F, H, M, B, R) :-
F /\ 0x08000000 =:= 0x08000000, !,
% '$is_log_updatable'(H, M), !,
'$log_update_clause'(H,M,B,R),
( F /\ 0x20000000 =:= 0x20000000, recorded('$mf','$mf_clause'(_,_,_,_,R),MR), erase(MR), fail ; true),
erase(R).
'$retract2'(F, H, M, B, R) :-
% '$is_dynamic'(H,M), !,
F /\ 0x00002000 =:= 0x00002000, !,
'$recordedp'(M:H,(H:-B),R),
( F /\ 0x20000000 =:= 0x20000000, recorded('$mf','$mf_clause'(_,_,_,_,MRef),MR), erase(MR), erase(MRef), fail ; true),
erase(R).
'$retract2'(_, H,M,_,_) :-
'$undefined'(H,M), !,
functor(H,Na,Ar),
'$dynamic'(Na/Ar,M),
fail.
'$retract2'(_, H,M,B,_) :-
functor(H,Na,Ar),
\+ '$dynamic'(Na/Ar,M),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),retract(M:(H:-B))).
/** @pred retract(+ _C_,- _R_)
Erases from the program the clause _C_ whose
database reference is _R_. The predicate must be dynamic.
*/
retract(M:C,R) :- !,
'$yap_strip_module'( C, M, H0),
'$retract'(H0, M, R).
'$retract'(C, M0, R) :-
db_reference(R),
'$check_head_and_body'(M0:C,M,H,B,retract(C,R)),
dynamic(H,M),
!,
instance(R,(H:-B)),
erase(R).
'$retract'(C,M0,R) :-
'$check_head_and_body'(M0:C,M,H,B,retract(C,R)),
var(R), !,
'$retract2'(H, M, B, R).
'$retract'(C,M,_) :-
'$fetch_predicate_indicator_from_clause'(C, M, PI),
\+ '$dynamic'(PI),
'$do_error'(permission_error(modify,static_procedure,PI),retract(M:C)).
'$fetch_predicate_indicator_from_clause'((C :- _), M:Na/Ar) :-
!,
'$yap_strip_module'(C, M, C1),
functor(C1, Na, Ar).
'$fetch_predicate_indicator_from_clause'(C, M:Na/Ar) :-
'$yap_strip_module'(C, M, C1),
functor(C1, Na, Ar).
/** @pred retractall(+ _G_) is iso
Retract all the clauses whose head matches the goal _G_. Goal
_G_ must be a call to a dynamic predicate.
*/
retractall(M:V) :- !,
'$retractall'(V,M).
retractall(V) :-
'$current_module'(M),
'$retractall'(V,M).
'$retractall'(V,M) :- var(V), !,
'$do_error'(instantiation_error,retract(M:V)).
'$retractall'(M:V,_) :- !,
'$retractall'(V,M).
'$retractall'(T,M) :-
(
'$is_log_updatable'(T, M) ->
( '$is_multifile'(T, M) ->
'$retractall_lu_mf'(T,M)
;
'$retractall_lu'(T,M)
)
;
\+ callable(T) ->
'$do_error'(type_error(callable,T),retractall(T))
;
'$undefined'(T,M) ->
functor(T,Na,Ar),
'$dynamic'(Na/Ar,M), !
;
'$is_dynamic'(T,M) ->
'$erase_all_clauses_for_dynamic'(T, M)
;
functor(T,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),retractall(T))
).
'$retractall_lu'(T,M) :-
'$free_arguments'(T), !,
( '$purge_clauses'(T,M), fail ; true ).
'$retractall_lu'(T,M) :-
'$log_update_clause'(T,M,_,R),
erase(R),
fail.
'$retractall_lu'(_,_).
'$retractall_lu_mf'(T,M) :-
'$log_update_clause'(T,M,_,R),
( recorded('$mf','$mf_clause'(_,_,_,_,R),MR), erase(MR), fail ; true),
erase(R),
fail.
'$retractall_lu_mf'(_,_).
'$erase_all_clauses_for_dynamic'(T, M) :-
'$recordedp'(M:T,(T :- _),R), erase(R), fail.
'$erase_all_clauses_for_dynamic'(T,M) :-
'$recordedp'(M:T,_,_), fail.
'$erase_all_clauses_for_dynamic'(_,_).
/* support for abolish/1 */
'$abolishd'(T, M) :-
'$is_multifile'(T,M),
functor(T,Name,Arity),
recorded('$mf','$mf_clause'(_,Name,Arity,M,Ref),R),
erase(R),
erase(Ref),
fail.
'$abolishd'(T, M) :-
recorded('$import','$import'(_,M,_,T,_,_),R),
erase(R),
fail.
'$abolishd'(T, M) :-
'$purge_clauses'(T,M), fail.
'$abolishd'(T, M) :-
'$kill_dynamic'(T,M), fail.
'$abolishd'(_, _).
/** @pred dynamic_predicate(+ _P_,+ _Semantics_)
Declares predicate _P_ or list of predicates [ _P1_,..., _Pn_]
as a dynamic predicate following either `logical` or
`immediate` semantics.
*/
dynamic_predicate(P,Sem) :-
'$bad_if_is_semantics'(Sem, dynamic(P,Sem)).
dynamic_predicate(P,Sem) :-
'$log_upd'(OldSem),
( Sem = logical -> '$switch_log_upd'(1) ; '$switch_log_upd'(0) ),
'$current_module'(M),
'$dynamic'(P, M),
'$switch_log_upd'(OldSem).
'$bad_if_is_semantics'(Sem, Goal) :-
var(Sem), !,
'$do_error'(instantiation_error,Goal).
'$bad_if_is_semantics'(Sem, Goal) :-
Sem \= immediate, Sem \= logical, !,
'$do_error'(domain_error(semantics_indicator,Sem),Goal).

View File

@@ -1,815 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: preds.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: Predicate Manipulation for YAP *
* *
*************************************************************************/
/**
* @{
* @defgroup Database The Clausal Data Base
* @ingroup builtins
Predicates in YAP may be dynamic or static. By default, when
consulting or reconsulting, predicates are assumed to be static:
execution is faster and the code will probably use less space.
Static predicates impose some restrictions: in general there can be no
addition or removal of clauses for a procedure if it is being used in the
current execution.
Dynamic predicates allow programmers to change the Clausal Data Base with
the same flexibility as in C-Prolog. With dynamic predicates it is
always possible to add or remove clauses during execution and the
semantics will be the same as for C-Prolog. But the programmer should be
aware of the fact that asserting or retracting are still expensive operations,
and therefore he should try to avoid them whenever possible.
*/
:- system_module( '$_preds', [abolish/1,
abolish/2,
assert/1,
assert/2,
assert_static/1,
asserta/1,
asserta/2,
asserta_static/1,
assertz/1,
assertz/2,
assertz_static/1,
clause/2,
clause/3,
clause_property/2,
compile_predicates/1,
current_key/2,
current_predicate/1,
current_predicate/2,
dynamic_predicate/2,
hide_predicate/1,
nth_clause/3,
predicate_erased_statistics/4,
predicate_property/2,
predicate_statistics/4,
retract/1,
retract/2,
retractall/1,
stash_predicate/1,
system_predicate/1,
system_predicate/2,
unknown/2], ['$assert_static'/5,
'$assertz_dynamic'/4,
'$clause'/4,
'$current_predicate'/4,
'$init_preds'/0,
'$noprofile'/2,
'$public'/2,
'$unknown_error'/1,
'$unknown_warning'/1]).
:- use_system_module( '$_boot', ['$check_head_and_body'/4,
'$check_if_reconsulted'/2,
'$head_and_body'/3,
'$inform_as_reconsulted'/2]).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_init', ['$do_log_upd_clause'/6,
'$do_log_upd_clause0'/6,
'$do_log_upd_clause_erase'/6,
'$do_static_clause'/5]).
:- use_system_module( '$_modules', ['$imported_pred'/4,
'$meta_predicate'/4,
'$module_expansion'/5]).
:- use_system_module( '$_preddecls', ['$check_multifile_pred'/3,
'$dynamic'/2]).
:- use_system_module( '$_strict_iso', ['$check_iso_strict_clause'/1]).
/** @pred assert_static(: _C_)
Adds clause _C_ to a static procedure. Asserting a static clause
for a predicate while choice-points for the predicate are available has
undefined results.
*/
assert_static(C) :-
'$assert'(C , assertz_static, _ ).
/** @pred asserta_static(: _C_)
Adds clause _C_ as the first clause for a static procedure.
*/
asserta_static(C) :-
'$assert'(C , asserta_static, _ ).
/** @pred assertz_static(: _C_)
Adds clause _C_ to the end of a static procedure. Asserting a
static clause for a predicate while choice-points for the predicate are
available has undefined results.
The following predicates can be used for dynamic predicates and for
static predicates, if source mode was on when they were compiled:
*/
assertz_static(C) :-
'$assert'(C , assertz_static, _ ).
/** @pred clause(+ _H_, _B_) is iso
A clause whose head matches _H_ is searched for in the
program. Its head and body are respectively unified with _H_ and
_B_. If the clause is a unit clause, _B_ is unified with
_true_.
This predicate is applicable to static procedures compiled with
`source` active, and to all dynamic procedures.
*/
clause(V0,Q) :-
'$yap_strip_module'(V0, M, V),
must_be_of_type( callable, V ),
'$clause'(V,M,Q,_).
/** @pred clause(+ _H_, _B_,- _R_)
The same as clause/2, plus _R_ is unified with the
reference to the clause in the database. You can use instance/2
to access the reference's value. Note that you may not use
erase/1 on the reference on static procedures.
*/
clause(P,Q,R) :-
'$instance_module'(R,M0), !,
instance(R,T0),
( T0 = (H :- B) -> Q = B ; H=T0, Q = true),
'$yap_strip_module'(P, M, T),
'$yap_strip_module'(M0:H, M1, H1),
(
M == M1
->
H1 = T
;
M1:H1 = T
).
clause(V0,Q,R) :-
'$yap_strip_module'(V0, M, V),
must_be_of_type( callable, V ),
'$clause'(V,M,Q,R).
'$clause'(P,M,Q,R) :-
'$is_exo'(P, M), !,
Q = true,
R = '$exo_clause'(M,P),
'$execute0'(P, M).
'$clause'(P,M,Q,R) :-
'$is_log_updatable'(P, M), !,
'$log_update_clause'(P,M,Q,R).
'$clause'(P,M,Q,R) :-
'$is_source'(P, M), !,
'$static_clause'(P,M,Q,R).
'$clause'(P,M,Q,R) :-
'$some_recordedp'(M:P), !,
'$recordedp'(M:P,(P:-Q),R).
'$clause'(P,M,Q,R) :-
\+ '$undefined'(P,M),
( '$is_system_predicate'(P,M) -> true ;
'$number_of_clauses'(P,M,N), N > 0 ),
functor(P,Name,Arity),
'$do_error'(permission_error(access,private_procedure,Name/Arity),
clause(M:P,Q,R)).
'$init_preds' :-
once('$do_static_clause'(_,_,_,_,_)),
fail.
'$init_preds' :-
once('$do_log_upd_clause0'(_,_,_,_,_,_)),
fail.
'$init_preds' :-
once('$do_log_upd_clause'(_,_,_,_,_,_)),
fail.
'$init_preds' :-
once('$do_log_upd_clause_erase'(_,_,_,_,_,_)),
fail.
'$init_preds'.
:- '$init_preds'.
/** @pred nth_clause(+ _H_, _I_,- _R_)
Find the _I_th clause in the predicate defining _H_, and give
a reference to the clause. Alternatively, if the reference _R_ is
given the head _H_ is unified with a description of the predicate
and _I_ is bound to its position.
*/
nth_clause(V,I,R) :-
strip_module(V, M1, P), !,
'$nth_clause'(P, M1, I, R).
'$nth_clause'(P,M,I,R) :-
var(I), var(R), !,
'$clause'(P,M,_,R),
'$fetch_nth_clause'(P,M,I,R).
'$nth_clause'(P,M,I,R) :-
'$fetch_nth_clause'(P,M,I,R).
/** @pred abolish(+ _P_,+ _N_)
Completely delete the predicate with name _P_ and arity _N_. It will
remove both static and dynamic predicates. All state on the predicate,
including whether it is dynamic or static, multifile, or
meta-predicate, will be lost.
*/
abolish(N0,A) :-
strip_module(N0, Mod, N), !,
'$abolish'(N,A,Mod).
'$abolish'(N,A,M) :- var(N), !,
'$do_error'(instantiation_error,abolish(M:N,A)).
'$abolish'(N,A,M) :- var(A), !,
'$do_error'(instantiation_error,abolish(M:N,A)).
'$abolish'(N,A,M) :-
( recorded('$predicate_defs','$predicate_defs'(N,A,M,_),R) -> erase(R) ),
fail.
'$abolish'(N,A,M) :- functor(T,N,A),
( '$is_dynamic'(T, M) -> '$abolishd'(T,M) ;
/* else */ '$abolishs'(T,M) ).
/** @pred abolish(+ _PredSpec_) is iso
Deletes the predicate given by _PredSpec_ from the database. If
§§ _PredSpec_ is an unbound variable, delete all predicates for the
current module. The
specification must include the name and arity, and it may include module
information. Under <tt>iso</tt> language mode this built-in will only abolish
dynamic procedures. Under other modes it will abolish any procedures.
*/
abolish(X0) :-
strip_module(X0,M,X),
'$abolish'(X,M).
'$abolish'(X,M) :-
current_prolog_flag(language, sicstus), !,
'$new_abolish'(X,M).
'$abolish'(X, M) :-
'$old_abolish'(X,M).
'$new_abolish'(V,M) :- var(V), !,
'$abolish_all'(M).
'$new_abolish'(A/V,M) :- atom(A), var(V), !,
'$abolish_all_atoms'(A,M).
'$new_abolish'(Na//Ar1, M) :-
integer(Ar1),
!,
Ar is Ar1+2,
'$new_abolish'(Na//Ar, M).
'$new_abolish'(Na/Ar, M) :-
functor(H, Na, Ar),
'$is_dynamic'(H, M), !,
'$abolishd'(H, M).
'$new_abolish'(Na/Ar, M) :- % succeed for undefined procedures.
functor(T, Na, Ar),
'$undefined'(T, M), !.
'$new_abolish'(Na/Ar, M) :-
'$do_error'(permission_error(modify,static_procedure,Na/Ar),abolish(M:Na/Ar)).
'$new_abolish'(T, M) :-
'$do_error'(type_error(predicate_indicator,T),abolish(M:T)).
'$abolish_all'(M) :-
'$current_predicate'(Na, M, S, _),
functor(S, Na, Ar),
'$new_abolish'(Na/Ar, M),
fail.
'$abolish_all'(_).
'$abolish_all_atoms'(Na, M) :-
'$current_predicate'(Na,M,S,_),
functor(S, Na, Ar),
'$new_abolish'(Na/Ar, M),
fail.
'$abolish_all_atoms'(_,_).
'$check_error_in_predicate_indicator'(V, Msg) :-
var(V), !,
'$do_error'(instantiation_error, Msg).
'$check_error_in_predicate_indicator'(M:S, Msg) :- !,
'$check_error_in_module'(M, Msg),
'$check_error_in_predicate_indicator'(S, Msg).
'$check_error_in_predicate_indicator'(S, Msg) :-
S \= _/_,
S \= _//_, !,
'$do_error'(type_error(predicate_indicator,S), Msg).
'$check_error_in_predicate_indicator'(Na/_, Msg) :-
var(Na), !,
'$do_error'(instantiation_error, Msg).
'$check_error_in_predicate_indicator'(Na/_, Msg) :-
\+ atom(Na), !,
'$do_error'(type_error(atom,Na), Msg).
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
var(Ar), !,
'$do_error'(instantiation_error, Msg).
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
\+ integer(Ar), !,
'$do_error'(type_error(integer,Ar), Msg).
'$check_error_in_predicate_indicator'(_/Ar, Msg) :-
Ar < 0, !,
'$do_error'(domain_error(not_less_than_zero,Ar), Msg).
% not yet implemented!
%'$check_error_in_predicate_indicator'(Na/Ar, Msg) :-
% Ar < maxarity, !,
% '$do_error'(type_error(representation_error(max_arity),Ar), Msg).
'$check_error_in_module'(M, Msg) :-
var(M), !,
'$do_error'(instantiation_error, Msg).
'$check_error_in_module'(M, Msg) :-
\+ atom(M), !,
'$do_error'(type_error(atom,M), Msg).
'$old_abolish'(V,M) :- var(V), !,
( true -> % current_prolog_flag(language, sicstus) ->
'$do_error'(instantiation_error,abolish(M:V))
;
'$abolish_all_old'(M)
).
'$old_abolish'(N/A, M) :- !,
'$abolish'(N, A, M).
'$old_abolish'(A,M) :- atom(A), !,
( current_prolog_flag(language, iso) ->
'$do_error'(type_error(predicate_indicator,A),abolish(M:A))
;
'$abolish_all_atoms_old'(A,M)
).
'$old_abolish'([], _) :- !.
'$old_abolish'([H|T], M) :- !, '$old_abolish'(H, M), '$old_abolish'(T, M).
'$old_abolish'(T, M) :-
'$do_error'(type_error(predicate_indicator,T),abolish(M:T)).
'$abolish_all_old'(M) :-
'$current_predicate'(Na, M, S, _),
functor( S, Na, Ar ),
'$abolish'(Na, Ar, M),
fail.
'$abolish_all_old'(_).
'$abolish_all_atoms_old'(Na, M) :-
'$current_predicate'(Na, M, S, _),
functor(S, Na, Ar),
'$abolish'(Na, Ar, M),
fail.
'$abolish_all_atoms_old'(_,_).
'$abolishs'(G, M) :- '$system_predicate'(G,M), !,
functor(G,Name,Arity),
'$do_error'(permission_error(modify,static_procedure,Name/Arity),abolish(M:G)).
'$abolishs'(G, Module) :-
current_prolog_flag(language, sicstus), % only do this in sicstus mode
'$undefined'(G, Module),
functor(G,Name,Arity),
print_message(warning,no_match(abolish(Module:Name/Arity))).
'$abolishs'(G, M) :-
'$is_multifile'(G,M),
functor(G,Name,Arity),
recorded('$mf','$mf_clause'(_,Name,Arity,M,_Ref),R),
erase(R),
% no need erase(Ref),
fail.
'$abolishs'(T, M) :-
recorded('$import','$import'(_,M,_,_,T,_,_),R),
erase(R),
fail.
'$abolishs'(G, M) :-
'$purge_clauses'(G, M), fail.
'$abolishs'(_, _).
/** @pred stash_predicate(+ _Pred_) @anchor stash_predicate
Make predicate _Pred_ invisible to new code, and to `current_predicate/2`,
`listing`, and friends. New predicates with the same name and
functor can be declared.
**/
stash_predicate(P0) :-
strip_module(P0, M, P),
'$stash_predicate2'(P, M).
'$stash_predicate2'(V, M) :- var(V), !,
'$do_error'(instantiation_error,stash_predicate(M:V)).
'$stash_predicate2'(N/A, M) :- !,
functor(S,N,A),
'$stash_predicate'(S, M) .
'$stash_predicate2'(PredDesc, M) :-
'$do_error'(type_error(predicate_indicator,PredDesc),stash_predicate(M:PredDesc)).
/** @pred hide_predicate(+ _Pred_)
Make predicate _Pred_ invisible to `current_predicate/2`,
`listing`, and friends.
**/
hide_predicate(P0) :-
'$yap_strip_module'(P0, M, P),
must_be_of_type(callable, M:P),
'$hide_predicate'(P, M).
/** @pred predicate_property( _P_, _Prop_) is iso
For the predicates obeying the specification _P_ unify _Prop_
with a property of _P_. These properties may be:
+ `built_in `
true for built-in predicates,
+ `dynamic`
true if the predicate is dynamic
+ `static `
true if the predicate is static
+ `meta_predicate( _M_) `
true if the predicate has a meta_predicate declaration _M_.
+ `multifile `
true if the predicate was declared to be multifile
+ `imported_from( _Mod_) `
true if the predicate was imported from module _Mod_.
+ `exported `
true if the predicate is exported in the current module.
+ `public`
true if the predicate is public; note that all dynamic predicates are
public.
+ `tabled `
true if the predicate is tabled; note that only static predicates can
be tabled in YAP.
+ `source (predicate_property flag) `
true if source for the predicate is available.
+ `number_of_clauses( _ClauseCount_) `
Number of clauses in the predicate definition. Always one if external
or built-in.
*/
predicate_property(Pred,Prop) :-
strip_module(Pred, Mod, TruePred),
'$predicate_property2'(TruePred,Prop,Mod).
'$predicate_property2'(Pred, Prop, Mod) :-
var(Mod), !,
'$all_current_modules'(Mod),
'$predicate_property2'(Pred, Prop, Mod).
'$predicate_property2'(Pred,Prop,M0) :-
var(Pred), !,
(M = M0 ;
M0 \= prolog, M = prolog ;
M0 \= user, M = user), % prolog and user modules are automatically incorporate in every other module
'$generate_all_preds_from_mod'(Pred, SourceMod, M),
'$predicate_property'(Pred,SourceMod,M,Prop).
'$predicate_property2'(M:Pred,Prop,_) :- !,
'$predicate_property2'(Pred,Prop,M).
'$predicate_property2'(Pred,Prop,Mod) :-
'$pred_exists'(Pred,Mod), !,
'$predicate_property'(Pred,Mod,Mod,Prop).
'$predicate_property2'(Pred,Prop,Mod) :-
'$get_undefined_pred'(Pred, Mod, NPred, M),
(
Prop = imported_from(M)
;
'$predicate_property'(NPred,M,M,Prop),
Prop \= exported
).
'$generate_all_preds_from_mod'(Pred, M, M) :-
'$current_predicate'(_Na,M,Pred,_).
'$generate_all_preds_from_mod'(Pred, SourceMod, Mod) :-
recorded('$import','$import'(SourceMod, Mod, Orig, Pred,_,_),_),
'$pred_exists'(Orig, SourceMod).
'$predicate_property'(P,M,_,built_in) :-
'$is_system_predicate'(P,M).
'$predicate_property'(P,M,_,source) :-
'$predicate_flags'(P,M,F,F),
F /\ 0x00400000 =\= 0.
'$predicate_property'(P,M,_,tabled) :-
'$predicate_flags'(P,M,F,F),
F /\ 0x00000040 =\= 0.
'$predicate_property'(P,M,_,dynamic) :-
'$is_dynamic'(P,M).
'$predicate_property'(P,M,_,static) :-
\+ '$is_dynamic'(P,M),
\+ '$undefined'(P,M).
'$predicate_property'(P,M,_,meta_predicate(Q)) :-
functor(P,Na,Ar),
prolog:'$meta_predicate'(Na,M,Ar,Q).
'$predicate_property'(P,M,_,multifile) :-
'$is_multifile'(P,M).
'$predicate_property'(P,M,_,public) :-
'$is_public'(P,M).
'$predicate_property'(P,M,_,thread_local) :-
'$is_thread_local'(P,M).
'$predicate_property'(P,M,M,exported) :-
functor(P,N,A),
once(recorded('$module','$module'(_TFN,M,_S,Publics,_L),_)),
lists:memberchk(N/A,Publics).
'$predicate_property'(P,Mod,_,number_of_clauses(NCl)) :-
'$number_of_clauses'(P,Mod,NCl).
'$predicate_property'(P,Mod,_,file(F)) :-
'$owner_file'(P,Mod,F).
/**
@pred predicate_statistics( _P_, _NCls_, _Sz_, _IndexSz_)
Given predicate _P_, _NCls_ is the number of clauses for
_P_, _Sz_ is the amount of space taken to store those clauses
(in bytes), and _IndexSz_ is the amount of space required to store
indices to those clauses (in bytes).
*/
predicate_statistics(V,NCls,Sz,ISz) :- var(V), !,
'$do_error'(instantiation_error,predicate_statistics(V,NCls,Sz,ISz)).
predicate_statistics(P0,NCls,Sz,ISz) :-
strip_module(P0, M, P),
'$predicate_statistics'(P,M,NCls,Sz,ISz).
'$predicate_statistics'(M:P,_,NCls,Sz,ISz) :- !,
'$predicate_statistics'(P,M,NCls,Sz,ISz).
'$predicate_statistics'(P,M,NCls,Sz,ISz) :-
'$is_log_updatable'(P, M), !,
'$lu_statistics'(P,NCls,Sz,ISz,M).
'$predicate_statistics'(P,M,_,_,_) :-
'$is_system_predicate'(P,M), !, fail.
'$predicate_statistics'(P,M,_,_,_) :-
'$undefined'(P,M), !, fail.
'$predicate_statistics'(P,M,NCls,Sz,ISz) :-
'$static_pred_statistics'(P,M,NCls,Sz,ISz).
/** @pred predicate_erased_statistics( _P_, _NCls_, _Sz_, _IndexSz_)
Given predicate _P_, _NCls_ is the number of erased clauses for
_P_ that could not be discarded yet, _Sz_ is the amount of space
taken to store those clauses (in bytes), and _IndexSz_ is the amount
of space required to store indices to those clauses (in bytes).
*/
predicate_erased_statistics(P,NCls,Sz,ISz) :-
var(P), !,
current_predicate(_,P),
predicate_erased_statistics(P,NCls,Sz,ISz).
predicate_erased_statistics(P0,NCls,Sz,ISz) :-
strip_module(P0,M,P),
'$predicate_erased_statistics'(M:P,NCls,Sz,_,ISz).
/** @pred current_predicate( _A_, _P_)
Defines the relation: _P_ is a currently defined predicate whose name is the atom _A_.
*/
current_predicate(A,T0) :-
'$yap_strip_module'(T0, M, T),
(nonvar(T) -> functor(T, A, _) ; true ),
(
'$current_predicate'(A,M, T, user)
;
'$imported_predicate'(T, M, T1, M1),
functor(T1, A, _),
\+ '$is_system_predicate'(T1,M1)
).
/** @pred system_predicate( ?_P_ )
Defines the relation: indicator _P_ refers to a currently defined system predicate.
*/
system_predicate(P0) :-
'$yap_strip_module'(P0, M, P),
(
var(P)
->
P = A/Arity,
'$current_predicate'(A, M, T, system),
functor(T, A, Arity),
'$is_system_predicate'( T, M)
;
ground(P), P = A/Arity
->
functor(T, A, Arity),
'$current_predicate'(A, M, T, system),
'$is_system_predicate'( T, M)
;
ground(P), P = A//Arity2
->
Arity is Arity2+2,
functor(T, A, Arity),
'$current_predicate'(A, M, T, system),
'$is_system_predicate'( T, M)
;
P = A/Arity
->
'$current_predicate'(A, M, T, system),
'$is_system_predicate'( T, M),
functor(T, A, Arity)
;
P = A//Arity2
->
'$current_predicate'(A, M, T, system),
'$is_system_predicate'( T, M),
functor(T, A, Arity),
Arity >= 2,
Arity2 is Arity-2
;
'$do_error'(type_error(predicate_indicator,P),
system_predicate(P0))
).
/** @pred system_predicate( ?A, ?P )
Succeeds if _A_ is the name of the system predicate _P_. It can be used to test and to enumerate all system predicates.
YAP also supports the ISO standard built-in system_predicate/1, that
provides similar functionality and is compatible with most other Prolog
systems.
*/
system_predicate(A, P0) :-
'$yap_strip_module'(P0, M, P),
(
nonvar(P)
->
'$current_predicate'(A, M, P, system),
'$is_system_predicate'( P, M)
;
'$current_predicate'(A, M, P, system)
).
/**
@pred current_predicate( F ) is iso
True if _F_ is the predicate indicator for a currently defined user or
library predicate.The indicator _F_ is of the form _Mod_:_Na_/_Ar_ or _Na/Ar_,
where the atom _Mod_ is the module of the predicate,
_Na_ is the name of the predicate, and _Ar_ its arity.
*/
current_predicate(F0) :-
'$yap_strip_module'(F0, M, F),
must_bind_to_type( predicate_indicator, F ),
'$c_i_predicate'( F, M ).
'$c_i_predicate'( A/N, M ) :-
!,
(
ground(A/N)
->
atom(A), integer(N),
functor(S, A, N),
current_predicate(A, M:S)
;
current_predicate(A, M:S),
functor(S, A, N)
).
'$c_i_predicate'( A//N, M ) :-
(
ground(A)
->
atom(A), integer(N),
N2 is N+2,
functor(S, A, N2),
current_predicate(A, M:S)
;
current_predicate(A, M:S),
functor(S, A, N2),
N is N2-2
).
/** @pred current_key(? _A_,? _K_)
Defines the relation: _K_ is a currently defined database key whose
name is the atom _A_. It can be used to generate all the keys for
the internal data-base.
*/
current_key(A,K) :-
'$current_predicate'(A,idb,K,user).
% do nothing for now.
'$noprofile'(_, _).
'$ifunctor'(Pred,Na,Ar) :-
(Ar > 0 ->
functor(Pred, Na, Ar)
;
Pred = Na
).
/** @pred compile_predicates(: _ListOfNameArity_)
Compile a list of specified dynamic predicates (see dynamic/1 and
assert/1 into normal static predicates. This call tells the
Prolog environment the definition will not change anymore and further
calls to assert/1 or retract/1 on the named predicates
raise a permission error. This predicate is designed to deal with parts
of the program that is generated at runtime but does not change during
the remainder of the program execution.
*/
compile_predicates(Ps) :-
'$current_module'(Mod),
'$compile_predicates'(Ps, Mod, compile_predicates(Ps)).
'$compile_predicates'(V, _, Call) :-
var(V), !,
'$do_error'(instantiation_error,Call).
'$compile_predicates'(M:Ps, _, Call) :-
'$compile_predicates'(Ps, M, Call).
'$compile_predicates'([], _, _).
'$compile_predicates'([P|Ps], M, Call) :-
'$compile_predicate'(P, M, Call),
'$compile_predicates'(Ps, M, Call).
'$compile_predicate'(P, _M, Call) :-
var(P), !,
'$do_error'(instantiation_error,Call).
'$compile_predicate'(M:P, _, Call) :-
'$compile_predicate'(P, M, Call).
'$compile_predicate'(Na/Ar, Mod, _Call) :-
functor(G, Na, Ar),
findall([G|B],clause(Mod:G,B),Cls),
abolish(Mod:Na,Ar),
'$add_all'(Cls, Mod).
'$add_all'([], _).
'$add_all'([[G|B]|Cls], Mod) :-
assert_static(Mod:(G:-B)),
'$add_all'(Cls, Mod).
clause_property(ClauseRef, file(FileName)) :-
( recorded('$mf','$mf_clause'(FileName,_Name,_Arity,_Module,ClauseRef),_R)
-> true
;
instance_property(ClauseRef, 2, FileName) ).
clause_property(ClauseRef, source(FileName)) :-
( recorded('$mf','$mf_clause'(FileName,_Name,_Arity,_Module,ClauseRef),_R)
-> true
;
instance_property(ClauseRef, 2, FileName) ).
clause_property(ClauseRef, line_count(LineNumber)) :-
instance_property(ClauseRef, 4, LineNumber),
LineNumber > 0.
clause_property(ClauseRef, fact) :-
instance_property(ClauseRef, 3, true).
clause_property(ClauseRef, erased) :-
instance_property(ClauseRef, 0, true).
clause_property(ClauseRef, predicate(PredicateIndicator)) :-
instance_property(ClauseRef, 1, PredicateIndicator).
'$set_predicate_attribute'(M:N/Ar, Flag, V) :-
functor(P, N, Ar),
'$set_flag'(P, M, Flag, V).
%% '$set_flag'(P, M, trace, off) :-
% set a predicate flag
%
'$set_flag'(P, M, trace, off) :-
'$predicate_flags'(P,M,F,F),
FN is F \/ 0x400000000,
'$predicate_flags'(P,M,F,FN).
/**
@}
*/

View File

@@ -1,262 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: profile.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: Some profiling predicates available in yap *
* *
*************************************************************************/
%% @file pl/profile.yap
:- system_module( '$_profile', [profile_data/3,
profile_reset/0,
showprofres/0,
showprofres/1], []).
/** @defgroup The_Count_Profiler The Count Profiler
@ingroup Profiling
@{
The count profiler works by incrementing counters at procedure entry or
backtracking. It provides exact information:
+ Profiling works for both static and dynamic predicates.
+ Currently only information on entries and retries to a predicate
are maintained. This may change in the future.
+ As an example, the following user-level program gives a list of
the most often called procedures in a program. The procedure
list_profile/0 shows all procedures, irrespective of module, and
the procedure list_profile/1 shows the procedures being used in
a specific module.
~~~~~
list_profile :-
% get number of calls for each profiled procedure
setof(D-[M:P|D1],(current_module(M),profile_data(M:P,calls,D),profile_data(M:P,retries,D1)),LP),
% output so that the most often called
% predicates will come last:
write_profile_data(LP).
list_profile(Module) :-
% get number of calls for each profiled procedure
setof(D-[Module:P|D1],(profile_data(Module:P,calls,D),profile_data(Module:P,retries,D1)),LP),
% output so that the most often called
% predicates will come last:
write_profile_data(LP).
write_profile_data([]).
write_profile_data([D-[M:P|R]|SLP]) :-
% swap the two calls if you want the most often
% called predicates first.
format('~a:~w: ~32+~t~d~12+~t~d~12+~n', [M,P,D,R]),
write_profile_data(SLP).
~~~~~
These are the current predicates to access and clear profiling data:
*/
:- use_system_module( '$_errors', ['$do_error'/2]).
% hook predicate, taken from SWI-Prolog, for converting possibly explicitly-
% qualified callable terms into an atom that can be used as a label for
% describing a predicate; used e.g. on the tick profiler defined below
:- multifile(user:prolog_predicate_name/2).
/** @pred profile_data( ?Na/Ar, ?Parameter, -Data_)
Give current profile data on _Parameter_ for a predicate described
by the predicate indicator _Na/Ar_. If any of _Na/Ar_ or
_Parameter_ are unbound, backtrack through all profiled predicates
or stored parameters. Current parameters are:
+ calls
Number of times a procedure was called.
+ retries
Number of times a call to the procedure was backtracked to and retried.
+ profile_reset
Reset all profiling information.
*/
:- meta_predicate profile_data(:,+,-).
profile_data(M:D, Parm, Data) :-!,
(
var(M) ->
'$do_error'(instantiation_error,profile_data(M:D, Parm, Data))
;
'$profile_data'(D, Parm, Data, M)
).
profile_data(P, Parm, Data) :-
'$current_module'(M),
'$profile_data'(P, Parm, Data, M).
'$profile_data'(P, Parm, Data,M) :- var(P), !,
'$profile_data_for_var'(P, Parm, Data,M).
'$profile_data'(M:P, Parm, Data, _) :- !,
'$profile_data'(P, Parm, Data, M).
'$profile_data'(P, Parm, Data, M) :-
'$profile_data2'(P, Parm, Data, M).
'$profile_data2'(Na/Ar,Parm,Data, M) :-
functor(P, Na, Ar),
'$profile_info'(M, P, Stats),
'$profile_say'(Stats, Parm, Data).
'$profile_data_for_var'(Name/Arity, Parm, Data, M) :-
functor(P,Name,Arity),
'$current_predicate'(Name,M,P,_),
\+ '$hidden'(Name), % don't show hidden predicates.
'$profile_info'(M, P, Stats),
'$profile_say'(Stats, Parm, Data).
'$profile_say'('$profile'(Entries, _, _), calls, Entries).
'$profile_say'('$profile'(_, _, Backtracks), retries, Backtracks).
profile_reset :-
current_module(M),
'$current_predicate'(_Na,M,P,_),
'$profile_reset'(M, P),
fail.
profile_reset.
/** @pred showprofres
Show profiling info.
*/
showprofres :-
showprofres(-1).
/** @pred showprofres( _N_)
Show profiling info for the top-most _N_ predicates.
The showprofres/0 and `showprofres/1` predicates call a user-defined multifile hook predicate, `user:prolog_predicate_name/2`, that can be used for converting a possibly explicitly-qualified callable term into an atom that will used when printing the profiling information.
*/
showprofres(A) :-
'$offline_showprofres',
('$profison' -> profoff, Stop = true ; Stop = false),
'$profglobs'(Tot,GCs,HGrows,SGrows,Mallocs,_Indexing,ProfOns),
% root node has no useful info.
'$get_all_profinfo'(0,[],ProfInfo0,0,_TotCode),
msort(ProfInfo0,ProfInfo),
'$get_ppreds'(ProfInfo,Preds0),
'$add_extras_prof'(GCs, HGrows, SGrows, Mallocs, Preds0, PredsI),
keysort(PredsI,Preds),
'$sum_alls'(Preds,0,Tot0),
Accounted is -Tot0,
(ProfOns == 0 ->
format(user_error,'~d ticks, ~d accounted for~n',[Tot,Accounted])
;
format(user_error,'~d ticks, ~d accounted for (~d overhead)~n',[Tot,Accounted,ProfOns])
),
% format(user_error,' ~d ticks in indexing code~n',[Indexing]),
A1 is A+1,
'$display_preds'(Preds, Tot, 0, 1, A1),
(Stop = true -> profon ; true).
/*
'$check_duplicates'([]).
'$check_duplicates'([A,A|ProfInfo]) :- !,
write(A),nl,
'$check_duplicates'(ProfInfo).
'$check_duplicates'([_|ProfInfo]) :-
'$check_duplicates'(ProfInfo).
*/
'$get_all_profinfo'([],L,L,Tot,Tot) :- !.
'$get_all_profinfo'(Node,L0,Lf,Tot0,Totf) :-
'$profnode'(Node,Clause,PredId,Count,Left,Right),
Tot1 is Tot0+Count,
'$get_all_profinfo'(Left,L0,Li,Tot1,Tot2),
'$get_all_profinfo'(Right,[gprof(PredId,Clause,Count)|Li],Lf,Tot2,Totf).
'$get_ppreds'([],[]).
'$get_ppreds'([gprof(0,_,0)|Cls],Ps) :- !,
'$get_ppreds'(Cls,Ps).
'$get_ppreds'([gprof(0,_,Count)|_],_) :- !,
'$do_error'('SYSTEM_ERROR_INTERNAL',showprofres(gprof(0,_,Count))).
'$get_ppreds'([gprof(PProfInfo,_,Count0)|Cls],[Sum-(Mod:Name/Arity)|Ps]) :-
'$get_more_ppreds'(Cls,PProfInfo,Count0,NCls,Sum),
'$get_pred_pinfo'(PProfInfo,Mod,Name,Arity),
'$get_ppreds'(NCls,Ps).
'$get_more_ppreds'([gprof(PProfInfo,_,Count)|Cls],PProfInfo,Count0,NCls,Sum)
:- !,
Count1 is Count+Count0,
'$get_more_ppreds'(Cls,PProfInfo,Count1,NCls,Sum).
'$get_more_ppreds'(Cls, _, Sum, Cls, NSum) :- NSum is -Sum.
'$display_preds'(_, _, _, N, N) :- !.
'$display_preds'([], _, _, _, _).
'$display_preds'([0-_|_], _Tot, _SoFar, _I, _N) :- !.
'$display_preds'([NSum-P|Ps], Tot, SoFar, I, N) :-
Sum is -NSum,
Perc is (100*Sum)/Tot,
Next is SoFar+Sum,
NextP is (100*Next)/Tot,
( ( P = M:F/A ->
G = M:H
; P = F/A,
G = H
),
functor(H, F, A),
user:prolog_predicate_name(G, PL) ->
true
; PL = P
),
format(user_error,'~|~t~d.~7+ ~|~w:~t~d~50+ (~|~t~2f~6+%) |~|~t~2f~6+%|~n',[I,PL,Sum,Perc,NextP]),
I1 is I+1,
'$display_preds'(Ps,Tot,Next,I1, N).
'$sum_alls'([],Tot,Tot).
'$sum_alls'([C-_|Preds],Tot0,Tot) :-
TotI is C+Tot0,
'$sum_alls'(Preds,TotI,Tot).
'$add_extras_prof'(GCs, HGrows, SGrows, Mallocs, Preds0, PredsI) :-
'$add_extra_prof'(GCs, 'Garbage Collections',Preds0,Preds1),
'$add_extra_prof'(HGrows, 'Code Expansion',Preds1,Preds2),
'$add_extra_prof'(SGrows, 'Stack Expansion',Preds2,Preds3),
'$add_extra_prof'(Mallocs, 'Heap Allocation',Preds3,PredsI).
'$add_extra_prof'(0, _,Preds, Preds) :- !.
'$add_extra_prof'(Ticks, Name, Preds, [NTicks-Name|Preds]) :-
NTicks is -Ticks.
/**
@}
*/

View File

@@ -1,79 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: protect.yap *
* Last rev: *
* mods: *
* comments: protecting the system functions *
* *
*************************************************************************/
:- system_module( '$_protect', [], ['$protect'/0]).
/**
* @file protect.yap
* @addgroup ProtectCore Freeze System Configuration
* @ingroup CoreUtilities
*
* This protects current code from further changes
* and also makes it impossible for some predicates to be seen
* in user-space.
*
* Algorithm:
* - fix system modules
* - fix system predicates
* - hide atoms with `$`
*/
'$protect' :-
'$all_current_modules'(M),
( sub_atom(M,0,1,_, '$') ; M= prolog; M= system ),
new_system_module( M ),
fail.
'$protect' :-
'$current_predicate'(Name,M,P,_),
'$is_system_module'(M),
functor(P,Name,Arity),
'$new_system_predicate'(Name,Arity,M),
sub_atom(Name,0,1,_, '$'),
functor(P,Name,Arity),
'$hide_predicate'(P,M),
fail.
'$protect' :-
current_atom(Name),
sub_atom(Name,0,1,_, '$'),
\+ '$visible'(Name),
hide_atom(Name),
fail.
'$protect'.
% hide all atoms who start by '$'
'$visible'('$'). /* not $VAR */
'$visible'('$VAR'). /* not $VAR */
'$visible'('$dbref'). /* not stream position */
'$visible'('$stream'). /* not $STREAM */
'$visible'('$stream_position'). /* not stream position */
'$visible'('$hacks').
'$visible'('$source_location').
'$visible'('$messages').
'$visible'('$push_input_context').
'$visible'('$pop_input_context').
'$visible'('$set_source_module').
'$visible'('$declare_module').
'$visible'('$store_clause').
'$visible'('$skip_list').
'$visible'('$win_insert_menu_item').
'$visible'('$set_predicate_attribute').
'$visible'('$parse_quasi_quotations').
'$visible'('$quasi_quotation').
'$visible'('$qq_open').
'$visible'('$live').
'$visible'('$init_prolog').

View File

@@ -1,796 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-2011 *
* *
**************************************************************************
* *
* File: qly.yap *
* Last rev: *
* mods: *
* comments: fast save/restore *
* *
*************************************************************************/
%% @file qly.yap
/**
@defgroup QLY Creating and Using a saved state
@ingroup YAPConsulting
@{
*/
:- system_module( '$_qly', [qload_module/1,
qsave_file/1,
qsave_module/1,
qsave_program/1,
qsave_program/2,
restore/1,
save_program/1,
save_program/2], ['$init_state'/0]).
:- use_system_module( '$_absf', ['$system_library_directories'/2]).
:- use_system_module( '$_boot', ['$system_catch'/4]).
:- use_system_module( '$_consult', ['$do_startup_reconsult'/1]).
:- use_system_module( '$_control', ['$run_atom_goal'/1]).
:- use_system_module( '$_errors', ['$do_error'/2]).
:- use_system_module( '$_preds', ['$init_preds'/0]).
:- use_system_module( '$_protect', ['$protect'/0]).
:- use_system_module( '$_threads', ['$reinit_thread0'/0]).
:- use_system_module( '$_yio', ['$extend_file_search_path'/1]).
/**
YAP can save and read images of its current state to files, known as
saved states. It is possible to save the entire state or just a module
or a file. Notice that saved states in YAP depend on the architecture
where they were made, and may also depend on the version of YAP being
saved.
YAP always tries to find saved states from the current directory
first. If it cannot it will use the environment variable [YAPLIBDIR](@ref YAPLIBDIR), if
defined, or search the default library directory.
*/
/** @pred save_program(+ _F_)
Saves the current state of the data-base in file _F_ .
The result is a resource archive containing a saved state that
expresses all Prolog data from the running program and all
user-defined resources. Depending on the stand_alone option, the
resource is headed by the emulator, a Unix shell script or nothing.
**/
save_program(File) :-
qsave_program(File).
/** @pred save_program(+ _F_, : _G_)
Saves an image of the current state of the YAP database in file
_F_, and guarantee that execution of the restored code will start by
trying goal _G_.
**/
qsave_program(File) :-
'$save_program_status'([], qsave_program(File)),
open(File, write, S, [type(binary)]),
'$qsave_program'(S),
close(S).
/** @pred qsave_program(+ _F_, Opts)
Saves an image of the current state of the YAP database in file
_F_, currently the options in _Opts_ are ignored:
+ stack(+ _KBytes_)
Limit for the local and global stack.
+ trail(+ _KBytes_)
Limit for the trail stack.
+ goal(: _Callable_)
Initialization goal for the new executable (see `-g`).
+ init_file(+ _Atom_)
Default initialization file for the new executable. See `-f`.
*/
qsave_program(File, Opts) :-
'$save_program_status'(Opts, qsave_program(File,Opts)),
open(File, write, S, [type(binary)]),
'$qsave_program'(S),
% make sure we're not going to bootstrap from this file.
close(S).
/** @pred save_program(+ _F_, : _G_)
Saves an image of the current state of the YAP database in file
_F_, and guarantee that execution of the restored code will start by
trying goal _G_.
**/
save_program(_File, Goal) :-
recorda('$restore_goal', Goal ,_R),
fail.
save_program(File, _Goal) :-
qsave_program(File).
/** @pred qend_program
Saves an image of the current state of the YAP database in default
filee, usually `startup.yss`.
**/
qend_program :-
module(user),
qsave_program('startup.yss'),
halt(0).
'$save_program_status'(Flags, G) :-
findall(F-V, '$x_yap_flag'(F,V),L),
recordz('$program_state',L,_),
'$cvt_qsave_flags'(Flags, G),
fail.
'$save_program_status'(_Flags, _G).
'$cvt_qsave_flags'(Flags, G) :-
nonvar(Flags),
strip_module(Flags, M, LFlags),
'$skip_list'(_Len, LFlags, []),
'$cvt_qsave_lflags'(LFlags, G, M).
'$cvt_qsave_flags'(Flags, G,_OFlags) :-
var(Flags),
'$do_error'(instantiation_error,G).
'$cvt_qsave_flags'(Flags, G,_OFlags) :-
'$do_error'(type_error(list,Flags),G).
'$cvt_qsave_lflags'([], _, _).
'$cvt_qsave_lflags'([Flag|Flags], G, M) :-
'$cvt_qsave_flag'(Flag, G, M),
'$cvt_qsave_lflags'(Flags, G, M).
'$cvt_qsave_flag'(Flag, G, _) :-
var(Flag), !,
'$do_error'(instantiation_error,G).
'$cvt_qsave_flag'(local(B), G, _) :- !,
( number(B) ->
(
B > 0 -> recordz('$restore_flag',local(B),_) ;
B =:= 0 -> true ;
'$do_error'(domain_error(not_less_than_zero,B),G))
;
'$do_error'(type_error(integer,B),G)
).
'$cvt_qsave_flag'(global(B), G, _) :- !,
( number(B) ->
(
B > 0 -> recordz('$restore_flag',global(B),_) ;
B =:= 0 -> true ;
'$do_error'(domain_error(not_less_than_zero,B),G))
;
'$do_error'(type_error(integer,B),G)
).
'$cvt_qsave_flag'(stack(B), G, _) :- !,
( number(B) ->
(
B > 0 -> recordz('$restore_flag',stack(B),_) ;
B =:= 0 -> true ;
'$do_error'(domain_error(not_less_than_zero,B),G))
;
'$do_error'(type_error(integer,B),G)
).
'$cvt_qsave_flag'(trail(B), G, _) :- !,
( number(B) ->
(
B > 0 -> recordz('$restore_flag',trail(B),_) ;
B =:= 0 -> true ;
'$do_error'(domain_error(not_less_than_zero,B),G))
;
'$do_error'(type_error(integer,B),G)
).
'$cvt_qsave_flag'(goal(B), G, M) :- !,
( callable(B) ->
strip_module(M:B, M1, G1),
recordz('$restore_flag',goal(M1:G1),_)
;
strip_module(M:B, M1, G1),
'$do_error'(type_error(callable,G1),G)
).
'$cvt_qsave_flag'(toplevel(B), G, M) :- !,
( callable(B) ->
strip_module(M:B, M1, G1),
recordz('$restore_flag',toplevel(M1:G1),_)
;
strip_module(M:B, M1, G1),
'$do_error'(type_error(callable,G1),G)
).
'$cvt_qsave_flag'(init_file(B), G, M) :- !,
( atom(B) ->
recordz('$restore_flag', init_file(M:B), _)
;
'$do_error'(type_error(atom,B),G)
).
%% '$cvt_qsave_flag'(autoload(_B), G, autoload(_B)).
%% '$cvt_qsave_flag'(op(_B), G, op(_B)).
%% '$cvt_qsave_flag'(stand_alone(_B), G, stand_alone(_B)).
%% '$cvt_qsave_flag'(emulator(_B), G, emulator(_B)).
%% '$cvt_qsave_flag'(foreign(_B), G, foreign(_B)).
'$cvt_qsave_flag'(Opt, G, _M) :-
'$do_error'(domain_error(qsave_program,Opt), G).
% there is some ordering between flags.
'$x_yap_flag'(language, V) :-
yap_flag(language, V).
'$x_yap_flag'(M:P, V) :-
current_module(M),
yap_flag(M:P, V).
'$x_yap_flag'(X, V) :-
prolog_flag_property(X, [access(read_write)]),
atom(X),
yap_flag(X, V),
X \= gc_margin, % different machines will have different needs,
X \= argv,
X \= os_argv,
X \= language,
X \= encoding.
'$init_state' :-
(
recorded('$program_state', _P, R)
->
erase(R),
'$do_init_state'
;
true
).
'$do_init_state' :-
'$undefp_handler'('$undefp'(_,_), prolog),
fail.
'$do_init_state' :-
set_value('$user_module',user),
'$protect',
fail.
'$do_init_state' :-
compile_expressions,
'$init_preds',
fail.
'$do_init_state' :-
recorded('$program_state',L,R),
erase(R),
lists:member(F-V,L),
catch(yap_flag(F,V),Error,user:'$Error'(Error)),
fail.
'$do_init_state' :-
'$reinit_thread0',
fail.
'$do_init_state' :-
'$current_module'(prolog),
module(user),
fail.
'$do_init_state' :-
'$init_from_saved_state_and_args',
fail.
'$do_init_state' :-
stream_property(user_input, tty(true)),
set_prolog_flag(readline, true).
'$do_init_state'.
%
% first, recover what we need from the saved state...
%'
'$init_from_saved_state_and_args' :-
'$init_path_extensions',
fail.
% use if we come from a save_program and we have SWI's shlib
'$init_from_saved_state_and_args' :-
current_prolog_flag(hwnd, _HWND),
load_files(library(win_menu), [silent(true)]),
fail.
'$init_from_saved_state_and_args' :-
recorded('$reload_foreign_libraries',_G,R),
erase(R),
shlib:reload_foreign_libraries,
fail.
% this should be done before -l kicks in.
'$init_from_saved_state_and_args' :-
current_prolog_flag(fast_boot, false),
( exists('~/.yaprc') -> load_files('~/.yaprc', []) ; true ),
( exists('~/.prologrc') -> load_files('~/.prologrc', []) ; true ),
( exists('~/prolog.ini') -> load_files('~/prolog.ini', []) ; true ),
fail.
% use if we come from a save_program and we have a goal to execute
'$init_from_saved_state_and_args' :-
get_value('$consult_on_boot',X), X \= [],
set_value('$consult_on_boot',[]),
'$do_startup_reconsult'(X),
fail.
'$init_from_saved_state_and_args' :-
recorded('$restore_flag', init_file(M:B), R),
erase(R),
'$do_startup_reconsult'(M:B),
fail.
'$init_from_saved_state_and_args' :-
recorded('$restore_flag', unknown(M:B), R),
erase(R),
yap_flag(M:unknown,B),
fail.
'$init_from_saved_state_and_args' :-
'$startup_goals',
fail.
'$init_from_saved_state_and_args' :-
recorded('$restore_goal',G,R),
erase(R),
prompt(_,'| '),
catch(once(user:G),Error,user:'$Error'(Error)),
fail.
'$init_from_saved_state_and_args'.
'$init_path_extensions' :-
get_value('$extend_file_search_path',P), !,
P \= [],
set_value('$extend_file_search_path',[]),
'$extend_file_search_path'(P).
'$init_path_extensions'.
% then we can execute the programs.
'$startup_goals' :-
module(user),
fail.
'$startup_goals' :-
recorded('$startup_goal',G,_),
catch(once(user:G),Error,user:'$Error'(Error)),
fail.
'$startup_goals' :-
get_value('$init_goal',GA),
GA \= [],
set_value('$init_goal',[]),
'$run_atom_goal'(GA),
fail.
'$startup_goals' :-
recorded('$restore_flag', goal(Module:GA), R),
erase(R),
catch(once(Module:GA),Error,user:'$Error'(Error)),
fail.
'$startup_goals' :-
get_value('$myddas_goal',GA), GA \= [],
set_value('$myddas_goal',[]),
get_value('$myddas_user',User), User \= [],
set_value('$myddas_user',[]),
get_value('$myddas_db',Db), Db \= [],
set_value('$myddas_db',[]),
get_value('$myddas_host',HostT),
( HostT \= [] ->
Host = HostT,
set_value('$myddas_host',[])
;
Host = localhost
),
get_value('$myddas_pass',PassT),
( PassT \= [] ->
Pass = PassT,
set_value('$myddas_pass',[])
;
Pass = ''
),
use_module(library(myddas)),
call(db_open(mysql,myddas,Host/Db,User,Pass)),
'$myddas_import_all',
fail.
'$startup_goals'.
%
% MYDDAS: Import all the tables from one database
%
'$myddas_import_all':-
call(db_my_show_tables(myddas,table(Table))),
call(db_import(myddas,Table,Table)),
fail.
'$myddas_import_all'.
qsave_file(F0) :-
ensure_loaded( F0 ),
absolute_file_name( F0, File, [expand(true),file_type(prolog),access(read),file_errors(fail),solutions(first)]),
absolute_file_name( F0, State, [expand(true),file_type(qly)]),
'$qsave_file_'(File, State).
/** @pred qsave_file(+ _File_, +_State_)
Saves an image of all the information compiled by the system from file _F_ to _State_.
This includes modules and predicates eventually including multi-predicates.
**/
qsave_file(F0, State) :-
ensure_loaded( F0 ),
absolute_file_name( F0, File, [expand(true),file_type(prolog),access(read),file_errors(fail),solutions(first)]),
'$qsave_file_'(File, State).
'$qsave_file_'(File, UserF, _State) :-
( File == user_input -> Age = 0 ; time_file64(File, Age) ),
'$current_module'(M),
assert(user:'$file_property'( '$lf_loaded'( UserF, Age, M) ) ),
'$set_owner_file'( '$file_property'( _ ), user, File ),
fail.
'$qsave_file_'(File, UserF, _State) :-
recorded('$lf_loaded','$lf_loaded'( File, M, Reconsult, UserFile, OldF, Line, Opts), _),
assert(user:'$file_property'( '$lf_loaded'( UserF, M, Reconsult, UserFile, OldF, Line, Opts) ) ),
'$set_owner_file'( '$file_property'( _ ), user, File ),
fail.
'$qsave_file_'(File, _UserF, _State) :-
recorded('$directive',directive( File, M:G, Mode, VL, Pos ), _),
assert(user:'$file_property'( directive( M:G, Mode, VL, Pos ) ) ),
'$set_owner_file'('$file_property'( _ ), user, File ),
fail.
'$qsave_file_'(File, _UserF, _State) :-
'$fetch_multi_files_file'(File, MultiFiles),
assert(user:'$file_property'( multifile(MultiFiles ) ) ),
'$set_owner_file'('$file_property'( _ ), user, File ),
fail.
'$qsave_file_'( File, _UserF, State ) :-
(
is_stream( State )
->
'$qsave_file_preds'(State, File)
;
open(State, write, S, [type(binary)]),
'$qsave_file_preds'(S, File),
close(S)
),
abolish(user:'$file_property'/1).
'$fetch_multi_files_file'(File, Multi_Files) :-
setof(Info, '$fetch_multi_file_module'(File, Info), Multi_Files).
'$fetch_multi_file_file'(FileName, (M:G :- Body)) :-
recorded('$multifile_defs','$defined'(FileName,Name,Arity,M), _),
functor(G, Name, Arity ),
clause(M:G, Body, ClauseRef),
clause_property(ClauseRef, file(FileName) ).
/** @pred qsave_module(+ _Module_, +_State_)
Saves an image of all the information compiled by the systemm on module _F_ to _State_.
**/
qsave_module(Mod, OF) :-
recorded('$module', '$module'(_F,Mod,Source,Exps,L), _),
'$fetch_parents_module'(Mod, Parents),
'$fetch_imports_module'(Mod, Imps),
'$fetch_multi_files_module'(Mod, MFs),
'$fetch_meta_predicates_module'(Mod, Metas),
'$fetch_module_transparents_module'(Mod, ModTransps),
'$fetch_term_expansions_module'(Mod, TEs),
'$fetch_foreigns_module'(Mod, Foreigns),
asserta(Mod:'@mod_info'(Source, Exps, MFs, L, Parents, Imps, Metas, ModTransps, Foreigns, TEs)),
open(OF, write, S, [type(binary)]),
'$qsave_module_preds'(S, Mod),
close(S),
abolish(Mod:'@mod_info'/10),
fail.
qsave_module(_, _).
/** @pred qsave_module(+ Module x)
Saves an image of all the information compiled by the systemm on
module _F_ to a file _State.qly_ in the current directory.
**/
qsave_module(Mod) :-
atom_concat(Mod,'.qly',OF),
qsave_module(Mod, OF).
/**
@pred restore(+ _F_)
Restores a previously saved state of YAP from file _F_.
*/
restore(File) :-
open(File, read, S, [type(binary)]),
'$qload_program'(S),
close(S).
/**
@pred qload_module(+ _M_)
Restores a previously save image of module _M_. This built-in searches
for a file M.qly or M according to the rules for qly files.
The q_load_module/1 built-in tries to reload any modules it imports
from and any foreign files that had been loaded with the original
module. It tries first reloading from qly images, but if they are not
available it tries reconsulting the source file.
*/
qload_module(Mod) :-
( current_prolog_flag(verbose_load, false)
->
Verbosity = silent
;
Verbosity = informational
),
StartMsg = loading_module,
EndMsg = module_loaded,
'$current_module'(SourceModule, Mod),
H0 is heapused, '$cputime'(T0,_),
absolute_file_name( Mod, File, [expand(true),file_type(qly)]),
print_message(Verbosity, loading(StartMsg, File)),
file_directory_name( File, Dir),
working_directory(OldD, Dir),
'$qload_module'(Mod, File, SourceModule ),
H is heapused-H0, '$cputime'(TF,_), T is TF-T0,
print_message(Verbosity, loaded(EndMsg, File, Mod, T, H)),
'$current_module'(_, SourceModule),
working_directory(_, OldD).
'$qload_module'(Mod, S, SourceModule) :-
is_stream( S ), !,
'$q_header'( S, Type ),
stream_property( S, file_name( File )),
( Type == module ->
'$qload_module'(S , Mod, File, SourceModule)
;
Type == file ->
'$qload_file'(S, File)
).
'$qload_module'(Mod, File, SourceModule) :-
open(File, read, S, [type(binary)]),
%check verifies if a saved state;
'$q_header'( S, Type ), !,
( Type == module ->
'$qload_module'(S , Mod, File, SourceModule)
;
Type == file ->
'$qload_file'(S, File)
),
!,
close(S).
'$qload_module'(_S, Mod, _File, _SourceModule) :-
unload_module( Mod ), fail.
'$qload_module'(S, _Mod, _File, _SourceModule) :-
'$qload_module_preds'(S), fail.
'$qload_module'(_S, Mod, File, SourceModule) :-
Mod:'@mod_info'(F, Exps, MFs, Line,Parents, Imps, Metas, ModTransps, Foreigns, TEs),
abolish(Mod:'@mod_info'/10),
recorda('$module', '$module'(File, Mod, F, Exps, Line), _),
'$install_parents_module'(Mod, Parents),
'$install_imports_module'(Mod, Imps, []),
'$install_multi_files_module'(Mod, MFs),
'$install_meta_predicates_module'(Mod, Metas),
'$install_foreigns_module'(Mod, Foreigns),
'$install_module_transparents_module'(Mod, ModTransps),
'$install_term_expansions_module'(Mod, TEs),
% last, export everything to the host: if the loading crashed you didn't actually do
% no evil.
'$convert_for_export'(all, Exps, Mod, SourceModule, TranslationTab, _AllExports0, qload_module),
'$add_to_imports'(TranslationTab, Mod, SourceModule). % insert ops, at least for now
'$fetch_imports_module'(Mod, Imports) :-
findall(Info, '$fetch_import_module'(Mod, Info), Imports).
% detect an import that is local to the module.
'$fetch_import_module'(Mod, '$impcort'(Mod0,Mod,G0,G,N,K) - S) :-
recorded('$import', '$import'(Mod0,Mod,G0,G,N,K), _),
( recorded('$module','$module'(_, Mod0, S, _, _), _) -> true ; S = user_input ).
'$fetch_parents_module'(Mod, Parents) :-
findall(Parent, prolog:'$parent_module'(Mod,Parent), Parents).
'$fetch_module_transparents_module'(Mod, Module_Transparents) :-
findall(Info, '$fetch_module_transparent_module'(Mod, Info), Module_Transparents).
% detect an module_transparenterator that is local to the module.
'$fetch_module_transparent_module'(Mod, '$module_transparent'(F,Mod,N,P)) :-
prolog:'$module_transparent'(F,Mod0,N,P), Mod0 == Mod.
'$fetch_meta_predicates_module'(Mod, Meta_Predicates) :-
findall(Info, '$fetch_meta_predicate_module'(Mod, Info), Meta_Predicates).
% detect a meta_predicate that is local to the module.
'$fetch_meta_predicate_module'(Mod, '$meta_predicate'(F,Mod,N,P)) :-
prolog:'$meta_predicate'(F,M,N,P), M==Mod.
'$fetch_multi_files_module'(Mod, Multi_Files) :-
findall(Info, '$fetch_multi_file_module'(Mod, Info), Multi_Files).
% detect an multi_file that is local to the module.
'$fetch_multi_file_module'(Mod, '$defined'(FileName,Name,Arity,Mod)) :-
recorded('$multifile_defs','$defined'(FileName,Name,Arity,Mod), _).
'$fetch_multi_file_module'(Mod, '$mf_clause'(FileName,_Name,_Arity,Mod,Clause), _) :-
recorded('$mf','$mf_clause'(FileName,_Name,_Arity,Mod,ClauseRef), _),
instance(ClauseRef, Clause ).
'$fetch_term_expansions_module'(Mod, TEs) :-
findall(Info, '$fetch_term_expansion_module'(Mod, Info), TEs).
% detect an term_expansionerator that is local to the module.
'$fetch_term_expansion_module'(Mod, ( user:term_expansion(G, GI) :- Bd )) :-
clause( user:term_expansion(G, GI), Bd, _),
strip_module(G, Mod, _).
% detect an term_expansionerator that is local to the module.
'$fetch_term_expansion_module'(Mod, ( system:term_expansion(G, GI) :- Bd )) :-
clause( system:term_expansion(G, GI), Bd, _),
strip_module(G, Mod, _).
% detect an term_expansionerator that is local to the module.
'$fetch_term_expansion_module'(Mod, ( user:goal_expansion(G, CurMod, GI) :- Bd )) :-
clause( user:goal_expansion(G, CurMod, GI), Bd, _),
Mod == CurMod.
% detect an term_expansionerator that is local to the module.
'$fetch_term_expansion_module'(Mod, ( user:goal_expansion(G, GI) :- Bd )) :-
clause( user:goal_expansion(G, GI), Bd, _),
strip_module(G, Mod, _).
% detect an term_expansionerator that is local to the module.
'$fetch_term_expansion_module'(Mod, ( system:goal_expansion(G, GI) :- Bd )) :-
clause( system:goal_expansion(G, GI), Bd, _),
strip_module(G, Mod, _).
'$fetch_foreigns_module'(Mod, Foreigns) :-
findall(Info, '$fetch_foreign_module'(Mod, Info), Foreigns).
% detect an term_expansionerator that is local to the module.
'$fetch_foreign_module'(Mod,Foreign) :-
recorded( '$foreign', Mod:Foreign, _).
'$install_term_expansions_module'(_, []).
'$install_term_expansions_module'(Mod, [TE|TEs]) :-
assert(TE),
'$install_term_expansions_module'(Mod, TEs).
'$install_imports_module'(_, [], Fs0) :-
sort(Fs0, Fs),
'$restore_load_files'(Fs).
'$install_imports_module'(Mod, [Import-F|Imports], Fs0) :-
recordz('$import', Import, _),
arg(1, Import, M),
'$install_imports_module'(Mod, Imports, [M-F|Fs0]).
'$restore_load_files'([]).
'$restore_load_files'([M-F0|Fs]) :-
(
absolute_file_name( M,_File, [expand(true),file_type(qly),access(read),file_errors(fail)])
->
qload_module(M)
;
use_module(M, F0, _)
),
'$restore_load_files'(Fs).
'$install_parents_module'(_, []).
'$install_parents_module'(Mod, [Parent|Parents]) :-
assert(prolog:Parent),
'$install_parents_module'(Mod, Parents).
'$install_module_transparents_module'(_, []).
'$install_module_transparents_module'(Mod, [Module_Transparent|Module_Transparents]) :-
assert(prolog:Module_Transparent),
'$install_module_transparents_module'(Mod, Module_Transparents).
'$install_meta_predicates_module'(_, []).
'$install_meta_predicates_module'(Mod, [Meta_Predicate|Meta_Predicates]) :-
assert(prolog:Meta_Predicate),
'$install_meta_predicates_module'(Mod, Meta_Predicates).
'$install_multi_files_module'(_, []).
'$install_multi_files_module'(Mod, [Multi_File|Multi_Files]) :-
recordz('$multifile_defs',Multi_File, _),
'$install_multi_files_module'(Mod, Multi_Files).
'$install_foreigns_module'(_, []).
'$install_foreigns_module'(Mod, [Foreign|Foreigns]) :-
'$do_foreign'(Foreign, Foreigns),
'$install_foreigns_module'(Mod, Foreigns).
'$do_foreign'('$foreign'(Objs,Libs,Entry), _) :-
load_foreign_files(Objs,Libs,Entry).
'$do_foreign'('$swi_foreign'(File, Opts, Handle), More) :-
open_shared_object(File, Opts, Handle, NewHandle),
'$init_foreigns'(More, NewHandle).
'$do_foreign'('$swi_foreign'(_,_), _More).
'$init_foreigns'([], _Handle, _NewHandle).
'$init_foreigns'(['$swi_foreign'( Handle, Function )|More], Handle, NewHandle) :-
!,
call_shared_object_function( NewHandle, Function),
'$init_foreigns'(More, Handle, NewHandle).
'$init_foreigns'([_|More], Handle, NewHandle) :-
'$init_foreigns'(More, Handle, NewHandle).
/**
@pred qload_file(+ _F_)
Restores a previously saved state of YAP contaianing a qly file _F_.
*/
qload_file( F0 ) :-
( current_prolog_flag(verbose_load, false)
->
Verbosity = silent
;
Verbosity = informational
),
StartMsg = loading_module,
EndMsg = module_loaded,
'$current_module'( SourceModule ),
H0 is heapused,
'$cputime'(T0,_),
( is_stream( F0 )
->
stream_property(F0, file_name(File) ),
File = FilePl,
S = File
;
absolute_file_name( F0, File, [expand(true),file_type(qly)]),
absolute_file_name( F0, FilePl, [expand(true),file_type(prolog)]),
unload_file( FilePl ),
open(File, read, S, [type(binary)])
),
print_message(Verbosity, loading(StartMsg, File)),
file_directory_name(File, DirName),
working_directory(OldD, DirName),
'$q_header'( S, Type ),
( Type == module ->
'$qload_module'(S , Mod, File, SourceModule)
;
Type == file ->
'$lf_option'(last_opt, LastOpt),
functor( TOpts, opt, LastOpt ),
'$lf_default_opts'(1, LastOpt, TOpts),
'$qload_file'(S, SourceModule, File, FilePl, F0, all, TOpts)
),
close(S),
working_directory( _, OldD),
H is heapused-H0, '$cputime'(TF,_), T is TF-T0,
'$current_module'(Mod, Mod ),
print_message(Verbosity, loaded(EndMsg, File, Mod, T, H)),
'$exec_initialization_goals'.
'$qload_file'(_S, SourceModule, _F, FilePl, _F0, _ImportList, _TOpts) :-
recorded('$source_file','$source_file'( FilePl, _Age, SourceModule), _),
!.
'$qload_file'(_S, SourceModule, _F, FilePl, _F0, _ImportList, _TOpts) :-
( FilePl == user_input -> Age = 0 ; time_file64(FilePl, Age) ),
recordaifnot('$source_file','$source_file'( FilePl, Age, SourceModule), _),
fail.
'$qload_file'(S, _SourceModule, _File, _FilePl, _F0, _ImportList, _TOpts) :-
'$qload_file_preds'(S),
fail.
'$qload_file'(_S, SourceModule, F, _FilePl, _F0, _ImportList, _TOpts) :-
user:'$file_property'( '$lf_loaded'( F, Age, _ ) ),
recordaifnot('$source_file','$source_file'( F, Age, SourceModule), _),
fail.
'$qload_file'(_S, _SourceModule, _File, FilePl, F0, _ImportList, _TOpts) :-
b_setval('$user_source_file', F0 ),
'$ql_process_directives'( FilePl ),
fail.
'$qload_file'(_S, SourceModule, _File, FilePl, _F0, ImportList, TOpts) :-
'$import_to_current_module'(FilePl, SourceModule, ImportList, _, TOpts).
'$ql_process_directives'( FilePl ) :-
user:'$file_property'( '$lf_loaded'( FilePl, M, Reconsult, UserFile, OldF, Line, Opts) ),
recorda('$lf_loaded','$lf_loaded'( FilePl, M, Reconsult, UserFile, OldF, Line, Opts), _),
fail.
'$ql_process_directives'( _FilePl ) :-
user:'$file_property'( multifile( List ) ),
lists:member( Clause, List ),
assert( Clause ),
fail.
'$ql_process_directives'( FilePl ) :-
user:'$file_property'( directive( MG, _Mode, VL, Pos ) ),
'$set_source'( FilePl, Pos ),
'$yap_strip_module'(MG, M, G),
'$process_directive'(G, reconsult, M, VL, Pos),
fail.
'$ql_process_directives'( _FilePl ) :-
abolish(user:'$file_property'/1).
%% @}

View File

@@ -1,86 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-2010 *
* *
**************************************************************************
* *
* File: save.yap *
* Last rev: 11/29/10 *
* mods: *
* comments: Some utility predicates to support save/restore in yap *
* *
*************************************************************************/
:- system_module( '$_save', [], []).
%%% Saving and restoring a computation
/*
save(A) :- save(A,_).
save(A,_) :- var(A), !,
'$do_error'(instantiation_error,save(A)).
save(A,OUT) :- atom(A), !, atom_codes(A,S), '$save'(S,OUT).
save(S,OUT) :- '$save'(S,OUT).
save_program(A) :- var(A), !,
'$do_error'(instantiation_error,save_program(A)).
save_program(A) :- atom(A), !,
atom_codes(A,S),
'$save_program2'(S, true).
save_program(S) :- '$save_program2'(S, true).
save_program(A, G) :- var(A), !,
'$do_error'(instantiation_error, save_program(A,G)).
save_program(A, G) :- var(G), !,
'$do_error'(instantiation_error, save_program(A,G)).
save_program(A, G) :- \+ callable(G), !,
'$do_error'(type_error(callable,G), save_program(A,G)).
save_program(A, G) :-
( atom(A) -> atom_codes(A,S) ; A = S),
'$save_program2'(S, G),
fail.
save_program(_,_).
'$save_program2'(S,G) :-
(
G == true
->
true
;
recorda('$restore_goal', G ,R)
),
(
'$undefined'(reload_foreign_libraries, shlib)
->
true
;
recorda('$reload_foreign_libraries', true, R1)
),
'$save_program'(S),
(
var(R1)
->
true
;
erase(R1)
),
(
var(R)
->
true
;
erase(R)
),
fail.
'$save_program2'(_,_).
restore(A) :- var(A), !,
'$do_error'(instantiation_error,restore(A)).
restore(A) :- atom(A), !, name(A,S), '$restore'(S).
restore(S) :- '$restore'(S).
*/

View File

@@ -1,342 +0,0 @@
/*************************************************************************
* *
* YAP Prolog %W% %G%
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: setof.pl *
* Last rev: *
* mods: *
* comments: set predicates *
* *
*************************************************************************/
/**
* @file setof.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Thu Nov 19 10:45:32 2015
*
* @brief Setof and friends.
*
*
*/
:- system_module( '$_setof', [(^)/2,
all/3,
bagof/3,
findall/3,
findall/4,
setof/3], []).
/**
@defgroup Sets Collecting Solutions to a Goal
@ingroup builtins
When there are several solutions to a goal, if the user wants to collect all
the solutions he may be led to use the data base, because backtracking will
forget previous solutions.
YAP allows the programmer to choose from several system
predicates instead of writing his own routines. findall/3 gives you
the fastest, but crudest solution. The other built-in predicates
post-process the result of the query in several different ways:
@{
*/
:- use_system_module( '$_boot', ['$catch'/3]).
:- use_system_module( '$_errors', ['$do_error'/2]).
% this is used by the all predicate
:- op(50,xfx,same).
%% @pred ^/2
%
% The "existential quantifier" symbol is only significant to bagof
% and setof, which it stops binding the quantified variable.
% op(200, xfy, ^) is defined during bootstrap.
_^Goal :-
'$execute'(Goal).
/** @pred findall( _T_,+ _G_,- _L_) is iso
findall/3 is a simplified version of bagof which has an implicit
existential quantifier on every variable.
Unifies _L_ with a list that contains all the instantiations of the
term _T_ satisfying the goal _G_.
With the following program:
~~~~~
a(2,1).
a(1,1).
a(2,2).
~~~~~
the answer to the query
~~~~~
findall(X,a(X,Y),L).
~~~~~
would be:
~~~~~
X = _32
Y = _33
L = [2,1,2];
no
~~~~~
*/
findall(Template, Generator, Answers) :-
must_be_of_type( list_or_partial_list, Answers ),
'$findall'(Template, Generator, [], Answers).
% If some answers have already been found
/** @pred findall( ?Key, +Goal, +InitialSolutions, -Solutions )
Similar to findall/3, but appends all answers to list _L0_.
*/
findall(Template, Generator, Answers, SoFar) :-
must_be_of_type( list_or_partial_list, Answers ),
'$findall'(Template, Generator, SoFar, Answers).
% starts by calling the generator,
% and recording the answers
'$findall'(Template, Generator, SoFar, Answers) :-
nb:nb_queue(Ref),
(
'$execute'(Generator),
nb:nb_queue_enqueue(Ref, Template),
fail
;
nb:nb_queue_close(Ref, Answers, SoFar)
).
% findall_with_key is very similar to findall, but uses the SICStus
% algorithm to guarantee that variables will have the same names.
%
'$findall_with_common_vars'(Template, Generator, Answers) :-
nb:nb_queue(Ref),
(
'$execute'(Generator),
nb:nb_queue_enqueue(Ref, Template),
fail
;
nb:nb_queue_close(Ref, Answers, []),
'$collect_with_common_vars'(Answers, _)
).
'$collect_with_common_vars'([], _).
'$collect_with_common_vars'([Key-_|Answers], VarList) :-
'$variables_in_term'(Key, _, VarList),
'$collect_with_common_vars'(Answers, VarList).
% This is the setof predicate
/** @pred setof( _X_,+ _P_,- _B_) is iso
Similar to `bagof( _T_, _G_, _L_)` but sorts list
_L_ and keeping only one copy of each element. Again, assuming the
same clauses as in the examples above, the reply to the query
~~~~~
setof(X,a(X,Y),L).
~~~~~
would be:
~~~~~
X = _32
Y = 1
L = [1,2];
X = _32
Y = 2
L = [2];
no
~~~~~
*/
setof(Template, Generator, Set) :-
( '$is_list_or_partial_list'(Set) ->
true
;
'$do_error'(type_error(list,Set), setof(Template, Generator, Set))
),
'$bagof'(Template, Generator, Bag),
'$sort'(Bag, Set).
% And this is bagof
% Either we have excess of variables
% and we need to find the solutions for each instantiation
% of these variables
/** @pred bagof( _T_,+ _G_,- _L_) is iso
For each set of possible instances of the free variables occurring in
_G_ but not in _T_, generates the list _L_ of the instances of
_T_ satisfying _G_. Again, assuming the same clauses as in the
examples above, the reply to the query
~~~~~
bagof(X,a(X,Y),L).
would be:
X = _32
Y = 1
L = [2,1];
X = _32
Y = 2
L = [2];
no
~~~~~
*/
bagof(Template, Generator, Bag) :-
( '$is_list_or_partial_list'(Bag) ->
true
;
'$do_error'(type_error(list,Bag), bagof(Template, Generator, Bag))
),
'$bagof'(Template, Generator, Bag).
'$bagof'(Template, Generator, Bag) :-
'$free_variables_in_term'(Template^Generator, StrippedGenerator, Key),
%format('TemplateV=~w v=~w ~w~n',[TemplateV,Key, StrippedGenerator]),
( Key \== '$' ->
'$findall_with_common_vars'(Key-Template, StrippedGenerator, Bags0),
'$keysort'(Bags0, Bags),
'$pick'(Bags, Key, Bag)
;
'$findall'(Template, StrippedGenerator, [], Bag0),
Bag0 \== [],
Bag = Bag0
).
% picks a solution attending to the free variables
'$pick'([K-X|Bags], Key, Bag) :-
'$parade'(Bags, K, Bag1, Bags1),
'$decide'(Bags1, [X|Bag1], K, Key, Bag).
'$parade'([K-X|L1], Key, [X|B], L) :- K == Key, !,
'$parade'(L1, Key, B, L).
'$parade'(L, _, [], L).
%
% The first argument to decide gives if solutions still left;
% The second gives the solution currently found;
% The third gives the free variables that are supposed to be bound;
% The fourth gives the free variables being currently used.
% The fifth outputs the current solution.
%
'$decide'([], Bag, Key0, Key, Bag) :- !,
Key0=Key.
'$decide'(_, Bag, Key, Key, Bag).
'$decide'(Bags, _, _, Key, Bag) :-
'$pick'(Bags, Key, Bag).
% as an alternative to setof you can use the predicate all(Term,Goal,Solutions)
% But this version of all does not allow for repeated answers
% if you want them use findall
/** @pred all( _T_,+ _G_,- _L_)
Similar to `findall( _T_, _G_, _L_)` but eliminate
repeated elements. Thus, assuming the same clauses as in the above
example, the reply to the query
~~~~~
all(X,a(X,Y),L).
~~~~~
would be:
~~~~~
X = _32
Y = _33
L = [2,1];
no
~~~~~
Note that all/3 will fail if no answers are found.
*/
all(T, G same X,S) :- !, all(T same X,G,Sx), '$$produce'(Sx,S,X).
all(T,G,S) :-
'$init_db_queue'(Ref),
( catch(G, Error,'$clean_findall'(Ref,Error) ),
'$execute'(G),
'$db_enqueue'(Ref, T),
fail
;
'$$set'(S,Ref)
).
% $$set does its best to preserve space
'$$set'(S,R) :-
'$$build'(S0,_,R),
S0 = [_|_],
S = S0.
'$$build'(Ns,S0,R) :- '$db_dequeue'(R,X), !,
'$$build2'(Ns,S0,R,X).
'$$build'([],_,_).
'$$build2'([X|Ns],Hash,R,X) :-
'$$new'(Hash,X), !,
'$$build'(Ns,Hash,R).
'$$build2'(Ns,Hash,R,_) :-
'$$build'(Ns,Hash,R).
'$$new'(V,El) :- var(V), !, V = n(_,El,_).
'$$new'(n(R,El0,L),El) :-
compare(C,El0,El),
'$$new'(C,R,L,El).
'$$new'(=,_,_,_) :- !, fail.
'$$new'(<,R,_,El) :- '$$new'(R,El).
'$$new'(>,_,L,El) :- '$$new'(L,El).
'$$produce'([T1 same X1|Tn],S,X) :- '$$split'(Tn,T1,X1,S1,S2),
( S=[T1|S1], X=X1;
!, produce(S2,S,X) ).
'$$split'([],_,_,[],[]).
'$$split'([T same X|Tn],T,X,S1,S2) :- '$$split'(Tn,T,X,S1,S2).
'$$split'([T1 same X|Tn],T,X,[T1|S1],S2) :- '$$split'(Tn,T,X,S1,S2).
'$$split'([T1|Tn],T,X,S1,[T1|S2]) :- '$$split'(Tn,T,X,S1,S2).
/**
@}
*/

View File

@@ -1,369 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: signals.pl *
* Last rev: *
* mods: *
* comments: signal handling in YAP *
* *
*************************************************************************/
%%! @addtogroup OS
%% @{
:- system_module( '$_signals', [alarm/3,
on_exception/3,
on_signal/3,
raise_exception/1,
read_sig/0], []).
:- use_system_module( '$_boot', ['$meta_call'/2]).
:- use_system_module( '$_debug', ['$do_spy'/4]).
:- use_system_module( '$_threads', ['$thread_gfetch'/1]).
/** @pred alarm(+ _Seconds_,+ _Callable_,+ _OldAlarm_)
Arranges for YAP to be interrupted in _Seconds_ seconds, or in
[ _Seconds_| _MicroSeconds_]. When interrupted, YAP will execute
_Callable_ and then return to the previous execution. If
_Seconds_ is `0`, no new alarm is scheduled. In any event,
any previously set alarm is canceled.
The variable _OldAlarm_ unifies with the number of seconds remaining
until any previously scheduled alarm was due to be delivered, or with
`0` if there was no previously scheduled alarm.
Note that execution of _Callable_ will wait if YAP is
executing built-in predicates, such as Input/Output operations.
The next example shows how _alarm/3_ can be used to implement a
simple clock:
~~~~~
loop :- loop.
ticker :- write('.'), flush_output,
get_value(tick, yes),
alarm(1,ticker,_).
:- set_value(tick, yes), alarm(1,ticker,_), loop.
~~~~~
The clock, `ticker`, writes a dot and then checks the flag
`tick` to see whether it can continue ticking. If so, it calls
itself again. Note that there is no guarantee that the each dot
corresponds a second: for instance, if the YAP is waiting for
user input, `ticker` will wait until the user types the entry in.
The next example shows how alarm/3 can be used to guarantee that
a certain procedure does not take longer than a certain amount of time:
~~~~~
loop :- loop.
:- catch((alarm(10, throw(ball), _),loop),
ball,
format('Quota exhausted.~n',[])).
~~~~~
In this case after `10` seconds our `loop` is interrupted,
`ball` is thrown, and the handler writes `Quota exhausted`.
Execution then continues from the handler.
Note that in this case `loop/0` always executes until the alarm is
sent. Often, the code you are executing succeeds or fails before the
alarm is actually delivered. In this case, you probably want to disable
the alarm when you leave the procedure. The next procedure does exactly so:
~~~~~
once_with_alarm(Time,Goal,DoOnAlarm) :-
catch(execute_once_with_alarm(Time, Goal), alarm, DoOnAlarm).
execute_once_with_alarm(Time, Goal) :-
alarm(Time, alarm, _),
( call(Goal) -> alarm(0, alarm, _) ; alarm(0, alarm, _), fail).
~~~~~
The procedure `once_with_alarm/3` has three arguments:
the _Time_ to wait before the alarm is
sent; the _Goal_ to execute; and the goal _DoOnAlarm_ to execute
if the alarm is sent. It uses catch/3 to handle the case the
`alarm` is sent. Then it starts the alarm, calls the goal
_Goal_, and disables the alarm on success or failure.
*/
/** @pred on_signal(+ _Signal_,? _OldAction_,+ _Callable_)
Set the interrupt handler for soft interrupt _Signal_ to be
_Callable_. _OldAction_ is unified with the previous handler.
Only a subset of the software interrupts (signals) can have their
handlers manipulated through on_signal/3.
Their POSIX names, YAP names and default behavior is given below.
The "YAP name" of the signal is the atom that is associated with
each signal, and should be used as the first argument to
on_signal/3. It is chosen so that it matches the signal's POSIX
name.
on_signal/3 succeeds, unless when called with an invalid
signal name or one that is not supported on this platform. No checks
are made on the handler provided by the user.
+ sig_up (Hangup)
SIGHUP in Unix/Linux; Reconsult the initialization files
~/.yaprc, ~/.prologrc and ~/prolog.ini.
+ sig_usr1 and sig_usr2 (User signals)
SIGUSR1 and SIGUSR2 in Unix/Linux; Print a message and halt.
A special case is made, where if _Callable_ is bound to
`default`, then the default handler is restored for that signal.
A call in the form `on_signal( _S_, _H_, _H_)` can be used
to retrieve a signal's current handler without changing it.
It must be noted that although a signal can be received at all times,
the handler is not executed while YAP is waiting for a query at the
prompt. The signal will be, however, registered and dealt with as soon
as the user makes a query.
Please also note, that neither POSIX Operating Systems nor YAP guarantee
that the order of delivery and handling is going to correspond with the
order of dispatch.
*/
:- meta_predicate on_signal(+,?,:), alarm(+,:,-).
'$creep'(G) :-
% get the first signal from the mask
'$first_signal'(Sig), !,
% process it
'$do_signal'(Sig, G).
'$creep'([M|G]) :-
% noise, just go on with our life.
'$execute'(M:G).
'$do_signal'(sig_wake_up, G) :-
'$awoken_goals'(LG),
% if more signals alive, set creep flag
'$continue_signals',
'$wake_up_goal'(G, LG).
% never creep on entering system mode!!!
% don't creep on meta-call.
'$do_signal'(sig_creep, MG) :-
'$start_creep'(MG, creep).
'$do_signal'(sig_iti, [M|G]) :-
'$thread_gfetch'(Goal),
% if more signals alive, set creep flag
'$continue_signals',
'$current_module'(M0),
'$execute0'(Goal,M0),
'$execute'(M:G).
'$do_signal'(sig_trace, [M|G]) :-
'$continue_signals',
trace,
'$execute'(M:G).
'$do_signal'(sig_debug, [M|G]) :-
'$continue_signals',
debug,
'$execute'(M:G).
'$do_signal'(sig_break, [M|G]) :-
'$continue_signals',
break,
'$execute0'(G,M).
'$do_signal'(sig_statistics, [M|G]) :-
'$continue_signals',
statistics,
'$execute0'(G,M).
% the next one should never be called...
'$do_signal'(fail, [_|_]) :-
fail.
'$do_signal'(sig_stack_dump, [M|G]) :-
'$continue_signals',
'$hacks':'$stack_dump',
'$execute0'(G,M).
'$do_signal'(sig_fpe,G) :-
'$signal_handler'(sig_fpe, G).
'$do_signal'(sig_alarm, G) :-
'$signal_handler'(sig_alarm, G).
'$do_signal'(sig_vtalarm, G) :-
'$signal_handler'(sig_vtalarm, G).
'$do_signal'(sig_hup, G) :-
'$signal_handler'(sig_hup, G).
'$do_signal'(sig_usr1, G) :-
'$signal_handler'(sig_usr1, G).
'$do_signal'(sig_usr2, G) :-
'$signal_handler'(sig_usr2, G).
'$do_signal'(sig_pipe, G) :-
'$signal_handler'(sig_pipe, G).
'$signal_handler'(Sig, [M|G]) :-
'$signal_do'(Sig, Goal),
% if more signals alive, set creep flag
'$continue_signals',
'$current_module'(M0),
'$execute0'((Goal,M:G),M0).
% we may be creeping outside and coming back to system mode.
'$start_creep'([_M|G], _) :-
nonvar(G),
G = '$$cut_by'(CP),
!,
'$$cut_by'(CP).
'$start_creep'([M|G], _) :-
'$is_no_trace'(G, M), !,
(
'$$save_by'(CP),
'$no_creep_call'(G,M),
'$$save_by'(CP2),
'$disable_debugging',
(CP == CP2 -> ! ; ( true ; '$enable_debugging', fail ) ),
'$enable_debugging'
;
'$disable_debugging',
fail
).
'$start_creep'([Mod|G], WhereFrom) :-
CP is '$last_choice_pt',
'$do_spy'(G, Mod, CP, WhereFrom).
'$no_creep_call'('$execute_clause'(G,Mod,Ref,CP),_) :- !,
'$enable_debugging',
'$execute_clause'(G,Mod,Ref,CP).
'$no_creep_call'('$execute_nonstop'(G, M),_) :- !,
'$enable_debugging',
'$execute_nonstop'(G, M).
'$no_creep_call'(G, M) :-
'$enable_debugging',
'$execute_nonstop'(G, M).
'$execute_goal'(G, Mod) :-
(
'$is_metapredicate'(G, Mod)
->
'$meta_call'(G,Mod)
;
'$execute_nonstop'(G,Mod)
).
'$signal_do'(Sig, Goal) :-
recorded('$signal_handler', action(Sig,Goal), _), !.
'$signal_do'(Sig, Goal) :-
'$signal_def'(Sig, Goal).
% reconsult init files.
'$signal_def'(sig_hup, (( exists('~/.yaprc') -> [-'~/.yaprc'] ; true ),
( exists('~/.prologrc') -> [-'~/.prologrc'] ; true ),
( exists('~/prolog.ini') -> [-'~/prolog.ini'] ; true ))).
% die on signal default.
'$signal_def'(sig_usr1, throw(error(signal(usr1,[]),true))).
'$signal_def'(sig_usr2, throw(error(signal(usr2,[]),true))).
'$signal_def'(sig_pipe, throw(error(signal(pipe,[]),true))).
'$signal_def'(sig_fpe, throw(error(signal(fpe,[]),true))).
% ignore sig_alarm by default
'$signal_def'(sig_alarm, true).
'$signal'(sig_hup).
'$signal'(sig_usr1).
'$signal'(sig_usr2).
'$signal'(sig_pipe).
'$signal'(sig_alarm).
'$signal'(sig_vtalarm).
'$signal'(sig_fpe).
on_signal(Signal,OldAction,NewAction) :-
var(Signal), !,
(nonvar(OldAction) -> throw(error(instantiation_error,on_signal/3)) ; true),
'$signal'(Signal),
on_signal(Signal, OldAction, NewAction).
on_signal(Signal,OldAction,default) :-
'$reset_signal'(Signal, OldAction).
on_signal(_Signal,_OldAction,Action) :-
var(Action), !,
throw(error('SYSTEM_ERROR_INTERNAL','Somehow the meta_predicate declarations of on_signal are subverted!')).
on_signal(Signal,OldAction,Action) :-
Action = (_:Goal),
var(Goal), !,
'$check_signal'(Signal, OldAction),
Goal = OldAction.
on_signal(Signal,OldAction,Action) :-
'$reset_signal'(Signal, OldAction),
% 13211-2 speaks only about callable
( Action = M:Goal -> true ; throw(error(type_error(callable,Action),on_signal/3)) ),
% the following disagrees with 13211-2:6.7.1.4 which disagrees with 13211-1:7.12.2a
% but the following agrees with 13211-1:7.12.2a
( nonvar(M) -> true ; throw(error(instantiation_error,on_signal/3)) ),
( atom(M) -> true ; throw(error(type_error(callable,Action),on_signal/3)) ),
( nonvar(Goal) -> true ; throw(error(instantiation_error,on_signal/3)) ),
recordz('$signal_handler', action(Signal,Action), _).
'$reset_signal'(Signal, OldAction) :-
recorded('$signal_handler', action(Signal,OldAction), Ref), !,
erase(Ref).
'$reset_signal'(_, default).
'$check_signal'(Signal, OldAction) :-
recorded('$signal_handler', action(Signal,OldAction), _), !.
'$check_signal'(_, default).
alarm(Interval, Goal, Left) :-
Interval == 0, !,
'$alarm'(0, 0, Left0, _),
on_signal(sig_alarm, _, Goal),
Left = Left0.
alarm(Interval, Goal, Left) :-
integer(Interval), !,
on_signal(sig_alarm, _, Goal), '$alarm'(Interval, 0, Left, _).
alarm(Number, Goal, Left) :-
float(Number), !,
Secs is integer(Number),
USecs is integer((Number-Secs)*1000000) mod 1000000,
on_signal(sig_alarm, _, Goal),
'$alarm'(Secs, USecs, Left, _).
alarm([Interval|USecs], Goal, [Left|LUSecs]) :-
on_signal(sig_alarm, _, Goal),
'$alarm'(Interval, USecs, Left, LUSecs).
raise_exception(Ball) :- throw(Ball).
on_exception(Pat, G, H) :- catch(G, Pat, H).
read_sig :-
recorded('$signal_handler',X,_),
writeq(X),nl,
fail.
read_sig.
%
% make thes predicates non-traceable.
:- '$set_no_trace'(current_choicepoint(_DCP), yap_hacks).
:- '$set_no_trace'('$current_choice_point'(_DCP), _).
:- '$set_no_trace'('$$cut_by'(_DCP), prolog).
:- '$set_no_trace'(true, yap_hacks).
:- '$set_no_trace'(true, prolog).
:- '$set_no_trace'('$call'(_,_,_,_), prolog).
:- '$set_no_trace'('$execute_nonstop'(_,_), prolog).
:- '$set_no_trace'('$execute_clause'(_,_,_,_), prolog).
:- '$set_no_trace'('$restore_regs'(_,_), prolog).
:- '$set_no_trace'('$undefp0'(_,_), prolog).
:- '$set_no_trace'('$Error'(_), prolog).
:- '$set_no_trace'('$LoopError'(_,_), prolog).
:- '$set_no_trace'('$TraceError'(_,_,_,_,_), prolog).
:- '$set_no_trace'('$run_catch'(_,_), prolog).
%%! @}

View File

@@ -1,166 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: sort.pl *
* Last rev: *
* mods: *
* comments: sorting in Prolog *
* *
*************************************************************************/
:- system_module( '$_sort', [keysort/2,
length/2,
msort/2,
predmerge/4,
predmerge/7,
predsort/3,
predsort/5,
sort/2,
sort2/4], []).
:- use_system_module( '$_errors', ['$do_error'/2]).
/** @addtogroup Comparing_Terms
*/
/* The three sorting routines are all variations of merge-sort, done by
bisecting the list, sorting the nearly equal halves, and merging the
results. The half-lists aren't actually constructed, the number of
elements is counted instead (which is why 'length' is in this file).
*/
/** @pred sort(+ _L_,- _S_) is iso
Unifies _S_ with the list obtained by sorting _L_ and merging
identical (in the sense of `==`) elements.
*/
sort(L,O) :-
'$skip_list'(NL,L,RL),
( RL == [] -> true ;
var(RL) -> '$do_error'(instantiation_error,sort(L,O)) ;
'$do_error'(type_error(list,L),sort(L,O))
),
(
nonvar(O)
->
(
O == []
->
L == []
;
'$skip_list'(NO,O,RO),
( RO == [] -> NO =< NL ;
var(RO) -> NO =< NL ;
'$do_error'(type_error(list,O),sort(L,O))
)
)
; true
),
'$sort'(L,O).
msort(L,O) :-
'$msort'(L,O).
/** @pred keysort(+ _L_, _S_) is iso
Assuming L is a list of the form ` _Key_- _Value_`,
`keysort(+ _L_, _S_)` unifies _S_ with the list obtained
from _L_, by sorting its elements according to the value of
_Key_.
~~~~~{.prolog}
?- keysort([3-a,1-b,2-c,1-a,1-b],S).
~~~~~
would return:
~~~~~{.prolog}
S = [1-b,1-a,1-b,2-c,3-a]
~~~~~
*/
keysort(L,O) :-
'$skip_list'(NL,L,RL),
( RL == [] -> true ;
var(RL) -> '$do_error'(instantiation_error,sort(L,O)) ;
'$do_error'(type_error(list,L),sort(L,O))
),
(
nonvar(O)
->
'$skip_list'(NO,O,RO),
( RO == [] -> NO =:= NL ;
var(RO) -> NO =< NL ;
'$do_error'(type_error(list,O),sort(L,O))
)
; true
),
'$keysort'(L,O).
:- meta_predicate prolog:predsort(3,+,-).
%% predsort(:Compare, +List, -Sorted) is det.
%
% Sorts similar to sort/2, but determines the order of two terms
% by calling Compare(-Delta, +E1, +E2). This call must unify
% Delta with one of <, > or =. If built-in predicate compare/3 is
% used, the result is the same as sort/2. See also keysort/2.
/** @pred predsort(+ _Pred_, + _List_, - _Sorted_)
Sorts similar to sort/2, but determines the order of two terms by
calling _Pred_(- _Delta_, + _E1_, + _E2_) . This call must
unify _Delta_ with one of `<`, `>` or `=`. If
built-in predicate compare/3 is used, the result is the same as
sort/2.
*/
predsort(P, L, R) :-
length(L, N),
predsort(P, N, L, _, R1), !,
R = R1.
predsort(P, 2, [X1, X2|L], L, R) :- !,
call(P, Delta, X1, X2),
sort2(Delta, X1, X2, R).
predsort(_, 1, [X|L], L, [X]) :- !.
predsort(_, 0, L, L, []) :- !.
predsort(P, N, L1, L3, R) :-
N1 is N // 2,
plus(N1, N2, N),
predsort(P, N1, L1, L2, R1),
predsort(P, N2, L2, L3, R2),
predmerge(P, R1, R2, R).
sort2(<, X1, X2, [X1, X2]).
sort2(=, X1, _, [X1]).
sort2(>, X1, X2, [X2, X1]).
predmerge(_, [], R, R) :- !.
predmerge(_, R, [], R) :- !.
predmerge(P, [H1|T1], [H2|T2], Result) :-
call(P, Delta, H1, H2),
predmerge(Delta, P, H1, H2, T1, T2, Result).
predmerge(>, P, H1, H2, T1, T2, [H2|R]) :-
predmerge(P, [H1|T1], T2, R).
predmerge(=, P, H1, _, T1, T2, [H1|R]) :-
predmerge(P, T1, T2, R).
predmerge(<, P, H1, H2, T1, T2, [H1|R]) :-
predmerge(P, T1, [H2|T2], R).
%%! @}

View File

@@ -1,395 +0,0 @@
:- system_module( '$_debug', [debug/0,
debugging/0,
leash/1,
nodebug/0,
(nospy)/1,
nospyall/0,
notrace/0,
(spy)/1,
trace/0], [
'$init_debugger'/0]).
:- use_system_module( '$_boot', ['$find_goal_definition'/4,
'$system_catch'/4]).
:- use_system_module( '$_errors', ['$Error'/1,
'$do_error'/2]).
:- use_system_module( '$_init', ['$system_module'/1]).
:- use_system_module( '$_modules', ['$meta_expansion'/6]).
:- use_system_module( '$_preds', ['$clause'/4]).
/*-----------------------------------------------------------------------------
Debugging / creating spy points
-----------------------------------------------------------------------------*/
/** @defgroup Deb_Preds Debugging Predicates
@ingroup builtins
@{
The
following predicates are available to control the debugging of
programs:
+ debug
Switches the debugger on.
+ debuggi=
r
g
Outputs status information about the debugger which includes the leash
mode and the existing spy-points, when the debugger is on.
+ nodebug
Switches the debugger off.
*/
:- op(900,fx,[spy,nospy]).
'$init_debugger' :-
'__NB_getval__'('$trace', _, fail), !.
'$init_debugger' :-
'$debugger_input',
'__NB_setval__'('$trace',off),
'__NB_setval__'('$if_skip_mode',no_skip),
'__NB_setval__'('$spy_glist',[]),
'__NB_setval__'('$spy_gn',1),
'__NB_setval__'('$debug_run',off),
'__NB_setval__'('$debug_jump',false).
% First part : setting and reseting spy points
% $suspy does most of the work
'$suspy'(V,S,M) :- var(V) , !,
'$do_error'(instantiation_error,M:spy(V,S)).
'$suspy'((M:S),P,_) :- !,
'$suspy'(S,P,M).
'$suspy'([],_,_) :- !.
'$suspy'([F|L],S,M) :- !, ( '$suspy'(F,S,M) ; '$suspy'(L,S,M) ).
'$suspy'(F/N,S,M) :- !,
functor(T,F,N),
'$do_suspy'(S, F, N, T, M).
'$suspy'(A,S,M) :- atom(A), !,
'$suspy_predicates_by_name'(A,S,M).
'$suspy'(P,spy,M) :- !,
'$do_error'(domain_error(predicate_spec,P),spy(M:P)).
'$suspy'(P,nospy,M) :-
'$do_error'(domain_error(predicate_spec,P),nospy(M:P)).
'$suspy_predicates_by_name'(A,S,M) :-
% just check one such predicate exists
(
current_predicate(A,M:_)
->
M = EM,
A = NA
;
recorded('$import','$import'(EM,M,GA,_,A,_),_),
functor(GA,NA,_)
),
!,
'$do_suspy_predicates_by_name'(NA,S,EM).
'$suspy_predicates_by_name'(A,spy,M) :- !,
print_message(warning,no_match(spy(M:A))).
'$suspy_predicates_by_name'(A,nospy,M) :-
print_message(warning,no_match(nospy(M:A))).
'$do_suspy_predicates_by_name'(A,S,M) :-
current_predicate(A,M:T),
functor(T,A,N),
'$do_suspy'(S, A, N, T, M).
'$do_suspy_predicates_by_name'(A, S, M) :-
recorded('$import','$import'(EM,M,_,T,A,N),_),
'$do_suspy'(S, A, N, T, EM).
%
% protect against evil arguments.
%
'$do_suspy'(S, F, N, T, M) :-
recorded('$import','$import'(EM,M,T0,_,F,N),_), !,
functor(T0, F0, N0),
'$do_suspy'(S, F0, N0, T, EM).
'$do_suspy'(S, F, N, T, M) :-
'$undefined'(T,M), !,
( S = spy ->
print_message(warning,no_match(spy(M:F/N)))
;
print_message(warning,no_match(nospy(M:F/N)))
).
'$do_suspy'(S, F, N, T, M) :-
'$system_predicate'(T,M),
'$predicate_flags'(T,M,F,F),
F /\ 0x118dd080 =\= 0,
( S = spy ->
'$do_error'(permission_error(access,private_procedure,T),spy(M:F/N))
;
'$do_error'(permission_error(access,private_procedure,T),nospy(M:F/N))
).
'$do_suspy'(S, F, N, T, M) :-
'$undefined'(T,M), !,
( S = spy ->
print_message(warning,no_match(spy(M:F/N)))
;
print_message(warning,no_match(nospy(M:F/N)))
).
'$do_suspy'(S,F,N,T,M) :-
'$suspy2'(S,F,N,T,M).
'$suspy2'(spy,F,N,T,M) :-
recorded('$spy','$spy'(T,M),_), !,
print_message(informational,breakp(bp(debugger,plain,M:T,M:F/N,N),add,already)).
'$suspy2'(spy,F,N,T,M) :- !,
recorda('$spy','$spy'(T,M),_),
'$set_spy'(T,M),
print_message(informational,breakp(bp(debugger,plain,M:T,M:F/N,N),add,ok)).
'$suspy2'(nospy,F,N,T,M) :-
recorded('$spy','$spy'(T,M),R), !,
erase(R),
'$rm_spy'(T,M),
print_message(informational,breakp(bp(debugger,plain,M:T,M:F/N,N),remove,last)).
'$suspy2'(nospy,F,N,_,M) :-
print_message(informational,breakp(no,breakpoint_for,M:F/N)).
'$pred_being_spied'(G, M) :-
recorded('$spy','$spy'(G,M),_), !.
/**
@pred spy( + _P_ ).
Sets spy-points on all the predicates represented by
_P_. _P_ can either be a single specification or a list of
specifications. Each one must be of the form _Name/Arity_
or _Name_. In the last case all predicates with the name
_Name_ will be spied. As in C-Prolog, system predicates and
predicates written in C, cannot be spied.
*/
spy Spec :-
'$init_debugger',
prolog:debug_action_hook(spy(Spec)), !.
spy L :-
'$current_module'(M),
'$suspy'(L, spy, M), fail.
spy _ :- debug.
/** @pred nospy( + _P_ )
Removes spy-points from all predicates specified by _P_.
The possible forms for _P_ are the same as in `spy P`.
*/
nospy Spec :-
'$init_debugger',
prolog:debug_action_hook(nospy(Spec)), !.
nospy L :-
'$current_module'(M),
'$suspy'(L, nospy, M), fail.
nospy _.
/** @pred nospyall
Removes all existing spy-points.
*/
nospyall :-
'$init_debugger',
prolog:debug_action_hook(nospyall), !.
nospyall :-
recorded('$spy','$spy'(T,M),_), functor(T,F,N), '$suspy'(F/N,nospy,M), fail.
nospyall.
% debug mode -> debug flag = 1
debug :-
'$init_debugger',
( '__NB_getval__'('$spy_gn',_, fail) -> true ; '__NB_setval__'('$spy_gn',1) ),
'$start_debugging'(on),
print_message(informational,debug(debug)).
'$start_debugging'(Mode) :-
(Mode == on ->
set_prolog_flag(debug, true)
;
set_prolog_flag(debug, false)
),
'__NB_setval__'('$debug_run',off),
'__NB_setval__'('$debug_jump',false).
nodebug :-
'$init_debugger',
set_prolog_flag(debug, false),
'__NB_setval__'('$trace',off),
print_message(informational,debug(off)).
%
% remove any debugging info after an abort.
%
/** @pred trace
Switches on the debugger and enters tracing mode.
*/
trace :-
'$init_debugger',
fail.
trace :-
'__NB_setval__'('$trace',on),
'$start_debugging'(on),
print_message(informational,debug(trace)),
'$creep'.
/** @pred notrace
Ends tracing and exits the debugger. This is the same as
nodebug/0.
*/
notrace :-
'$init_debugger',
nodebug.
/*-----------------------------------------------------------------------------
leash
-----------------------------------------------------------------------------*/
/** @pred leash(+ _M_)
Sets leashing mode to _M_.
The mode can be specified as:
+ `full`
prompt on Call, Exit, Redo and Fail
+ `tight`
prompt on Call, Redo and Fail
+ `half`
prompt on Call and Redo
+ `loose`
prompt on Call
+ `off`
never prompt
+ `none`
never prompt, same as `off`
The initial leashing mode is `full`.
The user may also specify directly the debugger ports
where he wants to be prompted. If the argument for leash
is a number _N_, each of lower four bits of the number is used to
control prompting at one the ports of the box model. The debugger will
prompt according to the following conditions:
+ if `N/\ 1 =\= 0` prompt on fail
+ if `N/\ 2 =\= 0` prompt on redo
+ if `N/\ 4 =\= 0` prompt on exit
+ if `N/\ 8 =\= 0` prompt on call
Therefore, `leash(15)` is equivalent to `leash(full)` and
`leash(0)` is equivalent to `leash(off)`.
Another way of using `leash` is to give it a list with the names of
the ports where the debugger should stop. For example,
`leash([call,exit,redo,fail])` is the same as `leash(full)` or
`leash(15)` and `leash([fail])` might be used instead of
`leash(1)`.
@}
*/
leash(X) :- var(X),
'$do_error'(instantiation_error,leash(X)).
leash(X) :-
'$init_debugger',
'$leashcode'(X,Code),
set_value('$leash',Code),
'$show_leash'(informational,Code), !.
leash(X) :-
'$do_error'(type_error(leash_mode,X),leash(X)).
'$show_leash'(Msg,0) :-
print_message(Msg,leash([])).
'$show_leash'(Msg,Code) :-
'$check_leash_bit'(Code,0x8,L3,call,LF),
'$check_leash_bit'(Code,0x4,L2,exit,L3),
'$check_leash_bit'(Code,0x2,L1,redo,L2),
'$check_leash_bit'(Code,0x1,[],fail,L1),
print_message(Msg,leash(LF)).
'$check_leash_bit'(Code,Bit,L0,_,L0) :- Bit /\ Code =:= 0, !.
'$check_leash_bit'(_,_,L0,Name,[Name|L0]).
'$leashcode'(full,0xf) :- !.
'$leashcode'(on,0xf) :- !.
'$leashcode'(half,0xb) :- !.
'$leashcode'(loose,0x8) :- !.
'$leashcode'(off,0x0) :- !.
'$leashcode'(none,0x0) :- !.
%'$leashcode'([L|M],Code) :- !, '$leashcode_list'([L|M],Code).
'$leashcode'([L|M],Code) :- !,
'$list2Code'([L|M],Code).
'$leashcode'(N,N) :- integer(N), N >= 0, N =< 0xf.
'$list2Code'(V,_) :- var(V), !,
'$do_error'(instantiation_error,leash(V)).
'$list2Code'([],0) :- !.
'$list2Code'([V|L],_) :- var(V), !,
'$do_error'(instantiation_error,leash([V|L])).
'$list2Code'([call|L],N) :- '$list2Code'(L,N1), N is 0x8 + N1.
'$list2Code'([exit|L],N) :- '$list2Code'(L,N1), N is 0x4 + N1.
'$list2Code'([redo|L],N) :- '$list2Code'(L,N1), N is 0x2 + N1.
'$list2Code'([fail|L],N) :- '$list2Code'(L,N1), N is 0x1 + N1.
/*-----------------------------------------------------------------------------
debugging
-----------------------------------------------------------------------------*/
debugging :-
'$init_debugger',
prolog:debug_action_hook(nospyall), !.
debugging :-
( current_prolog_flag(debug, true) ->
print_message(help,debug(debug))
;
print_message(help,debug(off))
),
findall(M:(N/A),(recorded('$spy','$spy'(T,M),_),functor(T,N,A)),L),
print_message(help,breakpoints(L)),
get_value('$leash',Leash),
'$show_leash'(help,Leash).
/*
@}
*/

View File

@@ -1,358 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: statistics.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: statistics on Prolog status *
* *
*************************************************************************/
:- system_module( '$_statistics', [key_statistics/3,
statistics/0,
statistics/2,
time/1], []).
:- use_system_module( '$_errors', ['$do_error'/2]).
%%% User interface for statistics
/** @pred statistics/0
Send to the current user error stream general information on space used and time
spent by the system.
~~~~~
?- statistics.
memory (total) 4784124 bytes
program space 3055616 bytes: 1392224 in use, 1663392 free
2228132 max
stack space 1531904 bytes: 464 in use, 1531440 free
global stack: 96 in use, 616684 max
local stack: 368 in use, 546208 max
trail stack 196604 bytes: 8 in use, 196596 free
0.010 sec. for 5 code, 2 stack, and 1 trail space overflows
0.130 sec. for 3 garbage collections which collected 421000 bytes
0.000 sec. for 0 atom garbage collections which collected 0 bytes
0.880 sec. runtime
1.020 sec. cputime
25.055 sec. elapsed time
~~~~~
The example shows how much memory the system spends. Memory is divided
into Program Space, Stack Space and Trail. In the example we have 3MB
allocated for program spaces, with less than half being actually
used. YAP also shows the maximum amount of heap space having been used
which was over 2MB.
The stack space is divided into two stacks which grow against each
other. We are in the top level so very little stack is being used. On
the other hand, the system did use a lot of global and local stack
during the previous execution (we refer the reader to a WAM tutorial in
order to understand what are the global and local stacks).
YAP also shows information on how many memory overflows and garbage
collections the system executed, and statistics on total execution
time. Cputime includes all running time, runtime excludes garbage
collection and stack overflow time.
*/
statistics :-
'$runtime'(Runtime,_),
'$cputime'(CPUtime,_),
'$systime'(SYStime,_),
'$walltime'(Walltime,_),
'$statistics_heap_info'(HpSpa, HpInUse),
'$statistics_heap_max'(HpMax),
'$statistics_trail_info'(TrlSpa, TrlInUse),
'$statistics_trail_max'(TrlMax),
'$statistics_stacks_info'(StkSpa, GlobInU, LocInU),
'$statistics_global_max'(GlobMax),
'$statistics_local_max'(LocMax),
'$inform_heap_overflows'(NOfHO,TotHOTime),
'$inform_stack_overflows'(NOfSO,TotSOTime),
'$inform_trail_overflows'(NOfTO,TotTOTime),
'$inform_gc'(NOfGC,TotGCTime,TotGCSize),
'$inform_agc'(NOfAGC,TotAGCTime,TotAGCSize),
'$statistics'(Runtime,CPUtime,SYStime,Walltime,HpSpa,HpInUse,HpMax,TrlSpa, TrlInUse,TrlMax,StkSpa, GlobInU, LocInU,GlobMax,LocMax,NOfHO,TotHOTime,NOfSO,TotSOTime,NOfTO,TotTOTime,NOfGC,TotGCTime,TotGCSize,NOfAGC,TotAGCTime,TotAGCSize).
'$statistics'(Runtime,CPUtime,SYStime,Walltime,HpSpa,HpInUse,HpMax,TrlSpa, TrlInUse,_TrlMax,StkSpa, GlobInU, LocInU,GlobMax,LocMax,NOfHO,TotHOTime,NOfSO,TotSOTime,NOfTO,TotTOTime,NOfGC,TotGCTime,TotGCSize,NOfAGC,TotAGCTime,TotAGCSize) :-
TotalMemory is HpSpa+StkSpa+TrlSpa,
format(user_error,'memory (total)~t~d bytes~35+~n', [TotalMemory]),
format(user_error,' program space~t~d bytes~35+', [HpSpa]),
format(user_error,':~t ~d in use~19+', [HpInUse]),
HpFree is HpSpa-HpInUse,
format(user_error,',~t ~d free~19+~n', [HpFree]),
format(user_error,'~t ~d max~73+~n', [HpMax]),
format(user_error,' stack space~t~d bytes~35+', [StkSpa]),
StackInUse is GlobInU+LocInU,
format(user_error,':~t ~d in use~19+', [StackInUse]),
StackFree is StkSpa-StackInUse,
format(user_error,',~t ~d free~19+~n', [StackFree]),
format(user_error,' global stack:~t~35+', []),
format(user_error,' ~t ~d in use~19+', [GlobInU]),
format(user_error,',~t ~d max~19+~n', [GlobMax]),
format(user_error,' local stack:~t~35+', []),
format(user_error,' ~t ~d in use~19+', [LocInU]),
format(user_error,',~t ~d max~19+~n', [LocMax]),
format(user_error,' trail stack~t~d bytes~35+', [TrlSpa]),
format(user_error,':~t ~d in use~19+', [TrlInUse]),
TrlFree is TrlSpa-TrlInUse,
format(user_error,',~t ~d free~19+~n', [TrlFree]),
OvfTime is (TotHOTime+TotSOTime+TotTOTime)/1000,
format(user_error,'~n~t~3f~12+ sec. for ~w code, ~w stack, and ~w trail space overflows~n',
[OvfTime,NOfHO,NOfSO,NOfTO]),
TotGCTimeF is float(TotGCTime)/1000,
format(user_error,'~t~3f~12+ sec. for ~w garbage collections which collected ~d bytes~n',
[TotGCTimeF,NOfGC,TotGCSize]),
TotAGCTimeF is float(TotAGCTime)/1000,
format(user_error,'~t~3f~12+ sec. for ~w atom garbage collections which collected ~d bytes~n',
[TotAGCTimeF,NOfAGC,TotAGCSize]),
RTime is float(Runtime)/1000,
format(user_error,'~t~3f~12+ sec. runtime~n', [RTime]),
CPUTime is float(CPUtime)/1000,
format(user_error,'~t~3f~12+ sec. cputime~n', [CPUTime]),
SYSTime is float(SYStime)/1000,
format(user_error,'~t~3f~12+ sec. systime~n', [SYSTime]),
WallTime is float(Walltime)/1000,
format(user_error,'~t~3f~12+ sec. elapsed time~n~n', [WallTime]),
fail.
'$statistics'(_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_,_).
/** @pred statistics(? _Param_,- _Info_)
Gives statistical information on the system parameter given by first
argument:
+ atoms
`[ _NumberOfAtoms_, _SpaceUsedBy Atoms_]`
This gives the total number of atoms `NumberOfAtoms` and how much
space they require in bytes, _SpaceUsedBy Atoms_.
+ cputime
`[ _Time since Boot_, _Time From Last Call to Cputime_]`
This gives the total cputime in milliseconds spent executing Prolog code,
garbage collection and stack shifts time included.
+ dynamic_code
`[ _Clause Size_, _Index Size_, _Tree Index Size_, _Choice Point Instructions Size_, _Expansion Nodes Size_, _Index Switch Size_]`
Size of static code in YAP in bytes: _Clause Size_, the number of
bytes allocated for clauses, plus
_Index Size_, the number of bytes spent in the indexing code. The
indexing code is divided into main tree, _Tree Index Size_,
tables that implement choice-point manipulation, _Choice xsPoint Instructions Size_, tables that cache clauses for future expansion of the index
tree, _Expansion Nodes Size_, and
tables such as hash tables that select according to value, _Index Switch Size_.
+ garbage_collection
`[ _Number of GCs_, _Total Global Recovered_, _Total Time Spent_]`
Number of garbage collections, amount of space recovered in kbytes, and
total time spent doing garbage collection in milliseconds. More detailed
information is available using `yap_flag(gc_trace,verbose)`.
+ global_stack
`[ _Global Stack Used_, _Execution Stack Free_]`
Space in kbytes currently used in the global stack, and space available for
expansion by the local and global stacks.
+ local_stack
`[ _Local Stack Used_, _Execution Stack Free_]`
Space in kbytes currently used in the local stack, and space available for
expansion by the local and global stacks.
+ heap
`[ _Heap Used_, _Heap Free_]`
Total space in kbytes not recoverable
in backtracking. It includes the program code, internal data base, and,
atom symbol table.
+ program
`[ _Program Space Used_, _Program Space Free_]`
Equivalent to heap.
+ runtime
`[ _Time since Boot_, _Time From Last Call to Runtime_]`
This gives the total cputime in milliseconds spent executing Prolog
code, not including garbage collections and stack shifts. Note that
until YAP4.1.2 the runtime statistics would return time spent on
garbage collection and stack shifting.
+ stack_shifts
`[ _Number of Heap Shifts_, _Number of Stack Shifts_, _Number of Trail Shifts_]`
Number of times YAP had to
expand the heap, the stacks, or the trail. More detailed information is
available using `yap_flag(gc_trace,verbose)`.
+ static_code
`[ _Clause Size_, _Index Size_, _Tree Index Size_, _Expansion Nodes Size_, _Index Switch Size_]`
Size of static code in YAP in bytes: _Clause Size_, the number of
bytes allocated for clauses, plus
_Index Size_, the number of bytes spent in the indexing code. The
indexing code is divided into a main tree, _Tree Index Size_, table that cache clauses for future expansion of the index
tree, _Expansion Nodes Size_, and and
tables such as hash tables that select according to value, _Index Switch Size_.
+ trail
`[ _Trail Used_, _Trail Free_]`
Space in kbytes currently being used and still available for the trail.
+ walltime
`[ _Time since Boot_, _Time From Last Call to Walltime_]`
This gives the clock time in milliseconds since starting Prolog.
*/
statistics(runtime,[T,L]) :-
'$runtime'(T,L).
statistics(cputime,[T,L]) :-
'$cputime'(T,L).
statistics(walltime,[T,L]) :-
'$walltime'(T,L).
statistics(threads,NT) :-
'$nof_threads'(NT).
statistics(threads_created,TC) :-
'$nof_threads_created'(TC).
statistics(thread_cputime,TR) :-
'$thread_runtime'(TR).
%statistics(core,[_]).
%statistics(memory,[_]).
statistics(heap,[Hp,HpF]) :-
'$statistics_heap_info'(HpM, Hp),
HpF is HpM-Hp.
statistics(program,Info) :-
statistics(heap,Info).
statistics(global_stack,[GlobInU,GlobFree]) :-
'$statistics_stacks_info'(StkSpa, GlobInU, LocInU),
GlobFree is StkSpa-GlobInU-LocInU.
statistics(local_stack,[LocInU,LocFree]) :-
'$statistics_stacks_info'(StkSpa, GlobInU, LocInU),
LocFree is StkSpa-GlobInU-LocInU.
statistics(trail,[TrlInUse,TrlFree]) :-
'$statistics_trail_info'(TrlSpa, TrlInUse),
TrlFree is TrlSpa-TrlInUse.
statistics(garbage_collection,[NOfGC,TotGCSize,TotGCTime]) :-
'$inform_gc'(NOfGC,TotGCTime,TotGCSize).
statistics(stack_shifts,[NOfHO,NOfSO,NOfTO]) :-
'$inform_heap_overflows'(NOfHO,_),
'$inform_stack_overflows'(NOfSO,_),
'$inform_trail_overflows'(NOfTO,_).
statistics(atoms,[NOf,SizeOf]) :-
'$statistics_atom_info'(NOf,SizeOf).
statistics(static_code,[ClauseSize, IndexSize, TreeIndexSize, ExtIndexSize, SWIndexSize]) :-
'$statistics_db_size'(ClauseSize, TreeIndexSize, ExtIndexSize, SWIndexSize),
IndexSize is TreeIndexSize+ ExtIndexSize+ SWIndexSize.
statistics(dynamic_code,[ClauseSize,IndexSize, TreeIndexSize, CPIndexSize, ExtIndexSize, SWIndexSize]) :-
'$statistics_lu_db_size'(ClauseSize, TreeIndexSize, CPIndexSize, ExtIndexSize, SWIndexSize),
IndexSize is TreeIndexSize+CPIndexSize+ ExtIndexSize+ SWIndexSize.
/** @pred key_statistics(+ _K_,- _Entries_,- _TotalSize_)
Returns several statistics for a key _K_. Currently, it says how
many entries we have for that key, _Entries_, what is the
total size spent on this key.
*/
key_statistics(Key, NOfEntries, TotalSize) :-
key_statistics(Key, NOfEntries, ClSize, IndxSize),
TotalSize is ClSize+IndxSize.
%% time(:Goal)
%
% Time the execution of Goal. Possible choice-points of Goal are removed.
% Based on the SWI-Prolog definition minus reporting the number of inferences,
% which YAP does not currently supports
/** @pred time(: _Goal_)
Prints the CPU time and the wall time for the execution of _Goal_.
Possible choice-points of _Goal_ are removed. Based on the SWI-Prolog
definition (minus reporting the number of inferences, which YAP currently
does not support).
*/
:- meta_predicate time(0).
time(Goal) :-
var(Goal),
'$do_error'(instantiation_error,time(Goal)).
time(_:Goal) :-
var(Goal),
'$do_error'(instantiation_error,time(Goal)).
time(Goal) :- \+ callable(Goal), !,
'$do_error'(type_error(callable,Goal),time(Goal)).
time(Goal) :-
statistics(walltime, _),
statistics(cputime, _),
( catch(Goal, E, true)
-> Result = yes
; Result = no
),
statistics(cputime, [_, Time]),
statistics(walltime, [_, Wall]),
( Time =:= 0
-> CPU = 'Inf'
; CPU is truncate(Time/Wall*100)
),
TimeSecs is Time/1000,
WallSecs is Wall/1000,
format(user_error,'% ~3f CPU in ~3f seconds (~|~t~w~3+% CPU)~n', [TimeSecs, WallSecs, CPU]),
( nonvar(E)
-> throw(E)
; Result == yes
).

View File

@@ -1,232 +0,0 @@
:- system_module( '$_strict_iso', [], ['$check_iso_strict_clause'/1,
'$iso_check_goal'/2]).
:- use_system_module( '$_errors', ['$do_error'/2]).
'$iso_check_goal'(V,G) :-
var(V), !,
'$do_error'(instantiation_error,call(G)).
'$iso_check_goal'(V,G) :-
number(V), !,
'$do_error'(type_error(callable,V),G).
'$iso_check_goal'(_:G,G0) :- !,
'$iso_check_goal'(G,G0).
'$iso_check_goal'((G1,G2),G0) :- !,
'$iso_check_a_goal'(G1,(G1,G2),G0),
'$iso_check_a_goal'(G2,(G1,G2),G0).
'$iso_check_goal'((G1;G2),G0) :- !,
'$iso_check_a_goal'(G1,(G1;G2),G0),
'$iso_check_a_goal'(G2,(G1;G2),G0).
'$iso_check_goal'((G1->G2),G0) :- !,
'$iso_check_a_goal'(G1,(G1->G2),G0),
'$iso_check_a_goal'(G2,(G1->G2),G0).
'$iso_check_goal'(!,_) :- !.
'$iso_check_goal'((G1|G2),G0) :-
current_prolog_flag(language, iso), !,
'$do_error'(domain_error(builtin_procedure,(G1|G2)), call(G0)).
'$iso_check_goal'((G1|G2),G0) :- !,
'$iso_check_a_goal'(G1,(G1|G2),G0),
'$iso_check_a_goal'(G2,(G1|G2),G0).
'$iso_check_goal'(G,G0) :-
current_prolog_flag(language, iso),
'$system_predicate'(G,prolog),
(
'$iso_builtin'(G)
->
true
;
'$do_error'(domain_error(builtin_procedure,G), call(G0))
).
'$iso_check_goal'(_,_).
'$iso_check_a_goal'(V,_,G) :-
var(V), !,
'$do_error'(instantiation_error,call(G)).
'$iso_check_a_goal'(V,E,G) :-
number(V), !,
'$do_error'(type_error(callable,E),call(G)).
'$iso_check_a_goal'(_:G,E,G0) :- !,
'$iso_check_a_goal'(G,E,G0).
'$iso_check_a_goal'((G1,G2),E,G0) :- !,
'$iso_check_a_goal'(G1,E,G0),
'$iso_check_a_goal'(G2,E,G0).
'$iso_check_a_goal'((G1;G2),E,G0) :- !,
'$iso_check_a_goal'(G1,E,G0),
'$iso_check_a_goal'(G2,E,G0).
'$iso_check_a_goal'((G1->G2),E,G0) :- !,
'$iso_check_a_goal'(G1,E,G0),
'$iso_check_a_goal'(G2,E,G0).
'$iso_check_a_goal'(!,_,_) :- !.
'$iso_check_a_goal'((_|_),E,G0) :-
current_prolog_flag(language, iso), !,
'$do_error'(domain_error(builtin_procedure,E), call(G0)).
'$iso_check_a_goal'((_|_),_,_) :- !.
'$iso_check_a_goal'(G,_,G0) :-
current_prolog_flag(language, iso),
'$is+system_predicate'(G,prolog),
(
'$iso_builtin'(G)
->
true
;
'$do_error'(domain_error(builtin_procedure,G), call(G0))
).
'$iso_check_a_goal'(_,_,_).
'$check_iso_strict_clause'((_:-B)) :- !,
'$check_iso_strict_body'(B).
'$check_iso_strict_clause'(_).
'$check_iso_strict_body'((B1,B2)) :- !,
'$check_iso_strict_body'(B1),
'$check_iso_strict_body'(B2).
'$check_iso_strict_body'((B1;B2)) :- !,
'$check_iso_strict_body'(B1),
'$check_iso_strict_body'(B2).
'$check_iso_strict_body'((B1->B2)) :- !,
'$check_iso_strict_body'(B1),
'$check_iso_strict_body'(B2).
'$check_iso_strict_body'(B) :-
'$check_iso_strict_goal'(B).
'$check_iso_strict_goal'(G) :-
'$is_system_predicate'(G,prolog), !,
'$check_iso_system_goal'(G).
'$check_iso_strict_goal'(_).
'$check_iso_system_goal'(G) :-
'$iso_builtin'(G), !.
'$check_iso_system_goal'(G) :-
'$do_error'(domain_error(builtin_procedure,G), G).
'$iso_builtin'(abolish(_)).
'$iso_builtin'(acylic_term(_)).
'$iso_builtin'(arg(_,_,_)).
'$iso_builtin'(_=:=_).
'$iso_builtin'(_=\=_).
'$iso_builtin'(_>_).
'$iso_builtin'(_>=_).
'$iso_builtin'(_<_).
'$iso_builtin'(_=<_).
'$iso_builtin'(asserta(_)).
'$iso_builtin'(assertz(_)).
'$iso_builtin'(at_end_of_stream).
'$iso_builtin'(at_end_of_stream(_)).
'$iso_builtin'(atom(_)).
'$iso_builtin'(atom_chars(_,_)).
'$iso_builtin'(atom_codes(_,_)).
'$iso_builtin'(atom_concat(_,_,_)).
'$iso_builtin'(atom_length(_,_)).
'$iso_builtin'(atomic(_)).
'$iso_builtin'(bagof(_,_,_)).
'$iso_builtin'(call(_)).
'$iso_builtin'(call(_,_)).
'$iso_builtin'(call(_,_,_)).
'$iso_builtin'(call(_,_,_,_)).
'$iso_builtin'(call(_,_,_,_,_)).
'$iso_builtin'(call(_,_,_,_,_,_)).
'$iso_builtin'(call(_,_,_,_,_,_,_)).
'$iso_builtin'(call(_,_,_,_,_,_,_,_)).
'$iso_builtin'(callable(_)).
'$iso_builtin'(catch(_,_,_)).
'$iso_builtin'(char_code(_,_)).
'$iso_builtin'(char_conversion(_,_)).
'$iso_builtin'(clause(_,_)).
'$iso_builtin'(close(_)).
'$iso_builtin'(close(_,_)).
'$iso_builtin'(compare(_,_,_)).
'$iso_builtin'(compound(_)).
'$iso_builtin'((_,_)).
'$iso_builtin'(copy_term(_,_)).
'$iso_builtin'(current_char_conversion(_,_)).
'$iso_builtin'(current_input(_)).
'$iso_builtin'(current_op(_,_,_)).
'$iso_builtin'(current_output(_)).
'$iso_builtin'(current_predicate(_)).
'$iso_builtin'(current_prolog_flag(_,_)).
'$iso_builtin'(!).
'$iso_builtin'((_;_)).
'$iso_builtin'(fail).
'$iso_builtin'(false).
'$iso_builtin'(findall(_,_,_)).
'$iso_builtin'(float(_)).
'$iso_builtin'(abort).
'$iso_builtin'(flush_output).
'$iso_builtin'(flush_output(_)).
'$iso_builtin'(functor(_,_,_)).
'$iso_builtin'(get_byte(_)).
'$iso_builtin'(get_byte(_,_)).
'$iso_builtin'(get_char(_)).
'$iso_builtin'(get_char(_,_)).
'$iso_builtin'(get_code(_)).
'$iso_builtin'(get_code(_,_)).
'$iso_builtin'(ground(_)).
'$iso_builtin'(halt).
'$iso_builtin'(halt(_)).
'$iso_builtin'((_->_)).
'$iso_builtin'(integer(_)).
'$iso_builtin'(_ is _).
'$iso_builtin'(keysort(_,_)).
'$iso_builtin'(nl).
'$iso_builtin'(nl(_)).
'$iso_builtin'(nonvar(_)).
'$iso_builtin'(\+(_)).
'$iso_builtin'(number(_)).
'$iso_builtin'(number_chars(_,_)).
'$iso_builtin'(number_codes(_,_)).
'$iso_builtin'(once(_)).
'$iso_builtin'(op(_,_,_)).
'$iso_builtin'(open(_,_,_)).
'$iso_builtin'(open(_,_,_,_)).
'$iso_builtin'(peek_byte(_)).
'$iso_builtin'(peek_byte(_,_)).
'$iso_builtin'(peek_char(_)).
'$iso_builtin'(peek_char(_,_)).
'$iso_builtin'(peek_code(_)).
'$iso_builtin'(peek_code(_,_)).
'$iso_builtin'(put_byte(_)).
'$iso_builtin'(put_byte(_,_)).
'$iso_builtin'(put_char(_)).
'$iso_builtin'(put_char(_,_)).
'$iso_builtin'(put_code(_)).
'$iso_builtin'(put_code(_,_)).
'$iso_builtin'(read(_)).
'$iso_builtin'(read(_,_)).
'$iso_builtin'(read_term(_,_)).
'$iso_builtin'(read_term(_,_,_)).
'$iso_builtin'(repeat).
'$iso_builtin'(retract(_)).
'$iso_builtin'(retractall(_)).
'$iso_builtin'(set_input(_)).
'$iso_builtin'(set_output(_)).
'$iso_builtin'(set_prolog_flag(_,_)).
'$iso_builtin'(set_stream_position(_,_)).
'$iso_builtin'(setof(_,_,_)).
'$iso_builtin'(sort(_,_)).
'$iso_builtin'(stream_property(_,_)).
'$iso_builtin'(sub_atom(_,_,_,_,_)).
'$iso_builtin'(subsumes_term(_,_)).
'$iso_builtin'(_@>_).
'$iso_builtin'(_@>=_).
'$iso_builtin'(_==_).
'$iso_builtin'(_@<_).
'$iso_builtin'(_@=<_).
'$iso_builtin'(_\==_).
'$iso_builtin'(term_variables(_,_)).
'$iso_builtin'(throw(_)).
'$iso_builtin'(true).
'$iso_builtin'(_\=_).
'$iso_builtin'(_=_).
'$iso_builtin'(unify_with_occurs_check(_,_)).
'$iso_builtin'(_384=.._385).
'$iso_builtin'(var(_)).
'$iso_builtin'(write(_)).
'$iso_builtin'(write(_,_)).
'$iso_builtin'(write_canonical(_)).
'$iso_builtin'(write_canonical(_,_)).
'$iso_builtin'(write_term(_,_)).
'$iso_builtin'(write_term(_,_,_)).
'$iso_builtin'(writeq(_)).
'$iso_builtin'(writeq(_,_)).

View File

@@ -1,103 +0,0 @@
:- module('$swi',
[]).
%% file_alias_path(-Alias, ?Dir) is nondet.
%
% True if file Alias points to Dir. Multiple solutions are
% generated with the longest directory first.
%% file_name_on_path(+File:atom, -OnPath) is det.
%
% True if OnPath a description of File based on the file search
% path. This performs the inverse of absolute_file_name/3.
prolog:file_name_on_path(Path, ShortId) :-
( prolog:file_alias_path(Alias, Dir),
atom_concat(Dir, Local, Path)
-> ( Alias == '.'
-> ShortId = Local
; file_name_extension(Base, pl, Local)
-> ShortId =.. [Alias, Base]
; ShortId =.. [Alias, Local]
)
; ShortId = Path
).
:- dynamic
alias_cache/2.
prolog:file_alias_path(Alias, Dir) :-
( alias_cache(_, _)
-> true
; build_alias_cache
),
( nonvar(Dir)
-> ensure_slash(Dir, DirSlash),
alias_cache(Alias, DirSlash)
; alias_cache(Alias, Dir)
).
build_alias_cache :-
findall(t(DirLen, AliasLen, Alias, Dir),
search_path(Alias, Dir, AliasLen, DirLen), Ts),
sort(Ts, List0),
reverse(List0, List),
forall(lists:member(t(_, _, Alias, Dir), List),
assert(alias_cache(Alias, Dir))).
search_path('.', Here, 999, DirLen) :-
working_directory(Here0, Here0),
ensure_slash(Here0, Here),
atom_length(Here, DirLen).
search_path(Alias, Dir, AliasLen, DirLen) :-
user:file_search_path(Alias, _),
Alias \== autoload,
Spec =.. [Alias,'.'],
atom_length(Alias, AliasLen0),
AliasLen is 1000 - AliasLen0, % must do reverse sort
absolute_file_name(Spec, Dir0,
[ file_type(directory),
access(read),
solutions(all),
file_errors(fail)
]),
ensure_slash(Dir0, Dir),
atom_length(Dir, DirLen).
ensure_slash(Dir, Dir) :-
sub_atom(Dir, _, _, 0, /), !.
ensure_slash(Dir0, Dir) :-
atom_concat(Dir0, /, Dir).
/** @pred reverse(+ _List_, ? _Reversed_)
True when _List_ and _Reversed_ are lists with the same elements
but in opposite orders.
*/
reverse(List, Reversed) :-
reverse(List, [], Reversed).
reverse([], Reversed, Reversed).
reverse([Head|Tail], Sofar, Reversed) :-
reverse(Tail, [Head|Sofar], Reversed).
%% win_add_dll_directory(+AbsDir) is det.
%
% Add AbsDir to the directories where dependent DLLs are searched
% on Windows systems.
:- if(current_prolog_flag(windows, true)).
prolog:win_add_dll_directory(Dir) :-
win_add_dll_directory(Dir, _), !.
prolog:win_add_dll_directory(Dir) :-
prolog_to_os_filename(Dir, OSDir),
getenv('PATH', Path0),
atomic_list_concat([Path0, OSDir], ';', Path),
setenv('PATH', Path).
:- endif.

View File

@@ -1,534 +0,0 @@
:- system_module( '$_tabling', [abolish_table/1,
global_trie_statistics/0,
is_tabled/1,
show_all_local_tables/0,
show_all_tables/0,
show_global_trie/0,
show_table/1,
show_table/2,
show_tabled_predicates/0,
(table)/1,
table_statistics/1,
table_statistics/2,
tabling_mode/2,
tabling_statistics/0,
tabling_statistics/2], []).
:- use_system_module( '$_errors', ['$do_error'/2]).
/** @defgroup Tabling Tabling
@ingroup extensions
@{
*YAPTab* is the tabling engine that extends YAP's execution
model to support tabled evaluation for definite programs. YAPTab was
implemented by Ricardo Rocha and its implementation is largely based
on the ground-breaking design of the XSB Prolog system, which
implements the SLG-WAM. Tables are implemented using tries and YAPTab
supports the dynamic intermixing of batched scheduling and local
scheduling at the subgoal level. Currently, the following restrictions
are of note:
+ YAPTab does not handle tabled predicates with loops through negation (undefined behaviour).
+ YAPTab does not handle tabled predicates with cuts (undefined behaviour).
+ YAPTab does not support coroutining (configure error).
+ YAPTab does not support tabling dynamic predicates (permission error).
To experiment with YAPTab use `--enable-tabling` in the configure
script or add `-DTABLING` to `YAP_EXTRAS` in the system's
`Makefile`. We next describe the set of built-ins predicates
designed to interact with YAPTab and control tabled execution:
*/
/*
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% %%
%% The YapTab/YapOr/OPTYap systems %%
%% %%
%% YapTab extends the Yap Prolog engine to support sequential tabling %%
%% YapOr extends the Yap Prolog engine to support or-parallelism %%
%% OPTYap extends the Yap Prolog engine to support or-parallel tabling %%
%% %%
%% %%
%% Yap Prolog was developed at University of Porto, Portugal %%
%% %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
*/
/**
YapTab extends the Yap Prolog engine to support sequential tabling. YapOr extends the Yap Prolog engine to support or-parallelism. YapOr extends the Yap Prolog engine to support or-parallelism.
*/
/** @pred abolish_table(+ _P_)
Removes all the entries from the table space for predicate _P_ (or
a list of predicates _P1_,..., _Pn_ or
[ _P1_,..., _Pn_]). The predicate remains as a tabled predicate.
*/
/** @pred is_tabled(+ _P_)
Succeeds if the predicate _P_ (or a list of predicates
_P1_,..., _Pn_ or [ _P1_,..., _Pn_]), of the form
_name/arity_, is a tabled predicate.
*/
/** @pred show_table(+ _P_)
Prints table contents (subgoals and answers) for predicate _P_
(or a list of predicates _P1_,..., _Pn_ or
[ _P1_,..., _Pn_]).
*/
/** @pred table( + _P_ )
Declares predicate _P_ (or a list of predicates
_P1_,..., _Pn_ or [ _P1_,..., _Pn_]) as a tabled
predicate. _P_ must be written in the form
_name/arity_. Examples:
~~~~~
:- table son/3.
:- table father/2.
:- table mother/2.
~~~~~
or
~~~~~
:- table son/3, father/2, mother/2.
~~~~~
or
~~~~~
:- table [son/3, father/2, mother/2].
~~~~~
*/
/** @pred table_statistics(+ _P_)
Prints table statistics (subgoals and answers) for predicate _P_
(or a list of predicates _P1_,..., _Pn_ or
[ _P1_,..., _Pn_]).
*/
/** @pred tabling_mode(+ _P_,? _Mode_)
Sets or reads the default tabling mode for a tabled predicate _P_
(or a list of predicates _P1_,..., _Pn_ or
[ _P1_,..., _Pn_]). The list of _Mode_ options includes:
+ `batched`
Defines that, by default, batched scheduling is the scheduling
strategy to be used to evaluated calls to predicate _P_.
+ `local`
Defines that, by default, local scheduling is the scheduling
strategy to be used to evaluated calls to predicate _P_.
+ `exec_answers`
Defines that, by default, when a call to predicate _P_ is
already evaluated (completed), answers are obtained by executing
compiled WAM-like code directly from the trie data
structure. This reduces the loading time when backtracking, but
the order in which answers are obtained is undefined.
+ `load_answers`
Defines that, by default, when a call to predicate _P_ is
already evaluated (completed), answers are obtained (as a
consumer) by loading them from the trie data structure. This
guarantees that answers are obtained in the same order as they
were found. Somewhat less efficient but creates less choice-points.
The default tabling mode for a new tabled predicate is `batched`
and `exec_answers`. To set the tabling mode for all predicates at
once you can use the yap_flag/2 predicate as described next.
*/
:- meta_predicate
table(:),
is_tabled(:),
tabling_mode(:,?),
abolish_table(:),
show_table(:),
show_table(?,:),
table_statistics(:),
table_statistics(?,:).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% show_tabled_predicates/0 %%
%% show_global_trie/0 %%
%% show_all_tables/0 %%
%% show_all_local_tables/0 %%
%% global_trie_statistics/0 %%
%% tabling_statistics/0 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
show_tabled_predicates :-
current_output(Stream),
show_tabled_predicates(Stream).
show_global_trie :-
current_output(Stream),
show_global_trie(Stream).
show_all_tables :-
current_output(Stream),
show_all_tables(Stream).
show_all_local_tables :-
current_output(Stream),
show_all_local_tables(Stream).
global_trie_statistics :-
current_output(Stream),
global_trie_statistics(Stream).
/** @pred tabling_statistics/0
Prints statistics on space used by all tables.
*/
tabling_statistics :-
current_output(Stream),
tabling_statistics(Stream).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% tabling_statistics/2 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% should match with code in OPTYap/opt.preds.c
tabling_statistics(total_memory,[BytesInUse,BytesAllocated]) :-
'$c_get_optyap_statistics'(0,BytesInUse,BytesAllocated).
tabling_statistics(table_entries,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(1,BytesInUse,StructsInUse).
tabling_statistics(subgoal_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(2,BytesInUse,StructsInUse).
tabling_statistics(dependency_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(3,BytesInUse,StructsInUse).
tabling_statistics(subgoal_trie_nodes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(6,BytesInUse,StructsInUse).
tabling_statistics(answer_trie_nodes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(7,BytesInUse,StructsInUse).
tabling_statistics(subgoal_trie_hashes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(8,BytesInUse,StructsInUse).
tabling_statistics(answer_trie_hashes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(9,BytesInUse,StructsInUse).
tabling_statistics(global_trie_nodes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(10,BytesInUse,StructsInUse).
tabling_statistics(global_trie_hashes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(11,BytesInUse,StructsInUse).
tabling_statistics(subgoal_entries,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(16,BytesInUse,StructsInUse).
tabling_statistics(answer_ref_nodes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(17,BytesInUse,StructsInUse).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% table/1 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
table(Pred) :-
'$current_module'(Mod),
'$do_table'(Mod,Pred).
'$do_table'(Mod,Pred) :-
var(Pred), !,
'$do_error'(instantiation_error,table(Mod:Pred)).
'$do_table'(_,Mod:Pred) :- !,
'$do_table'(Mod,Pred).
'$do_table'(_,[]) :- !.
'$do_table'(Mod,[HPred|TPred]) :- !,
'$do_table'(Mod,HPred),
'$do_table'(Mod,TPred).
'$do_table'(Mod,(Pred1,Pred2)) :- !,
'$do_table'(Mod,Pred1),
'$do_table'(Mod,Pred2).
'$do_table'(Mod,PredName/PredArity) :-
atom(PredName),
integer(PredArity),
functor(PredFunctor,PredName,PredArity), !,
'$set_table'(Mod,PredFunctor,[]).
'$do_table'(Mod,PredDeclaration) :-
PredDeclaration=..[PredName|PredList],
'$transl_to_mode_list'(PredList,PredModeList,PredArity),
functor(PredFunctor,PredName,PredArity), !,
'$set_table'(Mod,PredFunctor,PredModeList).
'$do_table'(Mod,Pred) :-
'$do_pi_error'(type_error(callable,Pred),table(Mod:Pred)).
'$set_table'(Mod,PredFunctor,_PredModeList) :-
'$undefined'('$c_table'(_,_,_),prolog), !,
functor(PredFunctor, PredName, PredArity),
'$do_error'(resource_error(tabling,Mod:PredName/PredArity),table(Mod:PredName/PredArity)).
'$set_table'(Mod,PredFunctor,PredModeList) :-
'$undefined'(PredFunctor,Mod), !,
'$c_table'(Mod,PredFunctor,PredModeList).
'$set_table'(Mod,PredFunctor,_PredModeList) :-
'$predicate_flags'(PredFunctor,Mod,Flags,Flags),
Flags /\ 0x00000040 =:= 0x00000040, !.
'$set_table'(Mod,PredFunctor,PredModeList) :-
'$predicate_flags'(PredFunctor,Mod,Flags,Flags),
Flags /\ 0x1991F8C0 =:= 0,
'$c_table'(Mod,PredFunctor,PredModeList), !.
'$set_table'(Mod,PredFunctor,_PredModeList) :-
functor(PredFunctor,PredName,PredArity),
'$do_error'(permission_error(modify,table,Mod:PredName/PredArity),table(Mod:PredName/PredArity)).
'$transl_to_mode_list'([],[],0) :- !.
'$transl_to_mode_list'([TextualMode|L],[Mode|ModeList],Arity) :-
'$transl_to_mode_directed_tabling'(TextualMode,Mode),
'$transl_to_mode_list'(L,ModeList,ListArity),
Arity is ListArity + 1.
%% should match with code in OPTYap/tab.macros.h
'$transl_to_mode_directed_tabling'(index,1).
'$transl_to_mode_directed_tabling'(min,2).
'$transl_to_mode_directed_tabling'(max,3).
'$transl_to_mode_directed_tabling'(all,4).
'$transl_to_mode_directed_tabling'(sum,5).
'$transl_to_mode_directed_tabling'(last,6).
'$transl_to_mode_directed_tabling'(first,7).
%% B-Prolog compatibility
'$transl_to_mode_directed_tabling'(+,1).
'$transl_to_mode_directed_tabling'(@,4).
'$transl_to_mode_directed_tabling'(-,7).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% is_tabled/1 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
is_tabled(Pred) :-
'$current_module'(Mod),
'$do_is_tabled'(Mod,Pred).
'$do_is_tabled'(Mod,Pred) :-
var(Pred), !,
'$do_error'(instantiation_error,is_tabled(Mod:Pred)).
'$do_is_tabled'(_,Mod:Pred) :- !,
'$do_is_tabled'(Mod,Pred).
'$do_is_tabled'(_,[]) :- !.
'$do_is_tabled'(Mod,[HPred|TPred]) :- !,
'$do_is_tabled'(Mod,HPred),
'$do_is_tabled'(Mod,TPred).
'$do_is_tabled'(Mod,(Pred1,Pred2)) :- !,
'$do_is_tabled'(Mod,Pred1),
'$do_is_tabled'(Mod,Pred2).
'$do_is_tabled'(Mod,PredName/PredArity) :-
atom(PredName),
integer(PredArity),
functor(PredFunctor,PredName,PredArity),
'$predicate_flags'(PredFunctor,Mod,Flags,Flags), !,
Flags /\ 0x000040 =\= 0.
'$do_is_tabled'(Mod,Pred) :-
'$do_pi_error'(type_error(callable,Pred),is_tabled(Mod:Pred)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% tabling_mode/2 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
tabling_mode(Pred,Options) :-
'$current_module'(Mod),
'$do_tabling_mode'(Mod,Pred,Options).
'$do_tabling_mode'(Mod,Pred,Options) :-
var(Pred), !,
'$do_error'(instantiation_error,tabling_mode(Mod:Pred,Options)).
'$do_tabling_mode'(_,Mod:Pred,Options) :- !,
'$do_tabling_mode'(Mod,Pred,Options).
'$do_tabling_mode'(_,[],_) :- !.
'$do_tabling_mode'(Mod,[HPred|TPred],Options) :- !,
'$do_tabling_mode'(Mod,HPred,Options),
'$do_tabling_mode'(Mod,TPred,Options).
'$do_tabling_mode'(Mod,(Pred1,Pred2),Options) :- !,
'$do_tabling_mode'(Mod,Pred1,Options),
'$do_tabling_mode'(Mod,Pred2,Options).
'$do_tabling_mode'(Mod,PredName/PredArity,Options) :-
atom(PredName),
integer(PredArity),
functor(PredFunctor,PredName,PredArity),
'$predicate_flags'(PredFunctor,Mod,Flags,Flags), !,
(
Flags /\ 0x000040 =\= 0, !, '$set_tabling_mode'(Mod,PredFunctor,Options)
;
'$do_error'(domain_error(table,Mod:PredName/PredArity),tabling_mode(Mod:PredName/PredArity,Options))
).
'$do_tabling_mode'(Mod,Pred,Options) :-
'$do_pi_error'(type_error(callable,Pred),tabling_mode(Mod:Pred,Options)).
'$set_tabling_mode'(Mod,PredFunctor,Options) :-
var(Options), !,
'$c_tabling_mode'(Mod,PredFunctor,Options).
'$set_tabling_mode'(_,_,[]) :- !.
'$set_tabling_mode'(Mod,PredFunctor,[HOption|TOption]) :- !,
'$set_tabling_mode'(Mod,PredFunctor,HOption),
'$set_tabling_mode'(Mod,PredFunctor,TOption).
'$set_tabling_mode'(Mod,PredFunctor,(Option1,Option2)) :- !,
'$set_tabling_mode'(Mod,PredFunctor,Option1),
'$set_tabling_mode'(Mod,PredFunctor,Option2).
'$set_tabling_mode'(Mod,PredFunctor,Option) :-
'$transl_to_pred_flag_tabling_mode'(Flag,Option), !,
'$c_tabling_mode'(Mod,PredFunctor,Flag).
'$set_tabling_mode'(Mod,PredFunctor,Options) :-
functor(PredFunctor,PredName,PredArity),
'$do_error'(domain_error(flag_value,tabling_mode+Options),tabling_mode(Mod:PredName/PredArity,Options)).
%% should match with code in OPTYap/opt.preds.c
'$transl_to_pred_flag_tabling_mode'(1,batched).
'$transl_to_pred_flag_tabling_mode'(2,local).
'$transl_to_pred_flag_tabling_mode'(3,exec_answers).
'$transl_to_pred_flag_tabling_mode'(4,load_answers).
'$transl_to_pred_flag_tabling_mode'(5,local_trie).
'$transl_to_pred_flag_tabling_mode'(6,global_trie).
'$transl_to_pred_flag_tabling_mode'(7,coinductive).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% abolish_table/1 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
abolish_table(Pred) :-
'$current_module'(Mod),
'$do_abolish_table'(Mod,Pred).
'$do_abolish_table'(Mod,Pred) :-
var(Pred), !,
'$do_error'(instantiation_error,abolish_table(Mod:Pred)).
'$do_abolish_table'(_,Mod:Pred) :- !,
'$do_abolish_table'(Mod,Pred).
'$do_abolish_table'(_,[]) :- !.
'$do_abolish_table'(Mod,[HPred|TPred]) :- !,
'$do_abolish_table'(Mod,HPred),
'$do_abolish_table'(Mod,TPred).
'$do_abolish_table'(Mod,(Pred1,Pred2)) :- !,
'$do_abolish_table'(Mod,Pred1),
'$do_abolish_table'(Mod,Pred2).
'$do_abolish_table'(Mod,PredName/PredArity) :-
atom(PredName),
integer(PredArity),
functor(PredFunctor,PredName,PredArity),
'$predicate_flags'(PredFunctor,Mod,Flags,Flags), !,
(
Flags /\ 0x000040 =\= 0, !, '$c_abolish_table'(Mod,PredFunctor)
;
'$do_error'(domain_error(table,Mod:PredName/PredArity),abolish_table(Mod:PredName/PredArity))
).
'$do_abolish_table'(Mod,Pred) :-
'$do_pi_error'(type_error(callable,Pred),abolish_table(Mod:Pred)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% show_table/1 %%
%% show_table/2 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
show_table(Pred) :-
current_output(Stream),
show_table(Stream,Pred).
show_table(Stream,Pred) :-
'$current_module'(Mod),
'$do_show_table'(Stream,Mod,Pred).
'$do_show_table'(_,Mod,Pred) :-
var(Pred), !,
'$do_error'(instantiation_error,show_table(Mod:Pred)).
'$do_show_table'(Stream,_,Mod:Pred) :- !,
'$do_show_table'(Stream,Mod,Pred).
'$do_show_table'(_,_,[]) :- !.
'$do_show_table'(Stream,Mod,[HPred|TPred]) :- !,
'$do_show_table'(Stream,Mod,HPred),
'$do_show_table'(Stream,Mod,TPred).
'$do_show_table'(Stream,Mod,(Pred1,Pred2)) :- !,
'$do_show_table'(Stream,Mod,Pred1),
'$do_show_table'(Stream,Mod,Pred2).
'$do_show_table'(Stream,Mod,PredName/PredArity) :-
atom(PredName),
integer(PredArity),
functor(PredFunctor,PredName,PredArity),
'$predicate_flags'(PredFunctor,Mod,Flags,Flags), !,
(
Flags /\ 0x000040 =\= 0, !, '$c_show_table'(Stream,Mod,PredFunctor)
;
'$do_error'(domain_error(table,Mod:PredName/PredArity),show_table(Mod:PredName/PredArity))
).
'$do_show_table'(_,Mod,Pred) :-
'$do_pi_error'(type_error(callable,Pred),show_table(Mod:Pred)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% table_statistics/1 %%
%% table_statistics/2 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
table_statistics(Pred) :-
current_output(Stream),
table_statistics(Stream,Pred).
table_statistics(Stream,Pred) :-
'$current_module'(Mod),
'$do_table_statistics'(Stream,Mod,Pred).
'$do_table_statistics'(_,Mod,Pred) :-
var(Pred), !,
'$do_error'(instantiation_error,table_statistics(Mod:Pred)).
'$do_table_statistics'(Stream,_,Mod:Pred) :- !,
'$do_table_statistics'(Stream,Mod,Pred).
'$do_table_statistics'(_,_,[]) :- !.
'$do_table_statistics'(Stream,Mod,[HPred|TPred]) :- !,
'$do_table_statistics'(Stream,Mod,HPred),
'$do_table_statistics'(Stream,Mod,TPred).
'$do_table_statistics'(Stream,Mod,(Pred1,Pred2)) :- !,
'$do_table_statistics'(Stream,Mod,Pred1),
'$do_table_statistics'(Stream,Mod,Pred2).
'$do_table_statistics'(Stream,Mod,PredName/PredArity) :-
atom(PredName),
integer(PredArity),
functor(PredFunctor,PredName,PredArity),
'$predicate_flags'(PredFunctor,Mod,Flags,Flags), !,
(
Flags /\ 0x000040 =\= 0, !, '$c_table_statistics'(Stream,Mod,PredFunctor)
;
'$do_error'(domain_error(table,Mod:PredName/PredArity),table_statistics(Mod:PredName/PredArity))
).
'$do_table_statistics'(_,Mod,Pred) :-
'$do_pi_error'(type_error(callable,Pred),table_statistics(Mod:Pred)).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
/**
@}
*/

File diff suppressed because it is too large Load Diff

View File

@@ -1,27 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-2010 *
* *
**************************************************************************
* *
* File: udi.yap *
* Last rev: 17/12/2012 *
* mods: *
* comments: support user defined indexing *
* *
*************************************************************************/
:- system_module( '$_udi', [udi/1], []).
:- meta_predicate udi(:).
/******************
* udi/1 *
******************/
udi(Pred) :-
'$udi_init'(Pred).

View File

@@ -1,152 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: undefined.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: Predicate Undefined for YAP *
* *
*************************************************************************/
/** @defgroup Undefined_Procedures Handling Undefined Procedures
@ingroup YAPControl
@{
A predicate in a module is said to be undefined if there are no clauses
defining the predicate, and if the predicate has not been declared to be
dynamic. What YAP does when trying to execute undefined predicates can
be specified in three different ways:
+ By setting an YAP flag, through the yap_flag/2 or
set_prolog_flag/2 built-ins. This solution generalizes the
ISO standard by allowing module-specific behavior.
+ By using the unknown/2 built-in (this deprecated solution is
compatible with previous releases of YAP).
+ By defining clauses for the hook predicate
`user:unknown_predicate_handler/3`. This solution is compatible
with SICStus Prolog.
*/
/** @pred user:unknown_predicate_handler(+ _Call_, + _M_, - _N_)
In YAP, the default action on undefined predicates is to output an
`error` message. Alternatives are to silently `fail`, or to print a
`warning` message and then fail. This follows the ISO Prolog standard
where the default action is `error`.
The user:unknown_predicate_handler/3 hook was originally include in
SICStus Prolog. It allows redefining the answer for specifici
calls. As an example. after defining `undefined/1` by:
~~~~~{.prolog}
undefined(A) :- format('Undefined predicate: ~w~n',[A]), fail.
~~~~~
and executing the goal:
~~~~~{.prolog}
:- assert(user:unknown_predicate_handler(U,M,undefined(M:U)) )
~~~~~
a call to a predicate for which no clauses were defined will result in
the output of a message of the form:
~~~~~{.prolog}
Undefined predicate: user:xyz(A1,A2)
~~~~~
followed by the failure of that call.
*/
:- multifile user:unknown_predicate_handler/3.
'$handle_error'(error,Goal,Mod) :-
functor(Goal,Name,Arity),
'program_continuation'(PMod,PName,PAr),
'$do_error'(existence_error(procedure,Name/Arity),
context(Mod:Goal,PMod:PName/PAr)).
'$handle_error'(warning,Goal,Mod) :-
functor(Goal,Name,Arity),
'program_continuation'(PMod,PName,PAr),
print_message(warning,error(existence_error(procedure,Name/Arity), context(Mod:Goal,PMod:PName/PAr))),
fail.
'$handle_error'(fail,_Goal,_Mod) :-
fail.
:- '$set_no_trace'('$handle_error'(_,_,_), prolog).
/**
* @pred '$undefp_expand'(+ M0:G0, -MG)
*
* @param G0 input goal
* @param M0 current module
* @param G1 new goal
*
* @return succeeds on finding G1, otherwise fails.
*
* Tries:
* 1 - `user:unknown_predicate_handler`
* 2 - `goal_expansion`
* 1 - `import` mechanism`
*/
'$undefp_search'(M0:G0, MG) :-
'$pred_exists'(unknown_predicate_handler(_,_,_,_), user),
'$yap_strip_module'(M0:G0, EM0, GM0),
user:unknown_predicate_handler(GM0,EM0,M1:G1),
!,
expand_goal(M1:G1, MG).
'$undefp_search'(MG, FMG) :-
expand_goal(MG, FMG).
% undef handler
'$undefp'([M0|G0], Action) :-
% make sure we do not loop on undefined predicates
yap_flag( unknown, Action, fail),
'$stop_creeping'(Current),
% yap_flag( debug, Debug, false),
(
'$undefp_search'(M0:G0, NM:NG),
( M0 \== NM -> true ; G0 \== NG ),
NG \= fail
->
yap_flag( unknown, _, Action),
% yap_flag( debug, _, Debug),
(
Current == true
->
% carry on signal processing
'$start_creep'([NM|NG], creep)
;
'$execute0'(NG, NM)
)
;
yap_flag( unknown, _, Action),
'$handle_error'(Action,G0,M0)
).
:- '$undefp_handler'('$undefp'(_,_), prolog).
/** @pred unknown(- _O_,+ _N_)
The unknown predicate, informs about what the user wants to be done
when there are no clauses for a predicate. Using unknown/3 is
strongly deprecated. We recommend setting the `unknown` prolog
flag for generic behaviour, and calling the hook
user:unknown_predicate_handler/3 to fine-tune specific cases
undefined goals.
*/
unknown(P, NP) :-
prolog_flag( unknown, P, NP ).
/**
@}
*/

View File

@@ -1,377 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: utils.yap *
* Last rev: 8/2/88 *
* mods: *
* comments: Some utility predicates available in yap *
* *
*************************************************************************/
:- system_module( '$_utils', [callable/1,
current_op/3,
nb_current/2,
nth_instance/3,
nth_instance/4,
op/3,
prolog/0,
recordaifnot/3,
recordzifnot/3,
simple/1,
subsumes_term/2], ['$getval_exception'/3]).
:- use_system_module( '$_boot', ['$live'/0]).
:- use_system_module( '$_errors', ['$do_error'/2]).
/** @pred op(+ _P_,+ _T_,+ _A_) is iso
Defines the operator _A_ or the list of operators _A_ with type
_T_ (which must be one of `xfx`, `xfy`,`yfx`,
`xf`, `yf`, `fx` or `fy`) and precedence _P_
(see appendix iv for a list of predefined operators).
Note that if there is a preexisting operator with the same name and
type, this operator will be discarded. Also, `,` may not be defined
as an operator, and it is not allowed to have the same for an infix and
a postfix operator.
*/
op(P,T,V) :-
'$check_op'(P,T,V,op(P,T,V)),
'$op'(P, T, V).
% just check the operator declarations for correctness.
'$check_op'(P,T,Op,G) :-
( var(P) ; var(T); var(Op)), !,
'$do_error'(instantiation_error,G).
'$check_op'(P,_,_,G) :-
\+ integer(P), !,
'$do_error'(type_error(integer,P),G).
'$check_op'(P,_,_,G) :-
P < 0, !,
'$do_error'(domain_error(operator_priority,P),G).
'$check_op'(_,T,_,G) :-
\+ atom(T), !,
'$do_error'(type_error(atom,T),G).
'$check_op'(_,T,_,G) :-
\+ '$associativity'(T), !,
'$do_error'(domain_error(operator_specifier,T),G).
'$check_op'(P,T,V,G) :-
'$check_module_for_op'(V, G, NV),
'$check_top_op'(P, T, NV, G).
'$check_top_op'(_, _, [], _) :- !.
'$check_top_op'(P, T, [Op|NV], G) :- !,
'$check_ops'(P, T, [Op|NV], G).
'$check_top_op'(P, T, V, G) :-
atom(V), !,
'$check_op_name'(P, T, V, G).
'$check_top_op'(_P, _T, V, G) :-
'$do_error'(type_error(atom,V),G).
'$associativity'(xfx).
'$associativity'(xfy).
'$associativity'(yfx).
'$associativity'(yfy).
'$associativity'(xf).
'$associativity'(yf).
'$associativity'(fx).
'$associativity'(fy).
'$check_module_for_op'(MOp, G, _) :-
var(MOp), !,
'$do_error'(instantiation_error,G).
'$check_module_for_op'(M:_V, G, _) :-
var(M), !,
'$do_error'(instantiation_error,G).
'$check_module_for_op'(M:V, G, NV) :-
atom(M), !,
'$check_module_for_op'(V, G, NV).
'$check_module_for_op'(M:_V, G, _) :- !,
'$do_error'(type_error(atom,M),G).
'$check_module_for_op'(V, _G, V).
'$check_ops'(_P, _T, [], _G) :- !.
'$check_ops'(P, T, [Op|NV], G) :- !,
(
var(NV)
->
'$do_error'(instantiation_error,G)
;
'$check_module_for_op'(Op, G, NOp),
'$check_op_name'(P, T, NOp, G),
'$check_ops'(P, T, NV, G)
).
'$check_ops'(_P, _T, Ops, G) :-
'$do_error'(type_error(list,Ops),G).
'$check_op_name'(_,_,V,G) :-
var(V), !,
'$do_error'(instantiation_error,G).
'$check_op_name'(_,_,',',G) :- !,
'$do_error'(permission_error(modify,operator,','),G).
'$check_op_name'(_,_,'[]',G) :- T \= yf, T\= xf, !,
'$do_error'(permission_error(create,operator,'[]'),G).
'$check_op_name'(_,_,'{}',G) :- T \= yf, T\= xf, !,
'$do_error'(permission_error(create,operator,'{}'),G).
'$check_op_name'(P,T,'|',G) :-
(
integer(P),
P < 1001, P > 0
;
atom_codes(T,[_,_])
), !,
'$do_error'(permission_error(create,operator,'|'),G).
'$check_op_name'(_,_,V,_) :-
atom(V), !.
'$check_op_name'(_,_,A,G) :-
'$do_error'(type_error(atom,A),G).
'$op'(P, T, ML) :-
strip_module(ML, M, [A|As]), !,
'$opl'(P, T, M, [A|As]).
'$op'(P, T, A) :-
'$op2'(P,T,A).
'$opl'(_P, _T, _, []).
'$opl'(P, T, M, [A|As]) :-
'$op2'(P, T, M:A),
'$opl'(P, T, M, As).
'$op2'(P,T,A) :-
atom(A), !,
'$opdec'(P,T,A,prolog).
'$op2'(P,T,A) :-
strip_module(A,M,N),
'$opdec'(P,T,N,M).
/** @pred current_op( _P_, _T_, _F_) is iso
Defines the relation: _P_ is a currently defined operator of type
_T_ and precedence _P_.
*/
current_op(X,Y,V) :- var(V), !,
'$current_module'(M),
'$do_current_op'(X,Y,V,M).
current_op(X,Y,M:Z) :- !,
'$current_opm'(X,Y,Z,M).
current_op(X,Y,Z) :-
'$current_module'(M),
'$do_current_op'(X,Y,Z,M).
'$current_opm'(X,Y,Z,M) :-
nonvar(Y),
\+ '$associativity'(Y),
'$do_error'(domain_error(operator_specifier,Y),current_op(X,Y,M:Z)).
'$current_opm'(X,Y,Z,M) :-
var(Z), !,
'$do_current_op'(X,Y,Z,M).
'$current_opm'(X,Y,M:Z,_) :- !,
'$current_opm'(X,Y,Z,M).
'$current_opm'(X,Y,Z,M) :-
'$do_current_op'(X,Y,Z,M).
'$do_current_op'(X,Y,Z,M) :-
nonvar(Y),
\+ '$associativity'(Y),
'$do_error'(domain_error(operator_specifier,Y),current_op(X,Y,M:Z)).
'$do_current_op'(X,Y,Z,M) :-
atom(Z), !,
'$current_atom_op'(Z, M1, Prefix, Infix, Posfix),
( M1 = prolog -> true ; M1 = M ),
(
'$get_prefix'(Prefix, X, Y)
;
'$get_infix'(Infix, X, Y)
;
'$get_posfix'(Posfix, X, Y)
).
'$do_current_op'(X,Y,Z,M) :-
'$current_op'(Z, M1, Prefix, Infix, Posfix),
( M1 = prolog -> true ; M1 = M ),
(
'$get_prefix'(Prefix, X, Y)
;
'$get_infix'(Infix, X, Y)
;
'$get_posfix'(Posfix, X, Y)
).
'$get_prefix'(Prefix, X, Y) :-
Prefix > 0,
X is Prefix /\ 0xfff,
(
0x2000 /\ Prefix =:= 0x2000
->
Y = fx
;
Y = fy
).
'$get_infix'(Infix, X, Y) :-
Infix > 0,
X is Infix /\ 0xfff,
(
0x3000 /\ Infix =:= 0x3000
->
Y = xfx
;
0x1000 /\ Infix =:= 0x1000
->
Y = xfy
;
Y = yfx
).
'$get_posfix'(Posfix, X, Y) :-
Posfix > 0,
X is Posfix /\ 0xfff,
(
0x1000 /\ Posfix =:= 0x1000
->
Y = xf
;
Y = yf
).
prolog :-
live.
%%% current ....
/** @pred callable( _T_) is iso
Checks whether _T_ is a callable term, that is, an atom or a
compound term.
*/
callable(A) :-
( var(A) -> fail ; number(A) -> fail ; true ).
/** @pred simple( _T_)
Checks whether _T_ is unbound, an atom, or a number.
*/
simple(V) :- var(V), !.
simple(A) :- atom(A), !.
simple(N) :- number(N).
/** @pred nth_instance(? _Key_,? _Index_,? _R_)
Fetches the _Index_nth entry in the internal database under the key
_Key_. Entries are numbered from one. If the key _Key_ or the
_Index_ are bound, a reference is unified with _R_. Otherwise,
the reference _R_ must be given, and YAP will find
the matching key and index.
*/
nth_instance(Key,Index,Ref) :-
nonvar(Key), var(Index), var(Ref), !,
recorded(Key,_,Ref),
'$nth_instance'(_,Index,Ref).
nth_instance(Key,Index,Ref) :-
'$nth_instance'(Key,Index,Ref).
/** @pred nth_instance(? _Key_,? _Index_, _T_,? _R_)
Fetches the _Index_nth entry in the internal database under the key
_Key_. Entries are numbered from one. If the key _Key_ or the
_Index_ are bound, a reference is unified with _R_. Otherwise,
the reference _R_ must be given, and YAP will find
the matching key and index.
*/
nth_instance(Key,Index,T,Ref) :-
nonvar(Key), var(Index), var(Ref), !,
recorded(Key,T,Ref),
'$nth_instance'(_,Index,Ref).
nth_instance(Key,Index,T,Ref) :-
'$nth_instance'(Key,Index,Ref),
instance(Ref,T).
/** @pred nb_current(? _Name_, ? _Value_)
Enumerate all defined variables with their value. The order of
enumeration is undefined.
*/
/** @pred nb_current(? _Name_,? _Value_)
Enumerate all defined variables with their value. The order of
enumeration is undefined.
*/
nb_current(GlobalVariable, Val) :-
'$nb_current'(GlobalVariable),
'$nb_getval'(GlobalVariable, Val, _).
'$getval_exception'(GlobalVariable, _Val, Caller) :-
user:exception(undefined_global_variable, GlobalVariable, Action),
!,
(
Action == fail
->
fail
;
Action == retry
->
true
;
Action == error
->
'$do_error'(existence_error(variable, GlobalVariable),Caller)
;
'$do_error'(type_error(atom, Action),Caller)
).
/** @pred subsumes_term(? _Subsumer_, ? _Subsumed_)
Succeed if _Submuser_ subsumes _Subsuned_ but does not bind any
variable in _Subsumer_.
*/
subsumes_term(A,B) :-
\+ \+ terms:subsumes(A,B).
term_string( T, S, Opts) :-
var( T ),
!,
memory_file:open_mem_read_stream( S, Stream ),
read_term( Stream, T, Opts ),
close( Stream ).
term_string( T, S, _Opts) :-
format(string(S), '~q.~n', [T]).

View File

@@ -1,200 +0,0 @@
:- system_module( '$_utils', [callable/1,
current_op/3,
nb_current/2,
nth_instance/3,
nth_instance/4,
op/3,
prolog/0,
recordaifnot/3,
recordzifnot/3,
simple/1,
subsumes_term/2], ['$getval_exception'/3]).
:- use_system_module( '$_boot', ['$live'/0]).
:- use_system_module( '$_errors', ['$do_error'/2]).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% %%
%% The YapTab/YapOr/OPTYap systems %%
%% %%
%% YapTab extends the Yap Prolog engine to support sequential tabling %%
%% YapOr extends the Yap Prolog engine to support or-parallelism %%
%% OPTYap extends the Yap Prolog engine to support or-parallel tabling %%
%% %%
%% %%
%% Yap Prolog was developed at University of Porto, Portugal %%
%% %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:- meta_predicate
parallel(0),
parallel_findall(?,0,?),
parallel_findfirst(?,0,?),
parallel_once(0).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% or_statistics/0 %%
%% opt_statistics/0 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
or_statistics :-
current_output(Stream),
or_statistics(Stream).
opt_statistics :-
current_output(Stream),
opt_statistics(Stream).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% or_statistics/2 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% should match with code in OPTYap/opt.preds.c
or_statistics(total_memory,[BytesInUse,BytesAllocated]) :-
'$c_get_optyap_statistics'(0,BytesInUse,BytesAllocated).
or_statistics(or_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(4,BytesInUse,StructsInUse).
or_statistics(query_goal_solution_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(12,BytesInUse,StructsInUse).
or_statistics(query_goal_answer_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(13,BytesInUse,StructsInUse).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% opt_statistics/2 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% should match with code in OPTYap/opt.preds.c
opt_statistics(total_memory,[BytesInUse,BytesAllocated]) :-
'$c_get_optyap_statistics'(0,BytesInUse,BytesAllocated).
opt_statistics(table_entries,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(1,BytesInUse,StructsInUse).
opt_statistics(subgoal_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(2,BytesInUse,StructsInUse).
opt_statistics(dependency_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(3,BytesInUse,StructsInUse).
opt_statistics(or_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(4,BytesInUse,StructsInUse).
opt_statistics(suspension_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(5,BytesInUse,StructsInUse).
opt_statistics(subgoal_trie_nodes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(6,BytesInUse,StructsInUse).
opt_statistics(answer_trie_nodes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(7,BytesInUse,StructsInUse).
opt_statistics(subgoal_trie_hashes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(8,BytesInUse,StructsInUse).
opt_statistics(answer_trie_hashes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(9,BytesInUse,StructsInUse).
opt_statistics(global_trie_nodes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(10,BytesInUse,StructsInUse).
opt_statistics(global_trie_hashes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(11,BytesInUse,StructsInUse).
opt_statistics(query_goal_solution_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(12,BytesInUse,StructsInUse).
opt_statistics(query_goal_answer_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(13,BytesInUse,StructsInUse).
opt_statistics(table_subgoal_solution_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(14,BytesInUse,StructsInUse).
opt_statistics(table_subgoal_answer_frames,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(15,BytesInUse,StructsInUse).
opt_statistics(subgoal_entries,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(16,BytesInUse,StructsInUse).
opt_statistics(answer_ref_nodes,[BytesInUse,StructsInUse]) :-
'$c_get_optyap_statistics'(17,BytesInUse,StructsInUse).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% parallel/1 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
parallel(Goal) :-
parallel_mode(Mode), Mode = on, !,
(
'$parallel_query'(Goal)
;
true
).
parallel(Goal) :-
(
'$execute'(Goal),
fail
;
true
).
'$parallel_query'(Goal) :-
'$c_yapor_start',
'$execute'(Goal),
fail.
'$parallel_query'(_).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% parallel_findall/3 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
parallel_findall(Template,Goal,Answers) :-
parallel_mode(Mode), Mode = on, !,
(
'$parallel_findall_query'(Template,Goal)
;
'$c_parallel_get_answers'(Refs),
'$parallel_findall_recorded'(Refs,Answers),
eraseall(parallel_findall)
).
parallel_findall(Template,Goal,Answers) :-
findall(Template,Goal,Answers).
'$parallel_findall_query'(Template,Goal) :-
'$c_yapor_start',
'$execute'(Goal),
recordz(parallel_findall,Template,Ref),
'$c_parallel_new_answer'(Ref),
fail.
'$parallel_findall_query'(_,_).
'$parallel_findall_recorded'([],[]) :- !.
'$parallel_findall_recorded'([Ref|Refs],[Template|Answers]):-
recorded(parallel_findall,Template,Ref),
'$parallel_findall_recorded'(Refs,Answers).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% parallel_findfirst/3 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
parallel_findfirst(Template,Goal,Answer) :-
parallel_findall(Template,(Goal,!),Answer).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%% parallel_once/1 %%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
parallel_once(Goal) :-
parallel_mode(Mode), Mode = on, !,
(
'$parallel_once_query'(Goal)
;
recorded(parallel_once,Goal,Ref),
erase(Ref)
).
parallel_once(Goal) :-
once(Goal).
'$parallel_once_query'(Goal) :-
'$c_yapor_start',
'$execute'(once(Goal)),
recordz(parallel_once,Goal,_),
fail.
'$parallel_once_query'(_).
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

View File

@@ -1,464 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: yio.yap *
* Last rev: *
* mods: *
* comments: Input output predicates *
* *
*************************************************************************/
:- system_module( '$_yio', [at_end_of_line/0,
at_end_of_line/1,
consult_depth/1,
current_char_conversion/2,
current_line_number/1,
current_line_number/2,
current_stream/3,
display/1,
display/2,
exists/1,
fileerrors/0,
format/1,
nofileerrors/0,
open_pipe_streams/2,
prolog_file_name/2,
read/1,
read/2,
sformat/3,
socket/2,
socket/4,
socket_connect/3,
stream_position/2,
stream_position/3,
stream_position_data/3,
ttyget/1,
ttyget0/1,
ttynl/0,
ttyput/1,
ttyskip/1,
rename/2,
write_depth/2], ['$default_expand'/1,
'$extend_file_search_path'/1,
'$set_default_expand'/1]).
:- use_system_module( '$_boot', ['$system_catch'/4]).
:- use_system_module( '$_errors', ['$do_error'/2]).
/** @defgroup InputOutput Input/Output Predicates
@ingroup builtins
Some of the Input/Output predicates described below will in certain conditions
provide error messages and abort only if the file_errors flag is set.
If this flag is cleared the same predicates will just fail. Details on
setting and clearing this flag are given under 7.7.
@{
*/
/* stream predicates */
/** @defgroup IO_Sockets YAP Old Style Socket and Pipe Interface
@{
Autoload the socket/pipe library
*/
/** @pred socket(+ _DOMAIN_,- _SOCKET_)
Call socket/4 with _TYPE_ bound to `SOCK_STREAM'` and
_PROTOCOL_ bound to `0`.
*/
/** @pred socket(+ _DOMAIN_,+ _TYPE_,+ _PROTOCOL_,- _SOCKET_)
Corresponds to the BSD system call `socket`. Create a socket for
domain _DOMAIN_ of type _TYPE_ and protocol
_PROTOCOL_. Both _DOMAIN_ and _TYPE_ should be atoms,
whereas _PROTOCOL_ must be an integer.
The new socket object is
accessible through a descriptor bound to the variable _SOCKET_.
The current implementation of YAP accepts socket
domains `AF_INET` and `AF_UNIX`.
Socket types depend on the
underlying operating system, but at least the following types are
supported: `SOCK_STREAM'` and `SOCK_DGRAM'` (untested in 6.3).
*/
/** @pred socket_connect(+ _SOCKET_, + _PORT_, - _STREAM_)
Interface to system call `connect`, used for clients: connect
socket _SOCKET_ to _PORT_. The connection results in the
read/write stream _STREAM_.
Port information depends on the domain:
+ 'AF_UNIX'(+ _FILENAME_)
+ 'AF_FILE'(+ _FILENAME_)
connect to socket at file _FILENAME_.
+ 'AF_INET'(+ _HOST_,+ _PORT_)
Connect to socket at host _HOST_ and port _PORT_.
*/
/** @pred open_pipe_streams(Read, Write)
Autoload old pipe access interface
*/
%! @}
/** @pred exists(+ _F_)
Checks if file _F_ exists in the current directory.
*/
exists(F) :-
absolute_file_name(F, _, [file_errors(fail),access(exist),expand(true)]).
%! @addtogroup ReadTerm
% @{
/* Term IO */
%! @}
%! @addtogroup Write
% @{
/* meaning of flags for '$write' is
1 quote illegal atoms
2 ignore operator declarations
4 output '$VAR'(N) terms as A, B, C, ...
8 use portray(_)
flags are defined in yapio.h
*/
/** @pred display(+ _T_)
Displays term _T_ on the current output stream. All Prolog terms are
written in standard parenthesized prefix notation.
*/
display(T) :-
current_output(Out),
write_term(Out, T, [ignore_ops(true)]).
/** @pred display(+ _S_, _T_)
Like display/1, but using stream _S_ to display the term.
*/
display(Stream, T) :-
write_term(Stream, T, [ignore_ops(true)]).
/* interface to user portray */
'$portray'(T) :-
\+ '$undefined'(portray(_),user),
'$system_catch'(call(portray(T)),user,Error,user:'$Error'(Error)), !,
set_value('$portray',true), fail.
'$portray'(_) :- set_value('$portray',false), fail.
%! @}
%! @addtogroup Format
% @{
/** @pred format(+ _T_)
Print formatted output to the current output stream.
*/
format(T) :-
format(T, []).
%! @}
%! @addtogroup CharsIO
% @{
/* character I/O */
/** @pred ttyget(- _C_)
The same as `get(C)`, but from stream user_input.
*/
ttyget(N) :- get(user_input,N).
/** @pred ttyget0(- _C_)
The same as `get0(C)`, but from stream user_input.
*/
ttyget0(N) :- get0(user_input,N).
/** @pred ttyskip(- _C_)
Like skip/1, but always using stream user_input.
stream.
*/
ttyskip(N) :- N1 is N, '$skip'(user_input,N1).
/** @pred ttyput(+ _N_)
As `put(N)` but always to user_output.
*/
ttyput(N) :- N1 is N, put(user_output,N1).
/** @pred ttynl
Outputs a new line to stream user_output.
*/
ttynl :- nl(user_output).
%! @}
%! @addtogroup StreamM
% @{
/** @pred current_line_number(- _LineNumber_)
Unify _LineNumber_ with the line number for the current output stream.
*/
current_line_number(N) :-
current_input(Stream),
line_count(Stream, N).
/** @pred current_line_number(+ _Stream_,- _LineNumber_)
Unify _LineNumber_ with the line number for _Stream_.
*/
current_line_number(Stream,N) :-
line_count(Stream, N).
/** @pred stream_position(+ _Stream_,- _StreamPosition_)
Unify _StreamPosition_ with the packaged information of position on
current stream _Stream_. Use stream_position_data/3 to
retrieve information on character or line count.
*/
stream_position(Stream, Position) :-
stream_property(Stream, position(Position)).
/** @pred stream_position(+ _Stream_,- _StreamPosition_, +_NewPosition_)
Unify _StreamPosition_ with the packaged information of position on
current stream _Stream_ an then moves to position _NewPosition_.
*/
stream_position(Stream, Position, NewPosition) :-
stream_property(Stream, position(Position)),
set_stream_position(Stream, NewPosition).
/** @pred at_end_of_line
Tests whether the next character in the current input stream is a line break character.
*/
at_end_of_line :-
current_input(S),
at_end_of_line(S).
/** @pred at_end_of_line( +Stream )
Tests whether the next character in the stream is a line break character.
*/
at_end_of_line(S) :-
stream_property(S, end_of_stream(past)), !.
at_end_of_line(S) :-
peek_code(S,N), ( N = 10 -> true ; N = -1).
/** @pred current_char_conversion(? _IN_,? _OUT_) is iso
If _IN_ is unbound give all current character
translations. Otherwise, give the translation for _IN_, if one
exists.
*/
current_char_conversion(X,Y) :-
var(X), !,
'$all_char_conversions'(List),
'$fetch_char_conversion'(List,X,Y).
current_char_conversion(X,Y) :-
'$current_char_conversion'(X,Y).
'$fetch_char_conversion'([X,Y|_],X,Y).
'$fetch_char_conversion'([_,_|List],X,Y) :-
'$fetch_char_conversion'(List,X,Y).
split_path_file(File, Path, Name) :-
file_directory_name(File, Path),
file_base_name(File, Name).
/** @pred current_stream( _F_, _M_, _S_)
Defines the relation: The stream _S_ is opened on the file _F_
in mode _M_. It might be used to obtain all open streams (by
backtracking) or to access the stream for a file _F_ in mode
_M_, or to find properties for a stream _S_. Notice that some
streams might not be associated to a file: in this case YAP tries to
return the file number. If that is not available, YAP unifies _F_
with _S_.
*/
current_stream(File, Mode, Stream) :-
stream_property(Stream, mode(Mode)),
'$stream_name'(Stream, File).
'$stream_name'(Stream, File) :-
stream_property(Stream, file_name(File)), !.
'$stream_name'(Stream, file_no(File)) :-
stream_property(Stream, file_no(File)), !.
'$stream_name'(Stream, Stream).
'$extend_file_search_path'(P) :-
atom_codes(P,S),
'$env_separator'(ES),
'$split_for_path'(S,0'=,ES,Paths), %'
'$add_file_search_paths'(Paths).
'$split_for_path'([], _, _, []).
'$split_for_path'(S, S1, S2, [A1=A2|R]) :-
'$fetch_first_path'(S, S1, A1, SR1),
'$fetch_second_path'(SR1, S2, A2, SR),
'$split_for_path'(SR, S1, S2, R) .
'$fetch_first_path'([S1|SR],S1,[],SR) :- !.
'$fetch_first_path'([C|S],S1,[C|F],SR) :-
'$fetch_first_path'(S,S1,F,SR).
'$fetch_second_path'([],_,[],[]).
'$fetch_second_path'([S1|SR],S1,[],SR) :- !.
'$fetch_second_path'([C|S],S1,[C|A2],SR) :-
'$fetch_second_path'(S,S1,A2,SR).
'$add_file_search_paths'([]).
'$add_file_search_paths'([NS=DS|Paths]) :-
atom_codes(N,NS),
atom_codes(D,DS),
assert(user:file_search_path(N,D)),
'$add_file_search_paths'(Paths).
'$format@'(Goal,Out) :-
with_output_to(codes(Out), Goal).
sformat(String, Form, Args) :-
format(codes(String, []), Form, Args).
/** @pred stream_position_data(+ _Field_,+ _StreamPosition_,- _Info_)
Extract values from stream position objects.
'$stream_position' is of the format '$stream_position'(Byte, Char,
Line, LinePos). Given the packaged stream position term
_StreamPosition_, unify _Info_ with _Field_ `line_count`,
`byte_count`, or `char_count`.
*/
stream_position_data(Prop, Term, Value) :-
nonvar(Prop), !,
( '$stream_position_field'(Prop, Pos)
-> arg(Pos, Term, Value)
; '$do_error'(domain_error(stream_position_data), Prop)
).
stream_position_data(Prop, Term, Value) :-
'$stream_position_field'(Prop, Pos),
arg(Pos, Term, Value).
'$stream_position_field'(char_count, 1).
'$stream_position_field'(line_count, 2).
'$stream_position_field'(line_position, 3).
'$stream_position_field'(byte_count, 4).
'$set_encoding'(Enc) :-
set_stream(loop_stream, encoding(Enc)).
%! @}
'$codes_to_chars'(String0, String, String0) :- String0 == String, !.
'$codes_to_chars'(String0, [Code|String], [Char|Chars]) :-
atom_codes(Char, [Code]),
'$codes_to_chars'(String0, String, Chars).
/** @pred file_exists(+ _File__)
The atom _File_ corresponds to an existing file or directory.
*/
file_exists(IFile) :-
absolute_file_name(IFile, _File, [expand(true), solutions(first), access(exist)]).
/** @pred rename(+F , +G)
Renames the single file _F_ to _G_.
*/
rename(IFile, OFile) :-
absolute_file_name(IFile, IF, [access(read),expand(true)]),
absolute_file_name(OFile, OF, [expand(true)]),
'$rename'(IF, OF).
/** @pred access_file(+F , +G)
Verify whether file F respects property _G_. The file is processed
with absolute_file_name.
*/
access_file(IFile, Access) :-
absolute_file_name(IFile, _IF, [access(Access),expand(true)]).
/**
@}
*/

View File

@@ -1,156 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: regexp.yap *
* Last rev: 5/15/2000 *
* mods: *
* comments: pseudo random numbers in YAP (from code by Van Gelder) *
* *
*************************************************************************/
/**
* @file prandom.yap
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Tue Nov 17 23:43:18 2015
*
* @brief Van Gelder Random Number Generator
*
*
*/
:- module(prandom, [
ranstart/0,
ranstart/1,
rannum/1,
ranunif/2]).
%%
% @groupdef prandom Van Gelder Random Number Generator
% @ingroup builtins
% @{
%
%
% The following code produces the same random numbers as my previous
% ranpkg.pl, but is more accurately documented and slightly more
% efficient.
%
% ranpkg.pl random number package Allen Van Gelder, Stanford
vvvvvv
% rannum produces a random non-negative integer whose low bits are not
% all that random, so it should be scaled to a smaller range in general.
% The integer is in the range 0 .. 2^(w-1) - 1,
% where w is the word size available for integers, e.g., 18 for DEC-10,
% and 16 or 32 for VAX and most IBM.
%
% ranunif produces a uniformly distributed non-negative random integer over
% a caller-specified range. If range is R, the result is in 0 .. R-1.
%
% ranstart must be called before the first use of rannum or ranunif,
% and may be called later to redefine the seed.
% ranstart/0 causes a built-in seed to be used.
% ranstart(N), N an integer, varies this, but the same N always
% produces the same sequence of numbers.
%
% According to my reading of Knuth, Vol. 2, this generator has period
% 2^(w-1) and potency w/2, i.e., 8, 9, or 16 in practice. Knuth says
% potency should be at least 5, so this looks more than adequate.
% Its drawback is the lack of randomness of low-order bits.
/** @pred rannum(- _I_)
Produces a random non-negative integer _I_ whose low bits are not
all that random, so it should be scaled to a smaller range in general.
The integer _I_ is in the range 0 .. 2^(w-1) - 1. You can use:
~~~~~
rannum(X) :- yap_flag(max_integer,MI), rannum(R), X is R/MI.
~~~~~
to obtain a floating point number uniformly distributed between 0 and 1.
*/
/** @pred ranstart
Initialize the random number generator using a built-in seed. The
ranstart/0 built-in is always called by the system when loading
the package.
*/
/** @pred ranstart(+ _Seed_)
Initialize the random number generator with user-defined _Seed_. The
same _Seed_ always produces the same sequence of numbers.
*/
/** @pred ranunif(+ _Range_,- _I_)
ranunif/2 produces a uniformly distributed non-negative random
integer _I_ over a caller-specified range _R_. If range is _R_,
the result is in 0 .. _R_-1.
*/
:- initialization(ranstart).
:- dynamic ranState/5.
%
% vsc: dangerous code, to change.
%
%
wsize(32) :-
yap_flag(max_tagged_integer,I), I >> 32 =:= 0, !.
wsize(64).
ranstart :- ranstart(8'365). %
ranstart(N) :-
wsize(Wsize), % bits available for int.
MaxInt is \(1 << (Wsize - 1)), % all bits but sign bit are 1.
Incr is (8'154 << (Wsize - 9)) + 1, % per Knuth, v.2 p.78
Mult is 8'3655, % OK for 16-18 Wsize
Prev is Mult * (8 * N + 5) + Incr,
assert(ranState(Mult, Prev, Wsize, MaxInt, Incr) ).
rannum(Raw) :-
retract(ranState(Mult, Prev, Wsize, MaxInt, Incr)),
Curr is Mult * Prev + Incr,
assert(ranState(Mult, Curr, Wsize, MaxInt, Incr)),
( Curr > 0,
Raw is Curr
;
Curr < 0,
Raw is Curr /\ MaxInt % force positive sign bit
).
ranunif(Range, Unif) :-
Range > 0,
retract( ranState(Mult, Prev, Wsize, MaxInt, Incr) ),
Curr is Mult * Prev + Incr,
assert(ranState(Mult, Curr, Wsize, MaxInt, Incr)),
( Curr > 0,
Raw is Curr
;
Curr < 0,
Raw is Curr /\ MaxInt % force positive sign bit
),
Unif is (Raw * Range) >> (Wsize-1).
/%%! @}

View File

@@ -1,157 +0,0 @@
% % % -*-Mode : Prolog; -*-
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
% Author: Vitor Santos Costa
% E-mail: vsc@dcc.fc.up.pt
% Copyright (C): Universidade do Porto
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% This file is part of the YAP Python Interface
% distributed according to Perl Artistic License
% check LICENSE file for distribution license
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%%
:- module(python,
[
init_python/0,
end_python/0,
python_command/1,
python_run_file/1,
python_run_command/1,
python_run_script/2,
python_assign/3,
python_import/1,
array_to_python_list/4,
array_to_python_tuple/4,
array_to_python_view/5,
python/2,
acquire_GIL/0,
release_GIL/0,
python_threaded/0,
prolog_list_to_python_list/3,
(:=)/2,
(:=)/1,
% (<-)/2,
% (<-)/1,
op(100,fy,$),
op(950,fy,:=),
op(950,yfx,:=),
op(950,fx,<-),
op(950,yfx,<-),
op(50, yf, []),
op(50, yf, '()'),
op(100, xfy, '.'),
op(100, fy, '.')
]).
/** <module> python
A C-based Prolog interface to python.
@author Vitor Santos Costa
@version 0:0:5, 2012/10/8
@license Perl Artistic License
This is an interface to allow calling Python from Prolog. Please look
at the SWIG package if you want to embedd Prolog with Python.
The interface should be activated by consulting the python lybrary. It
immediately boots a Python image.
To best define the interface, one has to address two opposite goals:
- make it as similar to python as possible
- make all embedded language interfaces (python, R, Java) as
similar as possible.
YAP supports the following translation between Prolog and Python:
| *Prolog* | *Pyhon* | *Prolog Examples* |
|:-------------:|:-------------:|---------------------------------------:|
| Numbers | Numbers | 2.3
| | | 1545
| | |
| Atom | Symbols | var
| $Atom | | $var [ = var]
| `string` | 'string' | \`hello\`
| "string" | ' | "hello"
| | |
| Atom(...) | Symb(...) | f( a, b, named=v)
| E.F(...) | E.F (...) | mod.f( a) [ = [mod\|f(a)] ]
| Atom() | | f() [ = '()'(f) ]
| Lists | Lists | [1,2,3]
| t(....) | Tuples | t(1,2,3) to (1,2,3)
| (..., ...) | | (1,2,3)[ = (1,(2,3))]
| {.=., .=.} | Dict | {\`one\`: 1, \`two\`: 2, \`three\`: 3}
*/
/************************************************************************************************************
Python interface
Data types are
Python Prolog
string atoms
numbers numbers
lists lists
tuples t(...)
generic objs __pointer__(Address)
$var refers to the attribute __main__.var
*************************************************************************************************************/
:- use_module(library(shlib)).
:- use_module(library(lists)).
:- use_module(library(apply_macros)).
:- use_module(library(charsio)).
:- dynamic python_mref_cache/2, python_obj_cache/2.
:= (P1,P2) :- !,
:= P1,
:= P2.
:= import( F ) :- !, python_import(F).
:= F :- python_proc(F).
V <- F :-
V := F.
( V := F ) :-
python_assign(F, V).
((<- F)) :-
:= F.
python_import(Module) :-
python_import(Module, _).
python(Exp, Out) :-
Out := Exp.
python_command(Cmd) :-
python_run_command(Cmd).
start_python :-
python_import('inspect', _),
at_halt(end_python).
add_cwd_to_python :-
unix(getcwd(Dir)),
atom_concat(['sys.path.append(\"',Dir,'\")'], Command),
python_command(Command),
python_command("sys.argv = [\"yap\"]").
% done
:- initialization( load_foreign_files([libYAPPython], [], init_python), now ).
:- initialization( load_foreign_library(foreign(libYAPPython), init_python), now ).

View File

@@ -1,287 +0,0 @@
/**
* @file queues.yap
* @author R.A.O'Keefe
* @date Friday November 18th, 1983, 8:09:31
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date 1999-
*
* @brief define queue operations
*
*
*/
:- module(queues, [
make_queue/1, % create empty queue
join_queue/3, % add element to end of queue
list_join_queue/3, % add many elements to end of queue
jump_queue/3, % add element to front of queue
list_jump_queue/3, % add many elements to front of queue
head_queue/2, % look at first element of queue
serve_queue/3, % remove first element of queue
length_queue/2, % count elements of queue
empty_queue/1, % test whether queue is empty
list_to_queue/2, % convert list to queue
queue_to_list/2 % convert queue to list
]).
/** @defgroup queues Queues
@ingroup library
@{
The following queue manipulation routines are available once
included with the `use_module(library(queues))` command. Queues are
implemented with difference lists.
In this package, a queue is represented as a term Front-Back, where
Front is a list and Back is a tail of that list, and is normally a
variable. join_queue will only work when the Back is a variable,
the other routines will accept any tail. The elements of the queue
are the list difference, that is, all the elements starting at Front
and stopping at Back. Examples:
[a,b,c,d,e|Z]-Z has elements a,b,c,d,e
[a,b,c,d,e]-[d,e] has elements a,b,c
Z-Z has no elements
[1,2,3]-[1,2,3] has no elements
*/
/**
@pred make_queue(+ _Queue_)
Creates a new empty queue. It should only be used to create a new queue.
*/
/** @pred empty_queue(+ _Queue_)
Tests whether the queue is empty.
*/
/** @pred head_queue(+ _Queue_, ? _Head_)
Unifies Head with the first element of the queue.
*/
/** @pred join_queue(+ _Element_, + _OldQueue_, - _NewQueue_)
Adds the new element at the end of the queue.
*/
/** @pred jump_queue(+ _Element_, + _OldQueue_, - _NewQueue_)
Adds the new element at the front of the list.
*/
/** @pred length_queue(+ _Queue_, - _Length_)
Counts the number of elements currently in the queue.
*/
/** @pred list_join_queue(+ _List_, + _OldQueue_, - _NewQueue_)
Ads the new elements at the end of the queue.
*/
/** @pred list_jump_queue(+ _List_, + _OldQueue_, + _NewQueue_)
Adds all the elements of _List_ at the front of the queue.
*/
/** @pred list_to_queue(+ _List_, - _Queue_)
Creates a new queue with the same elements as _List._
*/
/** @pred queue_to_list(+ _Queue_, - _List_)
Creates a new list with the same elements as _Queue_.
*/
/** @pred serve_queue(+ _OldQueue_, + _Head_, - _NewQueue_)
Removes the first element of the queue for service.
*/
:- use_module(library(lists), [append/3]).
/*
:- mode
make_queue(-),
join_queue(+, +, -),
list_join_queue(+, +, -),
jump_queue(+, +, -),
list_jump_queue(+, +, -),
head_queue(+, ?),
serve_queue(+, ?, -),
length_queue(+, ?),
length_queue(+, +, +, -),
empty_queue(+),
list_to_queue(+, -),
queue_to_list(+, -),
queue_to_list(+, +, -).
*/
% make_queue(Queue)
% creates a new empty queue. It will also match empty queues, but
% because Prolog doesn't do the occurs check, it will also match
% other queues, creating circular lists. So this should ONLY be
% used to make new queues.
make_queue(X-X).
% join_queue(Element, OldQueue, NewQueue)
% adds the new element at the end of the queue. The old queue is
% side-effected, so you *can't* do
% join_queue(1, OldQ, NewQ1),
% join_queue(2, OldQ, NewQ2).
% There isn't any easy way of doing that, sensible though it might
% be. You *can* do
% join_queue(1, OldQ, MidQ),
% join_queue(2, MidQ, NewQ).
% See list_join_queue.
join_queue(Element, Front-[Element|Back], Front-Back).
% list_join_queue(List, OldQueue, NewQueue)
% adds the new elements at the end of the queue. The elements are
% added in the same order that they appear in the list, e.g.
% list_join_queue([y,z], [a,b,c|M]-M, [a,b,c,y,z|N]-N).
list_join_queue(List, Front-OldBack, Front-NewBack) :-
append(List, OldBack, NewBack).
% jump_queue(Element, OldQueue, NewQueue)
% adds the new element at the front of the list. Unlike join_queue,
% jump_queue(1, OldQ, NewQ1),
% jump_queue(2, OldQ, NewQ2)
% *does* work, though if you add things at the end of NewQ1 they
% will also show up in NewQ2. Note that
% jump_queue(1, OldQ, MidQ),
% jump_queue(2, MidQ, NewQ)
% makes NewQ start 2, 1, ...
jump_queue(Element, Front-Back, [Element|Front]-Back).
% list_jump_queue(List, OldQueue, NewQueue)
% adds all the elements of List at the front of the queue. There are
% two ways we might do this. We could add all the elements one at a
% time, so that they would appear at the beginning of the queue in the
% opposite order to the order they had in the list, or we could add
% them in one lump, so that they have the same order in the queue as
% in the list. As you can easily add the elements one at a time if
% that is what you want, I have chosen the latter.
list_jump_queue(List, OldFront-Back, NewFront-Back) :-
append(List, OldFront, NewFront).
% reverse(List, OldFront, NewFront). % for the other definition
% head_queue(Queue, Head)
% unifies Head with the first element of the queue. The tricky part
% is that we might be at the end of a queue: Back-Back, with Back a
% variable, and in that case this predicate should not succeed, as we
% don't know what that element is or whether it exists yet.
head_queue(Front-Back, Head) :-
Front \== Back, % the queue is not empty
Front = [Head|_].
% serve_queue(OldQueue, Head, NewQueue)
% removes the first element of the queue for service.
serve_queue(OldFront-Back, Head, NewFront-Back) :-
OldFront \== Back,
OldFront = [Head|NewFront].
% empty_queue(Queue)
% tests whether the queue is empty. If the back of a queue were
% guaranteed to be a variable, we could have
% empty_queue(Front-Back) :- var(Front).
% but I don't see why you shouldn't be able to treat difference
% lists as queues if you want to.
empty_queue(Front-Back) :-
Front == Back.
% length_queue(Queue, Length)
% counts the number of elements currently in the queue. Note that
% we have to be careful in checking for the end of the list, we
% can't test for [] the way length(List) does.
length_queue(Front-Back, Length) :-
length_queue(Front, Back, 0, N),
Length = N.
length_queue(Front, Back, N, N) :-
Front == Back, !.
length_queue([_|Front], Back, K, N) :-
L is K+1,
length_queue(Front, Back, L, N).
% list_to_queue(List, Queue)
% creates a new queue with the same elements as List.
list_to_queue(List, Front-Back) :-
append(List, Back, Front).
% queue_to_list(Queue, List)
% creates a new list with the same elements as Queue.
queue_to_list(Front-Back, List) :-
queue_to_list(Front, Back, List).
queue_to_list(Front, Back, Ans) :-
Front == Back, !, Ans = [].
queue_to_list([Head|Front], Back, [Head|Tail]) :-
queue_to_list(Front, Back, Tail).
/** @} */

View File

@@ -1,222 +0,0 @@
/*************************************************************************
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: random.yap *
* Last rev: 5/12/99 *
* mods: *
* comments: Random operations *
* *
*************************************************************************/
/**
* @file random.yap
* @author original code from RA O'Keefe.
* @author VITOR SANTOS COSTA <vsc@VITORs-MBP.lan>
* @date Wed Nov 18 00:05:21 2015
*
* @brief Integer Random Number Generator
*
*
*/
:- module(random, [
random/1,
random/3,
randseq/3,
randset/3,
getrand/1,
setrand/1
]).
/** @defgroup random Random Number Generator
@ingroup library
@{
Since YAP-4.3.19 YAP uses
the O'Keefe public-domain algorithm, based on the "Applied Statistics"
algorithm AS183.
The following random number operations are included with the
`use_module(library(random))` command.
In ROK's words: ``This is algorithm AS 183 from Applied Statistics. I also have a C
version. It is really very good. It is straightforward to make a
version which yields 15-bit random integers using only integer
arithmetic.''
*/
/** @pred getrand(- _Key_)
Unify _Key_ with a term of the form `rand(X,Y,Z)` describing the
current state of the random number generator.
*/
/** @pred random(+ _LOW_, + _HIGH_, - _NUMBER_)
Unify _Number_ with a number in the range
`[LOW...HIGH)`. If both _LOW_ and _HIGH_ are
integers then _NUMBER_ will also be an integer, otherwise
_NUMBER_ will be a floating-point number.
*/
/** @defgroup Pseudo_Random Pseudo Random Number Integer Generator
@ingroup library
@{
The following routines produce random non-negative integers in the range
0 .. 2^(w-1) -1, where w is the word size available for integers, e.g.
32 for Intel machines and 64 for Alpha machines. Note that the numbers
generated by this random number generator are repeatable. This generator
was originally written by Allen Van Gelder and is based on Knuth Vol 2.
*/
/** @pred random(- _Number_)
Unify _Number_ with a floating-point number in the range `[0...1)`.
*/
/** @pred randseq(+ _LENGTH_, + _MAX_, - _Numbers_)
Unify _Numbers_ with a list of _LENGTH_ unique random integers
in the range `[1... _MAX_)`.
*/
/** @pred randset(+ _LENGTH_, + _MAX_, - _Numbers_)
Unify _Numbers_ with an ordered list of _LENGTH_ unique random
integers in the range `[1... _MAX_)`.
*/
/** @pred setrand(+ _Key_)
Use a term of the form `rand(X,Y,Z)` to set a new state for the
random number generator. The integer `X` must be in the range
`[1...30269)`, the integer `Y` must be in the range
`[1...30307)`, and the integer `Z` must be in the range
`[1...30323)`.
*/
%:- use_module(library(pairs)).
:- use_module(library(lists)).
:- load_foreign_files([yap_random], [], init_random).
% random(R) binds R to a new random number in [0.0,1.0)
% random(L, U, R) binds R to a random integer in [L,U)
% when L and U are integers (note that U will NEVER be generated),
% or to a random floating number in [L,U) otherwise.
random(L, U, R) :-
( integer(L), integer(U) ->
U > L,
random(X),
R is L+integer((U-L)*X)
;
number(L), number(U),
U > L,
random(X),
R is L+((U-L)*X)
).
/* There are two versions of this operation.
randset(K, N, S)
generates a random set of K integers in the range 1..N.
The result is an ordered list, such as setof might produce.
randseq(K, N, L)
generates a random sequence of K integers, the order is as
random as we can make it.
*/
randset(K, N, S) :-
K >= 0,
K =< N,
randset(K, N, [], S).
randset(0, _, S, S) :- !.
randset(K, N, Si, So) :-
random(X),
X * N < K, !,
J is K-1,
M is N-1,
randset(J, M, [N|Si], So).
randset(K, N, Si, So) :-
M is N-1,
randset(K, M, Si, So).
randseq(K, N, S) :-
randseq(K, N, L, []),
keysort(L, R),
strip_keys(R, S).
randseq(0, _, S, S) :- !.
randseq(K, N, [Y-N|Si], So) :-
random(X),
X * N < K, !,
random(Y),
J is K-1,
M is N-1,
randseq(J, M, Si, So).
randseq(K, N, Si, So) :-
M is N-1,
randseq(K, M, Si, So).
strip_keys([], []) :- !.
strip_keys([_-K|L], [K|S]) :-
strip_keys(L, S).
setrand(rand(X,Y,Z)) :-
integer(X),
integer(Y),
integer(Z),
X > 0,
X < 30269,
Y > 0,
Y < 30307,
Z > 0,
Z < 30323,
setrand(X,Y,Z).
getrand(rand(X,Y,Z)) :-
getrand(X,Y,Z).
/** @} */

Some files were not shown because too many files have changed in this diff Show More