From 14747fd0bf407b77f692176d391fe8c4b2a28107 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?V=C3=ADtor=20Santos=20Costa?= Date: Wed, 13 Nov 2013 22:52:36 +0000 Subject: [PATCH] more fixes --- C/iopreds.c | 6 +- C/pl-yap.c | 79 +++++++++++ H/Yap.h | 27 ---- H/dlocals.h | 2 - H/hlocals.h | 1 - H/ilocals.h | 1 - H/pl-global.h | 29 ++++ H/pl-incl.h | 13 +- H/pl-shared.h | 13 +- H/rlocals.h | 1 - misc/LOCALS | 2 - os/pl-prologflag.c | 2 - pl/absf.yap | 326 +++++++++++++++++++++++++++++++++++++++++++++ pl/consult.yap | 309 ------------------------------------------ pl/init.yap | 1 + 15 files changed, 458 insertions(+), 354 deletions(-) create mode 100644 pl/absf.yap diff --git a/C/iopreds.c b/C/iopreds.c index a45aa7b6b..b85242557 100755 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -118,7 +118,7 @@ Yap_InitPlIO (void) */ static int newline = TRUE; -#if DEBUG +#if DEBUG_YAP static int eolflg = 1; @@ -1088,7 +1088,7 @@ Yap_InitBackIO (void) { } -#if DEBUG +#if DEBUG_YAP static Int p_write_string( USES_REGS1 ) { @@ -1116,7 +1116,7 @@ Yap_InitIOPreds(void) Yap_InitCPred ("$get_read_error_handler", 1, p_get_read_error_handler, SafePredFlag|SyncPredFlag); Yap_InitCPred ("$read", 7, p_read, SyncPredFlag|UserCPredFlag); Yap_InitCPred ("$read", 8, p_read2, SyncPredFlag|UserCPredFlag); -#if DEBUG +#if DEBUG_YAP Yap_InitCPred ("write_string", 2, p_write_string, SyncPredFlag|UserCPredFlag); #endif Yap_InitCPred ("$start_line", 1, p_startline, SafePredFlag|SyncPredFlag); diff --git a/C/pl-yap.c b/C/pl-yap.c index b6761a220..7da69272a 100755 --- a/C/pl-yap.c +++ b/C/pl-yap.c @@ -1333,6 +1333,85 @@ accessLevel(void) return NULL_ATOM; } +#define SKIP_VERY_DEEP 1000000000L +#define SKIP_REDO_IN_SKIP (SKIP_VERY_DEEP-1) + +#define WFG_TRACE 0x01000 +#define WFG_TRACING 0x02000 +#define WFG_BACKTRACE 0x04000 +#define WFG_CHOICE 0x08000 + +#define TRACE_FIND_NONE 0 +#define TRACE_FIND_ANY 1 +#define TRACE_FIND_NAME 2 +#define TRACE_FIND_TERM 3 + +typedef struct find_data_tag +{ int port; /* Port to find */ + bool searching; /* Currently searching? */ + int type; /* TRACE_FIND_* */ + union + { atom_t name; /* Name of goal to find */ + struct + { functor_t functor; /* functor of the goal */ + Record term; /* Goal to find */ + } term; + } goal; +} find_data; + + +int +tracemode(debug_type doit, debug_type *old) +{ GET_LD + + if ( doit ) + { debugmode(DBG_ON, NULL); + doit = TRUE; + } + + if ( old ) + *old = debugstatus.tracing; + + if ( debugstatus.tracing != doit ) + { debugstatus.tracing = doit; + printMessage(ATOM_silent, + PL_FUNCTOR_CHARS, "trace_mode", 1, + PL_ATOM, doit ? ATOM_on : ATOM_off); + } + if ( doit ) /* make sure trace works inside skip */ + { debugstatus.skiplevel = SKIP_VERY_DEEP; + if ( LD->trace.find ) + LD->trace.find->searching = FALSE; + } + + succeed; +} + + +int +debugmode(debug_type doit, debug_type *old) +{ GET_LD + + if ( old ) + *old = debugstatus.debugging; + + if ( debugstatus.debugging != doit ) + { if ( doit ) + { debugstatus.skiplevel = SKIP_VERY_DEEP; + if ( doit == DBG_ALL ) + { doit = DBG_ON; + } + } + debugstatus.debugging = doit; + printMessage(ATOM_silent, + PL_FUNCTOR_CHARS, "debug_mode", 1, + PL_ATOM, doit ? ATOM_on : ATOM_off); + } + + succeed; +} + + int getAccessLevelMask(atom_t a, access_level_t *val) { if ( a == ATOM_user ) diff --git a/H/Yap.h b/H/Yap.h index ddbf1274a..b5d4b72f0 100755 --- a/H/Yap.h +++ b/H/Yap.h @@ -365,33 +365,6 @@ typedef enum #define QUINTUS_TO_CHARS 0 #define ISO_TO_CHARS 1 -#define CPROLOG_CHARACTER_ESCAPES 0 -#define ISO_CHARACTER_ESCAPES 1 -#define SICSTUS_CHARACTER_ESCAPES 2 - -// SWI Stuff -typedef enum - { DBG_OFF = 0, /* no debugging */ - DBG_ON, /* switch on in current environment */ - DBG_ALL /* switch on globally */ - } debug_type; - -typedef int bool; - -typedef struct debuginfo -{ size_t skiplevel; /* current skip level */ - bool tracing; /* are we tracing? */ - debug_type debugging; /* are we debugging? */ - int leashing; /* ports we are leashing */ - int visible; /* ports that are visible */ - bool showContext; /* tracer shows context module */ - int styleCheck; /* source style checking */ - int suspendTrace; /* tracing is suspended now */ - //LocalFrame retryFrame; /* Frame to retry */ -} pl_debugstatus_t; -// over SWI - - typedef enum { INDEX_MODE_OFF = 0, diff --git a/H/dlocals.h b/H/dlocals.h index e8056c1c4..418fe3d62 100644 --- a/H/dlocals.h +++ b/H/dlocals.h @@ -412,8 +412,6 @@ #define LOCAL_search_atoms LOCAL->search_atoms_ #define REMOTE_search_atoms(wid) REMOTE(wid)->search_atoms_ -#define LOCAL_debugstatus LOCAL->debugstatus_ -#define REMOTE_debugstatus(wid) REMOTE(wid)->debugstatus_ #define LOCAL_SourceModule LOCAL->SourceModule_ #define REMOTE_SourceModule(wid) REMOTE(wid)->SourceModule_ diff --git a/H/hlocals.h b/H/hlocals.h index 4b5b8215d..4486c3a07 100644 --- a/H/hlocals.h +++ b/H/hlocals.h @@ -232,6 +232,5 @@ typedef struct worker_local { UInt exo_arg_; struct scan_atoms* search_atoms_; - pl_debugstatus_t debugstatus_; Term SourceModule_; } w_local; diff --git a/H/ilocals.h b/H/ilocals.h index cccfcf2ce..bbd21acc0 100644 --- a/H/ilocals.h +++ b/H/ilocals.h @@ -232,6 +232,5 @@ static void InitWorker(int wid) { REMOTE_exo_arg(wid) = 0; - REMOTE_SourceModule(wid) = 0; } diff --git a/H/pl-global.h b/H/pl-global.h index 63460f18d..be0a6f0e8 100644 --- a/H/pl-global.h +++ b/H/pl-global.h @@ -1,3 +1,25 @@ + +typedef enum + { DBG_OFF = 0, /* no debugging */ + DBG_ON, /* switch on in current environment */ + DBG_ALL /* switch on globally */ + } debug_type; + +typedef struct debuginfo +{ size_t skiplevel; /* current skip level */ + bool tracing; /* are we tracing? */ + debug_type debugging; /* are we debugging? */ + int leashing; /* ports we are leashing */ + int visible; /* ports that are visible */ + bool showContext; /* tracer shows context module */ + int styleCheck; /* source style checking */ + int suspendTrace; /* tracing is suspended now */ + //LocalFrame retryFrame; /* Frame to retry */ +} pl_debugstatus_t; + + +typedef struct find_data_tag * FindData; /* pl-trace.c */ + typedef enum { LDATA_IDLE = 0, LDATA_SIGNALLED, @@ -319,6 +341,12 @@ typedef struct PL_local_data { } exception; const char *float_format; /* floating point format */ + struct + { FindData find; /* / in tracer */ + } trace; + + pl_debugstatus_t _debugstatus; /* status of the debugger */ + #ifdef O_PLMT struct { //intptr_t magic; /* PL_THREAD_MAGIC (checking) */ @@ -375,3 +403,4 @@ extern PL_local_data_t lds; #define source_line_pos (LD->read_source.linepos) #define source_char_no (LD->read_source.character) +#define debugstatus (LD->_debugstatus) diff --git a/H/pl-incl.h b/H/pl-incl.h index 8a1c6e45b..b3134a31b 100755 --- a/H/pl-incl.h +++ b/H/pl-incl.h @@ -1,4 +1,8 @@ +#ifndef PL_INCL_H + +#define PL_INCL_H 1 + #include "config.h" #if USE_GMP @@ -47,8 +51,6 @@ #define SWIP "swi_" -#include "pl-shared.h" - /* try not to pollute the SWI space */ #ifdef P #undef P @@ -89,6 +91,8 @@ typedef int bool; typedef int Char; /* char that can pass EOF */ typedef uintptr_t word; /* Anonymous 4 byte object */ +#include "pl-shared.h" + #if SIZE_DOUBLE==SIZEOF_INT_P #define WORDS_PER_DOUBLE 1 #else @@ -186,6 +190,8 @@ typedef enum #endif typedef uintptr_t PL_atomic_t; /* same size as a word */ +typedef struct record * Record; + #define MAXSIGNAL 64 #define SIG_PROLOG_OFFSET 32 /* Start of Prolog signals */ @@ -839,3 +845,6 @@ extern const PL_extension PL_predicates_from_write[]; extern const PL_extension PL_predicates_from_prologflag[]; extern const PL_extension PL_predicates_from_win[]; +#define enableThreads(val) FALSE + +#endif diff --git a/H/pl-shared.h b/H/pl-shared.h index 60410ebaf..9a7cd9068 100644 --- a/H/pl-shared.h +++ b/H/pl-shared.h @@ -16,14 +16,17 @@ typedef uintptr_t term_t; #endif -#ifndef _FLI_H_INCLUDED +#if !defined(_FLI_H_INCLUDED) && !defined(PL_INCL_H) #ifdef __WINDOWS__ #include #include #endif -typedef void *record_t; +typedef int bool; + + +typedef DBTerm *record_t; typedef struct mod_entry *module_t; typedef uintptr_t atom_t; @@ -156,6 +159,7 @@ typedef struct initialise_handle * InitialiseHandle; #define clear(s, a) ((s)->flags &= ~(a)) #ifdef DEBUG /* should have messages here */ +#define DEBUG_YAP 1 #undef DEBUG #define DEBUG(LEVEL, COMMAND) #else @@ -203,10 +207,11 @@ typedef struct initialise_handle * InitialiseHandle; extern unsigned int getUnknownModule(module_t m); -#define debugstatus LOCAL_debugstatus /* status of the debugger */ - #define truePrologFlag(flag) true(&LD->prolog_flag.mask, flag) #define setPrologFlagMask(flag) set(&LD->prolog_flag.mask, flag) #define clearPrologFlagMask(flag) clear(&LD->prolog_flag.mask, flag) +COMMON(int) debugmode(debug_type new, debug_type *old); +COMMON(int) tracemode(debug_type new, debug_type *old); + #endif /* PL_SHARED_INCLUDE */ diff --git a/H/rlocals.h b/H/rlocals.h index ce3d5612f..df9184d10 100644 --- a/H/rlocals.h +++ b/H/rlocals.h @@ -231,7 +231,6 @@ static void RestoreWorker(int wid USES_REGS) { - } diff --git a/misc/LOCALS b/misc/LOCALS index b3d00a2e1..9172055b8 100644 --- a/misc/LOCALS +++ b/misc/LOCALS @@ -265,8 +265,6 @@ UInt exo_arg =0 // atom completion struct scan_atoms* search_atoms void -pl_debugstatus_t debugstatus void - Term SourceModule =0 END_WORKER_LOCAL diff --git a/os/pl-prologflag.c b/os/pl-prologflag.c index 2a5c00087..479fa0e91 100644 --- a/os/pl-prologflag.c +++ b/os/pl-prologflag.c @@ -568,7 +568,6 @@ set_prolog_flag_unlocked(term_t key, term_t value, int flags) else clearPrologFlagMask(mask); } -#ifndef __YAP_PROLOG__ if ( k == ATOM_character_escapes ) { if ( val ) set(m, M_CHARESCAPE); @@ -589,7 +588,6 @@ set_prolog_flag_unlocked(term_t key, term_t value, int flags) break; /* don't change value */ #endif } -#endif /* __YAP_PROLOG__ */ /* set the flag value */ f->value.a = (val ? ATOM_true : ATOM_false); diff --git a/pl/absf.yap b/pl/absf.yap new file mode 100644 index 000000000..71948ea8b --- /dev/null +++ b/pl/absf.yap @@ -0,0 +1,326 @@ +/************************************************************************* +* * +* YAP Prolog * +* * +* Yap Prolog was developed at NCCUP - Universidade do Porto * +* * +* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * +* * +************************************************************************** +* * +* File: consult.yap * +* Last rev: 8/2/88 * +* mods: * +* comments: Consulting Files in YAP * +* * +*************************************************************************/ + +absolute_file_name(V,Out) :- var(V), !, + '$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(source),file_errors(fail),solutions(first),expand(true)],F,G). + +% fix wrong argument order, TrueFileName should be last. +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)). + +'$absolute_file_name'(File, _Opts, _TrueFileName, G) :- var(File), !, + '$do_error'(instantiation_error, G). +'$absolute_file_name'(File,Opts,TrueFileName, G) :- + '$process_fn_opts'(Opts,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G), + /* our own local findall */ + nb:nb_queue(Ref), + ( + '$find_in_path'(File,opts(Extensions,RelTo,Type,Access,FErrors,Expand,Debug),TrueFileName,G), + nb:nb_queue_enqueue(Ref, TrueFileName), + fail + ; + nb:nb_queue_close(Ref, FileNames, []) + ), + '$absolute_file_names'(Solutions, FileNames, FErrors, TrueFileName, File, G). + +'$absolute_file_names'(_Solutions, [], error, _, File, G) :- !, + '$do_error'(existence_error(file,File),G). +'$absolute_file_names'(Solutions, FileNames, _, TrueFileName, _, _) :- + lists:member(TrueFileName, FileNames), + (Solutions == first -> ! ; true). + + +'$process_fn_opts'(V,_,_,_,_,_,_,_,_,G) :- var(V), !, + '$do_error'(instantiation_error, G). +'$process_fn_opts'([],[],_,txt,none,error,first,false,false,_) :- !. +'$process_fn_opts'([Opt|Opts],Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G) :- !, + '$process_fn_opt'(Opt,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions0,RelTo0,Type0,Access0,FErrors0,Solutions0,Expand0,Debug0,G), + '$process_fn_opts'(Opts,Extensions0,RelTo0,Type0,Access0,FErrors0,Solutions0,Expand0,Debug0,G). +'$process_fn_opts'(Opts,_Extensions,_RelTo,_Type,_Access,_FErrors,_Solutions,_Expand,_Debug,G) :- !, + '$do_error'(type_error(list,Opts),G). + +'$process_fn_opt'(Opt,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G) :- var(Opt), !, + '$do_error'(instantiation_error, G). +'$process_fn_opt'(extensions(Extensions),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,_,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G) :- !, + '$check_fn_extensions'(Extensions,G). +'$process_fn_opt'(relative_to(RelTo),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,_,Type,Access,FErrors,Solutions,Expand,Debug,G) :- !, + '$check_atom'(RelTo,G). +'$process_fn_opt'(access(Access),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,_,FErrors,Solutions,Expand,Debug,G) :- !, + '$check_atom'(Access,G). +'$process_fn_opt'(file_type(Type),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,_,Access,FErrors,Solutions,Expand,Debug,G) :- !, + '$check_fn_type'(Type,G). +'$process_fn_opt'(file_errors(FErrors),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,_,Solutions,Expand,Debug,G) :- !, + '$check_fn_errors'(FErrors,G). +'$process_fn_opt'(solutions(Solutions),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,_,Expand,Debug,G) :- !, + '$check_fn_solutions'(Solutions,G). +'$process_fn_opt'(expand(Expand),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,Solutions,_,Debug,G) :- !, + '$check_true_false'(Expand,G). +'$process_fn_opt'(verbose_file_search(Debug),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,_,G) :- !, + '$check_true_false'(Debug,G). +'$process_fn_opt'(Opt,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G) :- !, + '$do_error'(domain_error(file_name_option,Opt),G). + +'$check_fn_extensions'(V,G) :- var(V), !, + '$do_error'(instantiation_error, G). +'$check_fn_extensions'([],_) :- !. +'$check_fn_extensions'([A|L],G) :- !, + '$check_atom'(A,G), + '$check_fn_extensions'(L,G). +'$check_fn_extensions'(T,G) :- !, + '$do_error'(type_error(list,T),G). + +'$check_atom'(V,G) :- var(V), !, + '$do_error'(instantiation_error, G). +'$check_atom'(A,_G) :- atom(A), !. +'$check_atom'(T,G) :- !, + '$do_error'(type_error(atom,T),G). + +'$check_fn_type'(V,G) :- var(V), !, + '$do_error'(instantiation_error, G). +'$check_fn_type'(txt,_) :- !. +'$check_fn_type'(prolog,_) :- !. +'$check_fn_type'(source,_) :- !. +'$check_fn_type'(executable,_) :- !. +'$check_fn_type'(qlf,_) :- !. +'$check_fn_type'(directory,_) :- !. +'$check_fn_type'(T,G) :- atom(T), !, + '$do_error'(domain_error(file_type,T),G). +'$check_fn_type'(T,G) :- !, + '$do_error'(type_error(atom,T),G). + +'$check_fn_errors'(V,G) :- var(V), !, + '$do_error'(instantiation_error, G). +'$check_fn_errors'(fail,_) :- !. +'$check_fn_errors'(error,_) :- !. +'$check_fn_errors'(T,G) :- atom(T), !, + '$do_error'(domain_error(file_errors,T),G). +'$check_fn_errors'(T,G) :- !, + '$do_error'(type_error(atom,T),G). + +'$check_fn_solutions'(V,G) :- var(V), !, + '$do_error'(instantiation_error, G). +'$check_fn_solutions'(first,_) :- !. +'$check_fn_solutions'(all,_) :- !. +'$check_fn_solutions'(T,G) :- atom(T), !, + '$do_error'(domain_error(solutions,T),G). +'$check_fn_solutions'(T,G) :- !, + '$do_error'(type_error(atom,T),G). + +'$check_true_false'(V,G) :- var(V), !, + '$do_error'(instantiation_error, G). +'$check_true_false'(true,_) :- !. +'$check_true_false'(false,_) :- !. +'$check_true_false'(T,G) :- atom(T), !, + '$do_error'(domain_error(boolean,T),G). +'$check_true_false'(T,G) :- !, + '$do_error'(type_error(atom,T),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'(commons(D),_,_, _) :- + % make sure library_directory is open. + \+ clause(user:commons_directory(_),_), + '$system_commons_directories'(D), + assert(user:commons_directory(D)), + fail. +'$find_in_path'(S, Opts, NewFile, Call) :- + S =.. [Name,File0], + '$cat_file_name'(File0,File1), !, + '$expand_file_name'(File1, File), + '$dir_separator'(D), + atom_codes(A,[D]), + '$extend_path_directory'(Name, A, File, Opts, NewFile, Call). +'$find_in_path'(File0,Opts,NewFile,_) :- + '$cat_file_name'(File0,File1), !, + '$expand_file_name'(File1, File), + '$add_path'(File,PFile), + '$get_abs_file'(PFile,Opts,AbsFile), + '$search_in_path'(AbsFile,Opts,NewFile). +'$find_in_path'(File,_,_,Call) :- + '$do_error'(domain_error(source_sink,File),Call). + +% allow paths in File Name +'$cat_file_name'(File0,File) :- + atom(File0), !, + File = File0. +'$cat_file_name'(Atoms, File) :- + '$to_list_of_atoms'(Atoms, List, []), + atom_concat(List, File). + +'$to_list_of_atoms'(V, _, _) :- var(V), !, fail. +'$to_list_of_atoms'(Atom, [Atom|L], L) :- atom(Atom), !. +'$to_list_of_atoms'(Atoms, L1, LF) :- + Atoms =.. [A,As,Bs], + atom_codes(A,[D]), + '$dir_separator'(D), + '$to_list_of_atoms'(As, L1, [A|L2]), + '$to_list_of_atoms'(Bs, L2, LF). + +'$get_abs_file'(File,opts(_,RelTo,_,_,_,Expand,_),AbsFile) :- + ( + nonvar(RelTo) + -> + ( is_absolute_file_name(File) -> + ActualFile = File + ; + '$dir_separator'(D), + atom_codes(DA,[D]), + atom_concat([RelTo, DA, File], ActualFile) + ) + ; + ActualFile = File + ), + '$swi_current_prolog_flag'(file_name_variables, OldF), + '$swi_set_prolog_flag'(file_name_variables, Expand), + ( + '$absolute_file_name'(ActualFile,AbsFile) + -> + '$swi_set_prolog_flag'(file_name_variables, OldF) + ; + '$swi_set_prolog_flag'(file_name_variables, OldF), + fail + ). + + +'$search_in_path'(File,opts(Extensions,_,Type,Access,_,_,_),F) :- + '$add_extensions'(Extensions, File, F0), + '$check_file'(F0, Type, Access, F). +'$search_in_path'(File,opts(_,_,Type,Access,_,_,_),F) :- + '$add_type_extensions'(Type, File, F0), + '$check_file'(F0, Type, Access, F). + +'$check_file'(F, _Type, none, F) :- !. +'$check_file'(F0, Type, Access, F0) :- + access_file(F0, Access), + (Type == directory + -> + exists_directory(F0) + ; + true + ). + +'$add_extensions'([Ext|_],File,F) :- + '$mk_sure_true_ext'(Ext,NExt), + atom_concat([File,NExt],F). +'$add_extensions'([_|Extensions],File,F) :- + '$add_extensions'(Extensions,File,F). + +'$mk_sure_true_ext'(Ext,NExt) :- + atom_codes(Ext,[C|L]), + C \= 0'., + !, + atom_codes(NExt,[0'.,C|L]). +'$mk_sure_true_ext'(Ext,Ext). + +'$add_type_extensions'(Type,File,F) :- + ( Type == source -> NType = prolog ; NType = Type ), + user:prolog_file_type(Ext, NType), + atom_concat([File,'.',Ext],F). +'$add_type_extensions'(_,File,File). + +'$add_path'(File,File) :- + '$dir_separator'(D), + atom_codes(DA,[D]), + sub_atom(File, 0, 1, _, DA), !. +'$add_path'(File,File). +'$add_path'(File,PFile) :- + recorded('$path',Path,_), + atom_concat([Path,File],PFile). + +'$system_library_directories'(Dir) :- + getenv('YAPSHAREDIR', Dirs), + '$split_by_sep'(0, 0, Dirs, Dir). +'$system_library_directories'(Dir) :- + getenv('YAPCOMMONSDIR', Dirs), + '$split_by_sep'(0, 0, Dirs, Dir). +'$system_library_directories'(Dir) :- + get_value(system_library_directory,Dir). +'$system_library_directories'(Dir) :- + get_value(prolog_commons_directory,Dir). + + +'$split_by_sep'(Start, Next, Dirs, Dir) :- + '$swi_current_prolog_flag'(windows, true), !, + '$split_by_sep'(Start, Next, Dirs, ';', Dir). +'$split_by_sep'(Start, Next, Dirs, Dir) :- + '$split_by_sep'(Start, Next, Dirs, ':', Dir). + +'$split_by_sep'(Start, Next, Dirs, Sep, Dir) :- + sub_atom(Dirs, Next, 1, _, Let), !, + '$continue_split_by_sep'(Let, Start, Next, Dirs, Sep, Dir). +'$split_by_sep'(Start, Next, Dirs, _Sep, Dir) :- + Next > Start, + Len is Next-Start, + sub_atom(Dirs, Start, Len, _, Dir). + + +% closed a directory +'$continue_split_by_sep'(Sep, Start, Next, Dirs, Sep, Dir) :- + Sz is Next-Start, + Sz > 0, + sub_atom(Dirs, Start, Sz, _, Dir). +% next dir +'$continue_split_by_sep'(Sep , _Start, Next, Dirs, Sep, Dir) :- !, + N1 is Next+1, + '$split_by_sep'(N1, N1, Dirs, Dir). +% same dir +'$continue_split_by_sep'(_Let, Start, Next, Dirs, Sep, Dir) :- + N1 is Next+1, + '$split_by_sep'(Start, N1, Dirs, Sep, Dir). + + +'$extend_path_directory'(_Name, D, File, _Opts, File, Call) :- + is_absolute_file_name(File), !. +'$extend_path_directory'(Name, D, File, Opts, NewFile, Call) :- + user:file_search_path(Name, IDirs), + ( atom(IDirs) -> + '$split_by_sep'(0, 0, IDirs, Dir) + ; + Dir = IDirs + ), + '$extend_pathd'(Dir, D, File, Opts, NewFile, Call). + +'$extend_pathd'(Dir, A, File, Opts, NewFile, Goal) :- + atom(Dir), !, + '$add_file_to_dir'(Dir,A,File,NFile), + '$find_in_path'(NFile, Opts, NewFile, Goal), !. +'$extend_pathd'(Name, A, File, Opts, OFile, Goal) :- + nonvar(Name), + Name =.. [N,P0], + '$add_file_to_dir'(P0,A,File,NFile), + NewName =.. [N,NFile], + '$find_in_path'(NewName, Opts, OFile, Goal). + +'$add_file_to_dir'(P0,A,Atoms,NFile) :- + atom_concat([P0,A,Atoms],NFile). + + diff --git a/pl/consult.yap b/pl/consult.yap index 30fb9ec57..1760b51b3 100755 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -771,315 +771,6 @@ remove_from_path(New) :- '$check_path'(New,Path), '$set_encoding'(Stream, Encoding) :- ( Encoding == default -> true ; set_stream(Stream, encoding(Encoding)) ). -absolute_file_name(V,Out) :- var(V), !, - '$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(source),file_errors(fail),solutions(first),expand(true)],F,G). - -% fix wrong argument order, TrueFileName should be last. -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)). - -'$absolute_file_name'(File, _Opts, _TrueFileName, G) :- var(File), !, - '$do_error'(instantiation_error, G). -'$absolute_file_name'(File,Opts,TrueFileName, G) :- - '$process_fn_opts'(Opts,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G), - /* our own local findall */ - nb:nb_queue(Ref), - ( - '$find_in_path'(File,opts(Extensions,RelTo,Type,Access,FErrors,Expand,Debug),TrueFileName,G), - nb:nb_queue_enqueue(Ref, TrueFileName), - fail - ; - nb:nb_queue_close(Ref, FileNames, []) - ), - '$absolute_file_names'(Solutions, FileNames, FErrors, TrueFileName, File, G). - -'$absolute_file_names'(_Solutions, [], error, _, File, G) :- !, - '$do_error'(existence_error(file,File),G). -'$absolute_file_names'(Solutions, FileNames, _, TrueFileName, _, _) :- - lists:member(TrueFileName, FileNames), - (Solutions == first -> ! ; true). - - -'$process_fn_opts'(V,_,_,_,_,_,_,_,_,G) :- var(V), !, - '$do_error'(instantiation_error, G). -'$process_fn_opts'([],[],_,txt,none,error,first,false,false,_) :- !. -'$process_fn_opts'([Opt|Opts],Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G) :- !, - '$process_fn_opt'(Opt,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions0,RelTo0,Type0,Access0,FErrors0,Solutions0,Expand0,Debug0,G), - '$process_fn_opts'(Opts,Extensions0,RelTo0,Type0,Access0,FErrors0,Solutions0,Expand0,Debug0,G). -'$process_fn_opts'(Opts,_Extensions,_RelTo,_Type,_Access,_FErrors,_Solutions,_Expand,_Debug,G) :- !, - '$do_error'(type_error(list,Opts),G). - -'$process_fn_opt'(Opt,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G) :- var(Opt), !, - '$do_error'(instantiation_error, G). -'$process_fn_opt'(extensions(Extensions),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,_,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G) :- !, - '$check_fn_extensions'(Extensions,G). -'$process_fn_opt'(relative_to(RelTo),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,_,Type,Access,FErrors,Solutions,Expand,Debug,G) :- !, - '$check_atom'(RelTo,G). -'$process_fn_opt'(access(Access),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,_,FErrors,Solutions,Expand,Debug,G) :- !, - '$check_atom'(Access,G). -'$process_fn_opt'(file_type(Type),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,_,Access,FErrors,Solutions,Expand,Debug,G) :- !, - '$check_fn_type'(Type,G). -'$process_fn_opt'(file_errors(FErrors),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,_,Solutions,Expand,Debug,G) :- !, - '$check_fn_errors'(FErrors,G). -'$process_fn_opt'(solutions(Solutions),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,_,Expand,Debug,G) :- !, - '$check_fn_solutions'(Solutions,G). -'$process_fn_opt'(expand(Expand),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,Solutions,_,Debug,G) :- !, - '$check_true_false'(Expand,G). -'$process_fn_opt'(verbose_file_search(Debug),Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,_,G) :- !, - '$check_true_false'(Debug,G). -'$process_fn_opt'(Opt,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,Extensions,RelTo,Type,Access,FErrors,Solutions,Expand,Debug,G) :- !, - '$do_error'(domain_error(file_name_option,Opt),G). - -'$check_fn_extensions'(V,G) :- var(V), !, - '$do_error'(instantiation_error, G). -'$check_fn_extensions'([],_) :- !. -'$check_fn_extensions'([A|L],G) :- !, - '$check_atom'(A,G), - '$check_fn_extensions'(L,G). -'$check_fn_extensions'(T,G) :- !, - '$do_error'(type_error(list,T),G). - -'$check_atom'(V,G) :- var(V), !, - '$do_error'(instantiation_error, G). -'$check_atom'(A,_G) :- atom(A), !. -'$check_atom'(T,G) :- !, - '$do_error'(type_error(atom,T),G). - -'$check_fn_type'(V,G) :- var(V), !, - '$do_error'(instantiation_error, G). -'$check_fn_type'(txt,_) :- !. -'$check_fn_type'(prolog,_) :- !. -'$check_fn_type'(source,_) :- !. -'$check_fn_type'(executable,_) :- !. -'$check_fn_type'(qlf,_) :- !. -'$check_fn_type'(directory,_) :- !. -'$check_fn_type'(T,G) :- atom(T), !, - '$do_error'(domain_error(file_type,T),G). -'$check_fn_type'(T,G) :- !, - '$do_error'(type_error(atom,T),G). - -'$check_fn_errors'(V,G) :- var(V), !, - '$do_error'(instantiation_error, G). -'$check_fn_errors'(fail,_) :- !. -'$check_fn_errors'(error,_) :- !. -'$check_fn_errors'(T,G) :- atom(T), !, - '$do_error'(domain_error(file_errors,T),G). -'$check_fn_errors'(T,G) :- !, - '$do_error'(type_error(atom,T),G). - -'$check_fn_solutions'(V,G) :- var(V), !, - '$do_error'(instantiation_error, G). -'$check_fn_solutions'(first,_) :- !. -'$check_fn_solutions'(all,_) :- !. -'$check_fn_solutions'(T,G) :- atom(T), !, - '$do_error'(domain_error(solutions,T),G). -'$check_fn_solutions'(T,G) :- !, - '$do_error'(type_error(atom,T),G). - -'$check_true_false'(V,G) :- var(V), !, - '$do_error'(instantiation_error, G). -'$check_true_false'(true,_) :- !. -'$check_true_false'(false,_) :- !. -'$check_true_false'(T,G) :- atom(T), !, - '$do_error'(domain_error(boolean,T),G). -'$check_true_false'(T,G) :- !, - '$do_error'(type_error(atom,T),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'(commons(D),_,_, _) :- - % make sure library_directory is open. - \+ clause(user:commons_directory(_),_), - '$system_commons_directories'(D), - assert(user:commons_directory(D)), - fail. -'$find_in_path'(S, Opts, NewFile, Call) :- - S =.. [Name,File0], - '$cat_file_name'(File0,File1), !, - '$expand_file_name'(File1, File), - '$dir_separator'(D), - atom_codes(A,[D]), - '$extend_path_directory'(Name, A, File, Opts, NewFile, Call). -'$find_in_path'(File0,Opts,NewFile,_) :- - '$cat_file_name'(File0,File1), !, - '$expand_file_name'(File1, File), - '$add_path'(File,PFile), - '$get_abs_file'(PFile,Opts,AbsFile), - '$search_in_path'(AbsFile,Opts,NewFile). -'$find_in_path'(File,_,_,Call) :- - '$do_error'(domain_error(source_sink,File),Call). - -% allow paths in File Name -'$cat_file_name'(File0,File) :- - atom(File0), !, - File = File0. -'$cat_file_name'(Atoms, File) :- - '$to_list_of_atoms'(Atoms, List, []), - atom_concat(List, File). - -'$to_list_of_atoms'(V, _, _) :- var(V), !, fail. -'$to_list_of_atoms'(Atom, [Atom|L], L) :- atom(Atom), !. -'$to_list_of_atoms'(Atoms, L1, LF) :- - Atoms =.. [A,As,Bs], - atom_codes(A,[D]), - '$dir_separator'(D), - '$to_list_of_atoms'(As, L1, [A|L2]), - '$to_list_of_atoms'(Bs, L2, LF). - -'$get_abs_file'(File,opts(_,RelTo,_,_,_,Expand,_),AbsFile) :- - ( - nonvar(RelTo) - -> - ( is_absolute_file_name(File) -> - ActualFile = File - ; - '$dir_separator'(D), - atom_codes(DA,[D]), - atom_concat([RelTo, DA, File], ActualFile) - ) - ; - ActualFile = File - ), - '$swi_current_prolog_flag'(file_name_variables, OldF), - '$swi_set_prolog_flag'(file_name_variables, Expand), - ( - '$absolute_file_name'(ActualFile,AbsFile) - -> - '$swi_set_prolog_flag'(file_name_variables, OldF) - ; - '$swi_set_prolog_flag'(file_name_variables, OldF), - fail - ). - - -'$search_in_path'(File,opts(Extensions,_,Type,Access,_,_,_),F) :- - '$add_extensions'(Extensions, File, F0), - '$check_file'(F0, Type, Access, F). -'$search_in_path'(File,opts(_,_,Type,Access,_,_,_),F) :- - '$add_type_extensions'(Type, File, F0), - '$check_file'(F0, Type, Access, F). - -'$check_file'(F, _Type, none, F) :- !. -'$check_file'(F0, Type, Access, F0) :- - access_file(F0, Access), - (Type == directory - -> - exists_directory(F0) - ; - true - ). - -'$add_extensions'([Ext|_],File,F) :- - '$mk_sure_true_ext'(Ext,NExt), - atom_concat([File,NExt],F). -'$add_extensions'([_|Extensions],File,F) :- - '$add_extensions'(Extensions,File,F). - -'$mk_sure_true_ext'(Ext,NExt) :- - atom_codes(Ext,[C|L]), - C \= 0'., - !, - atom_codes(NExt,[0'.,C|L]). -'$mk_sure_true_ext'(Ext,Ext). - -'$add_type_extensions'(Type,File,F) :- - ( Type == source -> NType = prolog ; NType = Type ), - user:prolog_file_type(Ext, NType), - atom_concat([File,'.',Ext],F). -'$add_type_extensions'(_,File,File). - -'$add_path'(File,File) :- - '$dir_separator'(D), - atom_codes(DA,[D]), - sub_atom(File, 0, 1, _, DA), !. -'$add_path'(File,File). -'$add_path'(File,PFile) :- - recorded('$path',Path,_), - atom_concat([Path,File],PFile). - -'$system_library_directories'(Dir) :- - getenv('YAPSHAREDIR', Dirs), - '$split_by_sep'(0, 0, Dirs, Dir). -'$system_library_directories'(Dir) :- - getenv('YAPCOMMONSDIR', Dirs), - '$split_by_sep'(0, 0, Dirs, Dir). -'$system_library_directories'(Dir) :- - get_value(system_library_directory,Dir). -'$system_library_directories'(Dir) :- - get_value(prolog_commons_directory,Dir). - - -'$split_by_sep'(Start, Next, Dirs, Dir) :- - '$swi_current_prolog_flag'(windows, true), !, - '$split_by_sep'(Start, Next, Dirs, ';', Dir). -'$split_by_sep'(Start, Next, Dirs, Dir) :- - '$split_by_sep'(Start, Next, Dirs, ':', Dir). - -'$split_by_sep'(Start, Next, Dirs, Sep, Dir) :- - sub_atom(Dirs, Next, 1, _, Let), !, - '$continue_split_by_sep'(Let, Start, Next, Dirs, Sep, Dir). -'$split_by_sep'(Start, Next, Dirs, _Sep, Dir) :- - Next > Start, - Len is Next-Start, - sub_atom(Dirs, Start, Len, _, Dir). - - -% closed a directory -'$continue_split_by_sep'(Sep, Start, Next, Dirs, Sep, Dir) :- - Sz is Next-Start, - Sz > 0, - sub_atom(Dirs, Start, Sz, _, Dir). -% next dir -'$continue_split_by_sep'(Sep , _Start, Next, Dirs, Sep, Dir) :- !, - N1 is Next+1, - '$split_by_sep'(N1, N1, Dirs, Dir). -% same dir -'$continue_split_by_sep'(_Let, Start, Next, Dirs, Sep, Dir) :- - N1 is Next+1, - '$split_by_sep'(Start, N1, Dirs, Sep, Dir). - - -'$extend_path_directory'(_Name, D, File, _Opts, File, Call) :- - is_absolute_file_name(File), !. -'$extend_path_directory'(Name, D, File, Opts, NewFile, Call) :- - user:file_search_path(Name, IDirs), - ( atom(IDirs) -> - '$split_by_sep'(0, 0, IDirs, Dir) - ; - Dir = IDirs - ), - '$extend_pathd'(Dir, D, File, Opts, NewFile, Call). - -'$extend_pathd'(Dir, A, File, Opts, NewFile, Goal) :- - atom(Dir), !, - '$add_file_to_dir'(Dir,A,File,NFile), - '$find_in_path'(NFile, Opts, NewFile, Goal), !. -'$extend_pathd'(Name, A, File, Opts, OFile, Goal) :- - nonvar(Name), - Name =.. [N,P0], - '$add_file_to_dir'(P0,A,File,NFile), - NewName =.. [N,NFile], - '$find_in_path'(NewName, Opts, OFile, Goal). - -'$add_file_to_dir'(P0,A,Atoms,NFile) :- - atom_concat([P0,A,Atoms],NFile). - - % % This is complicated because of embedded ifs. % diff --git a/pl/init.yap b/pl/init.yap index 8fdcd49a7..9fd88dbfd 100755 --- a/pl/init.yap +++ b/pl/init.yap @@ -67,6 +67,7 @@ otherwise. :- bootstrap('errors.yap'). :- bootstrap('lists.yap'). :- bootstrap('consult.yap'). +:- bootstrap('absf.yap'). :- [ 'utils.yap', 'control.yap',