diff --git a/C/iopreds.c b/C/iopreds.c index d6644b17f..5e90736a8 100644 --- a/C/iopreds.c +++ b/C/iopreds.c @@ -51,6 +51,14 @@ static char SccsId[] = "%W% %G%"; #if HAVE_STRING_H #include #endif +#if HAVE_FCNTL_H +/* for O_BINARY and O_TEXT in WIN32 */ +#include +#endif +#if HAVE_IO_H +/* Windows */ +#include +#endif #if !HAVE_STRNCAT #define strncat(X,Y,Z) strcat(X,Y) #endif @@ -1676,9 +1684,14 @@ p_open_pipe_stream (void) int sno; int filedes[2]; - if (pipe(filedes) != 0) { - return (PlIOError (SYSTEM_ERROR,TermNil, "open_pipe_stream/2 could not create pipe")); - } +#if _MSC_VER || defined(__MINGW32__) + if (_pipe(filedes, 256, O_TEXT) == -1) +#else + if (pipe(filedes) != 0) +#endif + { + return (PlIOError (SYSTEM_ERROR,TermNil, "open_pipe_stream/2 could not create pipe")); + } for (sno = 0; sno < MaxStreams; ++sno) if (Stream[sno].status & Free_Stream_f) break; diff --git a/C/save.c b/C/save.c index 81d26a0f6..93c459dc6 100644 --- a/C/save.c +++ b/C/save.c @@ -39,6 +39,12 @@ static char SccsId[] = "@(#)save.c 1.3 3/15/90"; #ifdef HAVE_UNISTD_H #include #endif +#ifdef HAVE_SYS_TYPES_H +#include +#endif +#ifdef HAVE_SYS_STAT_H +#include +#endif /********* hack for accesing several kinds of terms. Should be cleaned **/ @@ -124,9 +130,7 @@ STATIC_PROTO(void NewFileInfo, (long, long)); extern int DefVol; #endif -#if _MSC_VER -#include -#include +#if HAVE_IO_H #include #endif @@ -254,7 +258,7 @@ open_file(char *ss, int flag) #else #ifdef O_BINARY #if _MSC_VER - if ((splfild = open(ss, flag | O_BINARY), _S_IREAD | _S_IWRITE) < 0) + if ((splfild = _open(ss, flag | O_BINARY), _S_IREAD | _S_IWRITE) < 0) #else if ((splfild = open(ss, flag | O_BINARY), 0755) < 0) #endif diff --git a/C/stdpreds.c b/C/stdpreds.c index 2aa39617e..3ebb8adfb 100644 --- a/C/stdpreds.c +++ b/C/stdpreds.c @@ -2012,6 +2012,20 @@ mk_argc_list(void) Term t = TermNil; while (i < yap_argc) { char *arg = yap_args[i]; + /* check for -L -- */ + if (arg[0] == '-' && arg[1] == 'L') { + arg += 2; + while (*arg != '\0' && (*arg == ' ' || *arg == '\t')) + arg++; + if (*arg == '-' && arg[1] == '-' && arg[2] == '\0') { + /* we found the separator */ + int j; + for (j = yap_argc-1; j > i+1; --j) { + t = MkPairTerm(MkAtomTerm(LookupAtom(yap_args[j])),t); + } + return(t); + } + } if (arg[0] == '-' && arg[1] == '-' && arg[2] == '\0') { /* we found the separator */ int j; @@ -2173,6 +2187,13 @@ p_set_yap_flags(void) return(TRUE); } +#ifndef YAPOR +static Int +p_default_sequential(void) { + return(TRUE); +} +#endif + #ifdef DEBUG extern void DumpActiveGoals(void); @@ -2257,7 +2278,9 @@ InitCPreds(void) InitCPred("unhide", 1, p_unhide, SafePredFlag|SyncPredFlag); InitCPred("$hidden", 1, p_hidden, SafePredFlag|SyncPredFlag); InitCPred("$has_yap_or", 0, p_has_yap_or, SafePredFlag|SyncPredFlag); - InitCPred("$has_tabling", 0, p_has_tabling, SafePredFlag|SyncPredFlag); +#ifndef YAPOR + InitCPred("$default_sequential", 1, p_default_sequential, SafePredFlag|SyncPredFlag); +#endif #ifdef DEBUG InitCPred("dump_active_goals", 0, p_dump_active_goals, SafePredFlag|SyncPredFlag); #endif diff --git a/C/ypsocks.c b/C/ypsocks.c index e322761a9..32bb96610 100644 --- a/C/ypsocks.c +++ b/C/ypsocks.c @@ -36,6 +36,9 @@ #if HAVE_SYS_TIME_H && !HAVE_WINSOCK2_H && !_MSC_VER #include #endif +#if HAVE_IO_H +#include +#endif #if HAVE_WINSOCK2_H #include #ifdef HAVE_SYS_UN_H @@ -239,7 +242,7 @@ void init_socks(char *host, long interface_port) crash("[ could not connect to interface]"); } /* now reopen stdin stdout and stderr */ -#if HAVE_DUP2 +#if HAVE_DUP2 && !defined(__MINGW32__) if(dup2(s,0)<0) { YP_fprintf(YP_stderr,"could not dup2 stdin\n"); return; @@ -252,7 +255,7 @@ void init_socks(char *host, long interface_port) YP_fprintf(YP_stderr,"could not dup2 stderr\n"); return; } -#elif _MSC_VER +#elif _MSC_VER || defined(__MINGW32__) if(_dup2(s,0)<0) { YP_fprintf(YP_stderr,"could not dup2 stdin\n"); return; @@ -286,7 +289,11 @@ void init_socks(char *host, long interface_port) yp_iob[2].flags = _YP_IO_SOCK | _YP_IO_WRITE; #endif YP_sockets_io = 1; +#if _MSC_VER || defined(__MINGW32__) + _close(s); +#else close(s); +#endif } static Int @@ -436,7 +443,11 @@ p_socket(void) out = InitSocketStream(fd, new_socket, af_inet); else { /* ok, we currently don't support these sockets */ +#if _MSC_VER || defined(__MINGW32__) + _close(fd); +#else close(fd); +#endif return(FALSE); } return(unify(out,ARG4)); diff --git a/OPTYap/opt.preds.c b/OPTYap/opt.preds.c index 1db48119f..55d828140 100644 --- a/OPTYap/opt.preds.c +++ b/OPTYap/opt.preds.c @@ -68,11 +68,11 @@ static int p_debug_prolog(void); ** -------------------------- */ void init_optyap_preds(void) { + InitCPred("$default_sequential", 1, p_default_sequential, SafePredFlag); #ifdef YAPOR InitCPred("$yapor_on", 0, yapor_on, SafePredFlag); InitCPred("$start_yapor", 0, start_yapor, SafePredFlag); InitCPred("$sequential", 1, p_sequential, SafePredFlag); - InitCPred("$default_sequential", 1, p_default_sequential, SafePredFlag); InitCPred("execution_mode", 1, p_execution_mode, SafePredFlag); InitCPred("performance", 1, p_performance, SafePredFlag); InitCPred("$parallel_new_answer", 1, p_parallel_new_answer, SafePredFlag); diff --git a/TO_DO b/TO_DO index 5f23d5d2b..58c235897 100644 --- a/TO_DO +++ b/TO_DO @@ -1,5 +1,5 @@ BEFORE 4.4: -- weird going ons with prompt +- weird going ons with prompt and readline - mixed constraints and delays. - write infinite terms - constraints in DB. @@ -13,6 +13,7 @@ BEFORE 4.4: - library(system) for WIN32 - document system(library) - document new interface functions. +- remove pl/nfr.yap and misc/yap.spec from CVS. TO CHECK: - bad register allocation for a(X,Y) :- X is Y+2.3 ? @@ -70,3 +71,4 @@ DONE: - initial port to OS_X - listing (Steve Moyle). - logtalk. +- fix bugs from Nicos. diff --git a/changes4.3.html b/changes4.3.html index 16af2dd3f..3c1bb4e11 100644 --- a/changes4.3.html +++ b/changes4.3.html @@ -16,19 +16,38 @@

Yap-4.3.19:

    -
  • NEW: library(system), only for Unix system right now.. -
  • FIXED: allow current_stream/3 to work with third argument known. +
  • FIXED: make yap modules more compatible with SICStus Prolog
    • +
  • NEW: portray_clause/2 (request from Nicos Angelopoulos)
    • +
  • FIXED: document absolute_file_name/2
    • +
  • FIXED: absolute_file_name/2 should return absolute path, + never user name! (bug report from Nicos Angelopoulos)
    • +
  • FIXED: in a:-b:call(X) X belongs to the module b (bug + report from Nicos Angelopoulos)
    • +
  • FIXED: make consult/1 and friends meta-predicates (bug + report from Nicos Angelopoulos)
    • +
  • FIXED: allow [M:F] and friends (bug report from + Nicos Angelopoulos)
    • +
  • FIXED: ensure_loaded/1 can be used as a goal (bug report + from Nicos Angelopoulos)
    • +
  • FIXED: abolish(VAR) should abolish all predicates in + current module (bug report from Nicos Angelopoulos).
    • +
  • NEW: library(system), only for Unix system right now.
    • +
  • FIXED: allow current_stream/3 to work with third argument + known.
  • FIXED: always leave enough space so that the hybrid garbage - collection may work. -
  • FIXED: add_to_path should not leave choice-points. + collection may work.
    • +
  • FIXED: add_to_path should not leave choice-points.
  • FIXED: don't initialise first occurrences in branches for - func outputs. -
  • FIXED: handle void variables in body. + func outputs.
    • +
  • FIXED: handle void variables in body.
  • NEW: externd C-interface with StreamToFileNo, - BufferToString, and BufferToAtomList. -
  • NEW: support pipes with open_pipe_stream/2. -
  • FIXED: functor/3 was generating too many deallocates at the end of a clause.
    • -
  • FIXED: call_residue/2 should not allow constraints to escape (use copy_term_no_variables/2 to avoid this).
    • + BufferToString, and BufferToAtomList. +
  • NEW: support pipes with open_pipe_stream/2.
    • +
  • FIXED: functor/3 was generating too many + deallocates at the end of a clause.
    • +
  • FIXED: call_residue/2 should not allow + constraints to escape (use + copy_term_no_variables/2 to avoid this).
  • SPEEDUP: optimise away true/0 at the end of a clause.
  • FIXED: do not short circuit trail entries.
  • FIXED: Patches for memory allocation in Apple's OS/X.
    • @@ -39,8 +58,10 @@
  • FIXED: force line buffering for text stream.
  • FIXED: force no buffering for user_error.
  • FIXED: flush all streams before writing answer.
    • -
  • FIXED: YP_std* are now streams, so that yap_flag(user_*) will change them too.
    • -
  • FIXED: nth/3 and nth0/3 would leave one extra choice-point.
    • +
  • FIXED: YP_std* are now streams, so that + yap_flag(user_*) will change them too.
    • +
  • FIXED: nth/3 and nth0/3 would + leave one extra choice-point.
  • FIXED: use Contents instead of Uses to determine live variables.
  • FIXED: cputime was actually walltime in WIN32, ugh (report from Steve Moyle).
  • FIXED: regexp library would not compile on recent versions of cygwin.
    • diff --git a/config.h.in b/config.h.in index c7055cce2..649b24f39 100644 --- a/config.h.in +++ b/config.h.in @@ -33,6 +33,7 @@ #undef HAVE_FPU_CONTROL_H #undef HAVE_GMP_H #undef HAVE_IEEEFP_H +#undef HAVE_IO_H #undef HAVE_LIMITS_H #undef HAVE_MEMORY_H #undef HAVE_NETDB_H diff --git a/configure b/configure index 7ec4b9aee..96cc6b10d 100755 --- a/configure +++ b/configure @@ -2461,7 +2461,7 @@ else fi done -for ac_hdr in sys/select.h direct.h dirent.h signal.h +for ac_hdr in sys/select.h direct.h dirent.h signal.h io.h do ac_safe=`echo "$ac_hdr" | sed 'y%./+-%__p_%'` echo $ac_n "checking for $ac_hdr""... $ac_c" 1>&6 diff --git a/configure.in b/configure.in index f019bb4fb..a686fbd79 100644 --- a/configure.in +++ b/configure.in @@ -395,7 +395,7 @@ AC_CHECK_HEADERS(sys/param.h errno.h netdb.h netinet/in.h arpa/inet.h) AC_CHECK_HEADERS(string.h memory.h sys/mman.h sys/stat.h stdarg.h ctype.h) AC_CHECK_HEADERS(sys/resource.h limits.h siginfo.h time.h fenv.h) AC_CHECK_HEADERS(fpu_control.h sys/shm.h regex.h winsock.h winsock2.h) -AC_CHECK_HEADERS(sys/select.h direct.h dirent.h signal.h) +AC_CHECK_HEADERS(sys/select.h direct.h dirent.h signal.h io.h) if test "$yap_cv_gmp" != "no" then AC_CHECK_HEADERS(gmp.h) diff --git a/console/yap.c b/console/yap.c index f9bd11528..0a3f21244 100644 --- a/console/yap.c +++ b/console/yap.c @@ -327,8 +327,25 @@ parse_yap_arguments(int argc, char *argv[], yap_init_args *init_args) output_msg = TRUE; break; #endif - case 'l': case 'L': + p++; + while (*p != '\0' && (*p == ' ' || *p == '\t')) + p++; + /* skip zeroth argument */ + argc--; + if (argc == 0) { + fprintf(stderr," [ YAP unrecoverable error: missing file name with option 'l' ]\n"); + exit(1); + } + argv++; + if (p[0] == '-' && p[1] == '-'&& p[2] == '\0') { + /* we're done here */ + argc = 1; + } + init_args->YapPrologBootFile = *argv; + init_args->HaltAfterConsult = TRUE; + break; + case 'l': if ((*argv)[0] == '\0') init_args->YapPrologBootFile = *argv; else { @@ -340,8 +357,6 @@ parse_yap_arguments(int argc, char *argv[], yap_init_args *init_args) argv++; init_args->YapPrologBootFile = *argv; } - if (p[0] == 'L') - init_args->HaltAfterConsult = TRUE; break; case '-': /* skip remaining arguments */ diff --git a/docs/yap.tex b/docs/yap.tex index bb2797063..46d9f3f88 100644 --- a/docs/yap.tex +++ b/docs/yap.tex @@ -885,7 +885,7 @@ Unix-like environments. A simple example is shown next: @example @cartouche -#!/usr/local/bin/yap -L $0 "$@" +#!/usr/local/bin/yap -L # # Hello World script file using Yap # @@ -898,16 +898,16 @@ Unix-like environments. A simple example is shown next: The @code{#!} characters specify that the script should call the binary file Yap. Notice that many systems will require the complete path to the Yap binary. The @code{-L} flag indicates that YAP should consult the -file "$0" at booting and then halt. The remaining arguments are then -passed to YAP. Note that YAP will skip the first lines if they start -with @code{#} (the comment sign for Unix's shell). YAP will consult the -file and execute any commands. +current file when booting and then halt. The remaining arguments are +then passed to YAP. Note that YAP will skip the first lines if they +start with @code{#} (the comment sign for Unix's shell). YAP will +consult the file and execute any commands. A slightly more sophisticated example is: @example @cartouche -#!/usr/bin/yap -L $0 "$@" +#!/usr/bin/yap -L # # Hello World script file using Yap # @@ -923,6 +923,58 @@ The @code{initialization} directive tells Yap to execute the goal main after consulting the file. Source code is thus compiled and @code{main} executed at the end. +By default, arguments to a script are considered arguments to YAP. As an +example, consider the following script @code{dump_args}: + +@example +@cartouche +#!/usr/bin/yap -L + +main( [] ). +main( [H|T] ) :- + write( H ), nl, + main( T ). + +:- unix( argv(AllArgs) ), main( AllArgs ). + +@end cartouche +@end example + +If you this run this script with the arguments: +@example +./dump_args -s 10000 +@end example +@noindent +the script will start an YAP process with stack size @code{10MB}, and +the list of arguments to the process will be empty. + +Often one wants to run the script as any other program, and for this it +is convenient to ignore arguments to YAP. This is possible by using +@code{L --} as in the next version of @code{dump_args}: + +@example +@cartouche +#!/usr/bin/yap -L -- + +main( [] ). +main( [H|T] ) :- + write( H ), nl, + main( T ). + +:- unix( argv(AllArgs) ), main( AllArgs ). + +@end cartouche +@end example + +The @code{--} indicates the next arguments are not for YAP. Instead, +they must be sent directly to the @code{argv} builtin. Hence, running +@example +./dump_args test +@end example +@noindent +will write @code{test} on the standard output. + + @node Syntax, Loading Programs, Run, Top @chapter Syntax @@ -1547,6 +1599,13 @@ directories are the places where files specified in the form @code{consult/1}, @code{reconsult/1}, @code{use_module/1} or @code{ensure_loaded/1}. +@item prolog_file_name(+@var{Name},-@var{FullPath}) +@findex prolog_file_name/2 +@syindex prolog_file_name/1 +@cnindex prolog_file_name/2 +Unify @var{FullPath} with the absolute path YAP would use to consult +file @var{Name}. + @item public @var{P} [ISO] @findex public/1 (directive) @snindex public/1 (directive) @@ -4510,11 +4569,13 @@ support may go away in future versions. @findex abolish/1 @saindex abolish/1 @caindex abolish/1 - Deletes the predicate given by @var{PredSpec} from the database. The + Deletes the predicate given by @var{PredSpec} from the database. If +@var{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 @t{iso} language mode this builtin will only abolish dynamic procedures. Under other modes it will abolish any procedures, as -long as they are not currently in use. +long as they are not currently in use. @item abolish(+@var{P},+@var{N}) @findex abolish/2 @@ -4609,7 +4670,13 @@ Lists predicate @var{P} if its source code is available. @findex portray_clause/1 @syindex portray_clause/1 @cnindex portray_clause/1 -Write clause @var{C} as if written by listing. +Write clause @var{C} as if written by @code{listing/0}. + +@item portray_clause(+@var{S},+@var{C}) +@findex portray_clause/2 +@syindex portray_clause/2 +@cnindex portray_clause/2 +Write clause @var{C} on stream @var{S} as if written by @code{listing/0}. @item current_atom(@var{A}) @findex current_atom/1 @@ -7233,6 +7300,159 @@ YAP does not currently support opening a @code{charsio} stream in @section Calling The Operating System from YAP @cindex Operating System Utilities +Yap now provides a library of system utilities compatible with the +SICStus Prolog system library. This library extends and to some point +replaces the functionality of Operating System access routines. The +library includes Unix/Linux and Win32 @code{C} code. They +are available through the @code{use_module(library(system))} command. + +@table @code + +@item datime(datime(-@var{Year}, -@var{Month}, -@var{DayOfTheMonth}, +-@var{Hour}, -@var{Minute}, -@var{Second}) +@findex datime/1 +@syindex datime/1 +@cnindex datime/1 +The @code{datime/1} procedure returns the current date and time, with +information on @var{Year}, @var{Month}, @var{DayOfTheMonth}, +@var{Hour}, @var{Minute}, and @var{Second}. The @var{Hour} is returned +on local time. This function uses the WIN32 +@code{GetLocalTime} function or the Unix @code{localtime} function. + +@example + ?- datime(X). + +X = datime(2001,5,28,15,29,46) ? +@end example + +@item delete_file(+@var{File}) +@findex delete_file/1 +@syindex delete_file/1 +@cnindex delete_file/1 +The @code{delete_file/1} procedure removes file @var{File}. If +@var{File} is a directory, remove the directory @emph{and all its +subdirectories}. + +@example + ?- delete_file(x). +@end example + +@item delete_file(+@var{File},+@var{Opts}) +@findex delete_file/2 +@syindex delete_file/2 +@cnindex delete_file/2 +The @code{delete_file/2} procedure removes file @var{File} according to +options @var{Opts}. These options are @code{directory} if one should +remove directories, @code{recursive} if one should remove directories +recursively, and @code{ignore} if errors are not to be reported. + +This example is equivalent to using the @code{delete_file/1} predicate: +@example + ?- delete_file(x, [recursive]). +@end example + + +@item directory_files(+@var{Dir},+@var{List}) +@findex directory_files/2 +@syindex directory_files/2 +@cnindex directory_files/2 +Given a directory @var{Dir}, @code{directory_files/2} procedures a +listing of all files and directories in the directory: +@example + ?- directory_files('.',L), writeq(L). +['Makefile.~1~','sys.so','Makefile','sys.o',x,..,'.'] +@end example +The predicates uses the @code{dirent} family of routines in Unix +environments, and @code{findfirst} in WIN32. + +@item file_exists(+@var{File}) +@findex file_exists/1 +@syindex file_exists/1 +@cnindex file_exists/1 +The atom @var{File} corresponds to an existing file. + +@item file_exists(+@var{File},+@var{Permissions}) +@findex file_exists/2 +@syindex file_exists/2 +@cnindex file_exists/2 +The atom @var{File} corresponds to an existing file with permissions +compatible with @var{Permissions}. YAP currently only accepts for +permissions to be described as a number. The actual meaning of this +number is Operating System dependent. + +@item file_property(+@var{File},?@var{Property}) +@findex file_property/2 +@syindex file_property/2 +@cnindex file_property/2 +The atom @var{File} corresponds to an existing file, and @var{Property} +will be unified with a property of this file. The poperties are of the +form @code{type(@var{Type))}, which gives whether the file is a regular +file, a directory, a fifo file, or of unknown type; +@code{size(@var{Size))}, with gives the size for a file, and +@code{mod_time(@var{Time))}, which gives the last time a file was +modified according to some Operating System dependent +timestamp. Properties can be obtained through backtracking: + +@example + ?- file_property('Makefile',P). + +P = type(regular) ? ; + +P = size(2375) ? ; + +P = mod_time(990826911) ? ; + +no +@end example + +@item make_directory(+@var{Dir}) +@findex make_directory/2 +@syindex make_directory/2 +@cnindex make_directory/2 +Create a directory @var{Dir}. The name of the directory must be an atom. + +@item rename_file(+@var{OldFile},+@var{NewFile}) +@findex rename_file/2 +@syindex rename_file/2 +@cnindex rename_file/2 +Create file @var{OldFile} to @var{NewFile}. This predicate uses the +@code{C} builtin function @code{rename}. + + +@item environ(?@var{EnvVar},+@var{EnvValue}) +@findex environ/2 +@syindex environ/2 +@cnindex environ/2 +Unify environment variable @var{EnvVar} with its value @var{EnvValue}, +if there is one. This predicate is backtrackable in Unix systems, but +not currently in Win32 configurations. + +@example + ?- environ('HOME',X). + +X = 'C:\\cygwin\\home\\administrator' ? +@end example + +@item +exec(+@var{Command},[+@var{InputStream},+@var{OutputStream},,+@var{ErrorStream}, +-@var{Status}) +@findex exec/3 +@syindex exec/3 +@cnindex exec/3 +Execute command @var{Command} with its streams connected to +@var{InputStream}, @var{OutputStream}, and @var{ErrorStream}. The result +for the command is returned in @var{Status}. + +@item working_directory(-@var{CurDir},?@var{NextDir}) +@findex working_directory/2 +@syindex working_directory/2 +@cnindex working_directory/2 +Fetch the current directory at @var{CurDir}. If @var{NextDir} is bound +to an atom, make its value the current working directory. + +@end table + + @node Terms, Timeout, System, Library @section Utilities On Terms @cindex utilities on terms @@ -12520,7 +12740,8 @@ compatible built-in. implemented in YAP (note that this is only a partial list): @code{call_cleanup/1}, @code{file_search_path/2}, @code{stream_interrupt/3}, @code{reinitialize/0}, @code{help/0}, -@code{help/1}, @code{module/3}, @code{trimcore/0}. +@code{help/1}, @code{trimcore/0}, @code{load_files/1}, +@code{load_files/2}, and @code{require/1}. The previous list is incomplete. We also cannot guarantee full compatibility for other built-ins (although we will try to address any diff --git a/library/system.yap b/library/system.yap index 73d179de3..7ab15fe8e 100644 --- a/library/system.yap +++ b/library/system.yap @@ -275,12 +275,48 @@ check_mode(write,1, _) :- !. check_mode(Mode, G) :- throw(domain_error(io_mode,Mode),G). +shell :- + G = shell, + get_shell(Shell), + atom_codes(FullCommand, Shell), + exec_command(FullCommand, '$stream'(0),'$stream'(0), '$stream'(1), PID, Error), + handle_system_error(Error, off, G), + wait(PID, _Status, Error), + handle_system_error(Error, off, G). + +shell(Command) :- + G = shell(Command), + check_command(Command, G), + get_shell(Shell), + atom_codes(Command, SC), + append(Shell, SC, ShellCommand), + atom_codes(FullCommand, ShellCommand), + exec_command(FullCommand, '$stream'(0),'$stream'(0), '$stream'(1), PID, Error), + handle_system_error(Error, off, G), + wait(PID, _Status, Error), + handle_system_error(Error, off, G). + shell(Command, Status) :- G = shell(Command, Status), check_command(Command, G), - do_shell(Status, Error), - ( var(Error) -> Status = 0 ; Status = Error). + get_shell(Shell), + atom_codes(Command, SC), + append(Shell, SC, ShellCommand), + atom_codes(FullCommand, ShellCommand), + exec_command(FullCommand, '$stream'(0),'$stream'(0), '$stream'(1), PID, Error), + handle_system_error(Error, off, G), + wait(PID, Status,Error), + handle_system_error(Error, off, G). +get_shell(Shell) :- + getenv('SHELL', Shell0), !, + atom_codes(Shell0, Codes), + append(Codes," -c ", Shell). +get_shell(COMSPEC) :- + getenv('COMPSEC', Shell), + atom_codes(Shell0, Codes), + append(Codes," /c ", Shell). + system(Command, Status) :- G = system(Command, Status), check_command(Command, G), diff --git a/library/system/Makefile.in b/library/system/Makefile.in index 7d310e3b4..813ec6ada 100644 --- a/library/system/Makefile.in +++ b/library/system/Makefile.in @@ -64,7 +64,7 @@ sys.so: sys.o # DLLTOOL=dlltool DLLNAME=sys.dll -DLL_LIBS=-lcrtdll -L../.. -lWYap +DLL_LIBS=-L /usr/lib/mingw -lmoldname -lcrtdll -lkernel32 -L../.. -lWYap BASE_FILE=sys.base EXP_FILE=sys.exp DEF_FILE=$(srcdir)/sys.def diff --git a/library/system/sys.c b/library/system/sys.c index 4037e7b27..787a8ca19 100644 --- a/library/system/sys.c +++ b/library/system/sys.c @@ -54,7 +54,13 @@ #if HAVE_DIRENT_H #include #endif - +#if HAVE_DIRECT_H +#include +#endif +#if defined(__MINGW32__) || _MSC_VER +#include +#include +#endif #ifdef __MINGW32__ #ifdef HAVE_ENVIRON #undef HAVE_ENVIRON @@ -68,7 +74,16 @@ static int datime(void) { Term tf, out[6]; -#ifdef HAVE_TIME +#if defined(__MINGW32__) || _MSC_VER + SYSTEMTIME stime; + GetLocalTime(&stime); + out[0] = MkIntTerm(stime.wYear); + out[1] = MkIntTerm(stime.wMonth); + out[2] = MkIntTerm(stime.wDay); + out[3] = MkIntTerm(stime.wHour); + out[4] = MkIntTerm(stime.wMinute); + out[5] = MkIntTerm(stime.wSecond); +#elif HAVE_TIME time_t tp; if ((tp = time(NULL)) == -1) { @@ -106,6 +121,32 @@ list_directory(void) Term tf = MkAtomTerm(LookupAtom("[]")); char *buf = AtomName(AtomOfTerm(ARG1)); +#if defined(__MINGW32__) || _MSC_VER + struct _finddata_t c_file; + char bs[BUF_SIZE]; + long hFile; + + bs[0] = '\0'; +#if HAVE_STRNCPY + strncpy(bs, buf, BUF_SIZE); +#else + strcpy(bs, buf); +#endif +#if HAVE_STRNCAT + strncat(bs, "/*", BUF_SIZE); +#else + strncat(bs, "/*"); +#endif + if ((hFile = _findfirst(bs, &c_file)) == -1L) { + return(unify(ARG2,tf)); + } + tf = MkPairTerm(MkAtomTerm(LookupAtom(c_file.name)), tf); + while (_findnext( hFile, &c_file) == 0) { + Term ti = MkAtomTerm(LookupAtom(c_file.name)); + tf = MkPairTerm(ti, tf); + } + _findclose( hFile ); +#else #if HAVE_OPENDIR { DIR *de; @@ -121,6 +162,7 @@ list_directory(void) closedir(de); } #endif /* HAVE_OPENDIR */ +#endif return(unify(ARG2, tf)); } @@ -128,10 +170,15 @@ static int p_unlink(void) { char *fd = AtomName(AtomOfTerm(ARG1)); - if (unlink(fd) == -1) { - /* return an error number */ - return(unify(ARG2, MkIntTerm(errno))); - } +#if defined(__MINGW32__) || _MSC_VER + if (_unlink(fd) == -1) +#else + if (unlink(fd) == -1) +#endif + { + /* return an error number */ + return(unify(ARG2, MkIntTerm(errno))); + } return(TRUE); } @@ -139,7 +186,11 @@ static int p_mkdir(void) { char *fd = AtomName(AtomOfTerm(ARG1)); +#if defined(__MINGW32__) || _MSC_VER + if (_mkdir(fd) == -1) { +#else if (mkdir(fd, 0777) == -1) { +#endif /* return an error number */ return(unify(ARG2, MkIntTerm(errno))); } @@ -150,7 +201,11 @@ static int p_rmdir(void) { char *fd = AtomName(AtomOfTerm(ARG1)); +#if defined(__MINGW32__) || _MSC_VER + if (_rmdir(fd) == -1) { +#else if (rmdir(fd) == -1) { +#endif /* return an error number */ return(unify(ARG2, MkIntTerm(errno))); } @@ -181,7 +236,7 @@ static int file_property(void) { char *fd; -#if HAVE_LSTAT +#if HAVE_LSTAT struct stat buf; fd = AtomName(AtomOfTerm(ARG1)); @@ -189,9 +244,9 @@ file_property(void) /* return an error number */ return(unify(ARG6, MkIntTerm(errno))); } - if (S_ISREG(buf.st_mode)) + if (buf.st_mode & _S_IFREG) unify(ARG2, MkAtomTerm(LookupAtom("regular"))); - else if (S_ISDIR(buf.st_mode)) + else if (buf.st_mode & _S_IFDIR) unify(ARG2, MkAtomTerm(LookupAtom("directory"))); else if (S_ISFIFO(buf.st_mode)) unify(ARG2, MkAtomTerm(LookupAtom("fifo"))); @@ -201,10 +256,25 @@ file_property(void) unify(ARG2, MkAtomTerm(LookupAtom("socket"))); else unify(ARG2, MkAtomTerm(LookupAtom("unknown"))); +#elif defined(__MINGW32__) || _MSC_VER + /* for some weird reason _stat did not work with mingw32 */ + struct stat buf; + + fd = AtomName(AtomOfTerm(ARG1)); + if (stat(fd, &buf) != 0) { + /* return an error number */ + return(unify(ARG6, MkIntTerm(errno))); + } + if (buf.st_mode & S_IFREG) + unify(ARG2, MkAtomTerm(LookupAtom("regular"))); + else if (buf.st_mode & S_IFDIR) + unify(ARG2, MkAtomTerm(LookupAtom("directory"))); + else + unify(ARG2, MkAtomTerm(LookupAtom("unknown"))); +#endif unify(ARG3, MkIntTerm(buf.st_size)); unify(ARG4, MkIntTerm(buf.st_mtime)); unify(ARG5, MkIntTerm(buf.st_mode)); -#endif return(TRUE); } @@ -221,7 +291,11 @@ p_mktemp(void) #else strcpy(tmp, s); #endif +#if defined(__MINGW32__) || _MSC_VER + if ((s = _mktemp(tmp)) == NULL) { +#else if ((s = mktemp(tmp)) == NULL) { +#endif /* return an error number */ return(unify(ARG3, MkIntTerm(errno))); } @@ -247,12 +321,20 @@ static int p_environ(void) { #if HAVE_ENVIRON +#if defined(__MINGW32__) || _MSC_VER + extern char **_environ; +#else extern char **environ; +#endif Term t1 = ARG1; Int i; i = IntOfTerm(t1); +#if defined(__MINGW32__) || _MSC_VER + if (_environ[i] == NULL) +#else if (environ[i] == NULL) +#endif return(FALSE); else { Term t = BufferToString(environ[i]); @@ -264,6 +346,37 @@ p_environ(void) #endif } +#if defined(__MINGW32__) || _MSC_VER +static int +get_handle(Term ti, int fd, Term tzero) +{ + if (ti == tzero) { + int new_fd = _dup(fd); + _close(fd); + return(new_fd); + } else { + int sd = YapStreamToFileNo(ti), new_fd; + if (sd == fd) + return(-1); + new_fd = _dup(fd); + _close(fd); + _dup2(sd, fd); + return(new_fd); + } +} + +static void +restore_descriptor(int fd0, int fd, Term t, Term tzero) +{ + if (fd != -1) { + if (t != tzero) { + _close(fd0); + } + _dup2(fd, fd0); + } +} +#endif + /* execute a command as a detached process */ static int execute_command(void) @@ -272,6 +385,46 @@ execute_command(void) Term tzero = MkIntTerm(0); int res; int inpf, outf, errf; +#if defined(__MINGW32__) || _MSC_VER + DWORD CreationFlags = 0; + STARTUPINFO StartupInfo; + PROCESS_INFORMATION ProcessInformation; + inpf = get_handle(ti, 0, tzero); + outf = get_handle(to, 1, tzero); + errf = get_handle(te, 2, tzero); + if (inpf != -1 || outf != -1 || errf != -1) { + /* we are keeping the curent streams */ + CreationFlags = DETACHED_PROCESS; + } + StartupInfo.cb = sizeof(STARTUPINFO); + StartupInfo.lpReserved = NULL; + StartupInfo.lpDesktop = NULL; /* inherit */ + StartupInfo.lpTitle = NULL; /* we do not create a new console window */ + StartupInfo.dwFlags = STARTF_USESTDHANDLES; + StartupInfo.cbReserved2 = 0; + StartupInfo.lpReserved2 = NULL; + StartupInfo.hStdInput = GetStdHandle(STD_INPUT_HANDLE); + StartupInfo.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); + StartupInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE); + /* got stdin, stdout and error as I like it */ + if (CreateProcess(NULL, + AtomName(AtomOfTerm(ARG1)), + NULL, + NULL, + TRUE, + CreationFlags, + NULL, + NULL, + &StartupInfo, + &ProcessInformation) == FALSE) { + return(unify(ARG6, MkIntTerm(GetLastError()))); + } + restore_descriptor(0, inpf, ti, tzero); + restore_descriptor(1, outf, to, tzero); + restore_descriptor(2, errf, te, tzero); + res = ProcessInformation.dwProcessId; + return(unify(ARG5,MkIntTerm(res))); +#else /* UNIX CODE */ /* process input first */ if (ti == tzero) { inpf = open("/dev/null", O_RDONLY); @@ -341,50 +494,7 @@ execute_command(void) close(errf); return(unify(ARG5,MkIntTerm(res))); } -} - -/* execute a command as a detached process */ -static int -shell(void) -{ - char *command = AtomName(AtomOfTerm(ARG1)); - int pid; - /* we are now ready to fork */ - if ((pid = fork()) < 0) { - /* return an error number */ - return(unify(ARG2, MkIntTerm(errno))); - } else if (pid == 0) { - char *argv[4]; - char *shell; - - /* child */ - /* close current streams, but not std streams */ - YapCloseAllOpenStreams(); -#if HAVE_GETENV - shell = getenv ("SHELL"); - if (shell == NULL) - shell = "/bin/sh"; -#endif - argv[0] = shell; - argv[1] = "-c"; - argv[2] = command; - argv[3] = NULL; - execv("/bin/sh", argv); - exit(127); - /* we have the streams where we want them, just want to execute now */ - } else { - do { - int status; - - /* check for interruptions */ - if (waitpid(pid, &status, 0) == -1) { - if (errno != EINTR) - return -1; - return(unify(ARG2, MkIntTerm(errno))); - } else - return(TRUE); - } while(TRUE); - } +#endif /* UNIX code */ } /* execute a command as a detached process */ @@ -403,6 +513,21 @@ static int p_wait(void) { Int pid = IntOfTerm(ARG1); +#if defined(__MINGW32__) || _MSC_VER + HANDLE proc = OpenProcess(STANDARD_RIGHTS_REQUIRED|SYNCHRONIZE, FALSE, pid); + DWORD ExitCode; + if (proc == NULL) { + return(unify(ARG3, MkIntTerm(GetLastError()))); + } + if (WaitForSingleObject(proc, INFINITE) == WAIT_FAILED) { + return(unify(ARG3, MkIntTerm(GetLastError()))); + } + if (GetExitCodeProcess(proc, &ExitCode) == 0) { + return(unify(ARG3, MkIntTerm(GetLastError()))); + } + CloseHandle(proc); + return(unify(ARG2, MkIntTerm(ExitCode))); +#else do { int status; @@ -415,6 +540,7 @@ p_wait(void) return(unify(ARG2, MkIntTerm(status))); } } while(TRUE); +#endif } /* execute a command as a detached process */ @@ -428,10 +554,18 @@ p_popen(void) int flags; #if HAVE_POPEN +#if defined(__MINGW32__) || _MSC_VER + /* This will only work for console applications. FIX */ + if (mode == 0) + pfd = _popen(command, "r"); + else + pfd = _popen(command, "w"); +#else if (mode == 0) pfd = popen(command, "r"); else pfd = popen(command, "w"); +#endif if (pfd == NULL) { return(unify(ARG4, MkIntTerm(errno))); } @@ -461,6 +595,11 @@ p_sleep(void) else usecs = tfl*1000; } +#if defined(__MINGW32__) || _MSC_VER + if (secs) usecs = secs*1000; + Sleep(usecs); + out = 0; +#else #if HAVE_USLEEP if (usecs > 0) { usleep(usecs); @@ -472,6 +611,7 @@ p_sleep(void) out = sleep(secs); } #endif +#endif /* defined(__MINGW32__) || _MSC_VER */ return(unify(ARG2, MkIntTerm(out))); } @@ -480,13 +620,21 @@ p_sleep(void) static int host_name(void) { - char name[256]; +#if defined(__MINGW32__) || _MSC_VER + char name[MAX_COMPUTERNAME_LENGTH+1]; + DWORD nSize = MAX_COMPUTERNAME_LENGTH+1; + if (GetComputerName(name, &nSize) == 0) { + return(unify(ARG2, MkIntTerm(GetLastError()))); + } +#else #if HAVE_GETHOSTNAME + char name[256]; if (gethostname(name, 256) == -1) { /* return an error number */ return(unify(ARG2, MkIntTerm(errno))); } #endif +#endif /* defined(__MINGW32__) || _MSC_VER */ return(unify(ARG1, MkAtomTerm(LookupAtom(name)))); } @@ -495,26 +643,42 @@ host_id(void) { #if HAVE_GETHOSTID return(unify(ARG1, MkIntTerm(gethostid()))); +#else + return(unify(ARG1, MkIntTerm(0))); #endif } static int pid(void) { +#if defined(__MINGW32__) || _MSC_VER + return(unify(ARG1, MkIntTerm(_getpid()))); +#else return(unify(ARG1, MkIntTerm(getpid()))); +#endif } static int p_kill(void) { -#if HAVE_KILL +#if defined(__MINGW32__) || _MSC_VER + /* Windows does not support cross-process signals, so we shall do the + SICStus thing and assume that a signal to a process will + always kill it */ + HANDLE proc = OpenProcess(STANDARD_RIGHTS_REQUIRED|PROCESS_TERMINATE, FALSE, IntOfTerm(ARG1)); + if (proc == NULL) { + return(unify(ARG3, MkIntTerm(GetLastError()))); + } + if (TerminateProcess(proc, -1) == 0) { + return(unify(ARG3, MkIntTerm(GetLastError()))); + } + CloseHandle(proc); +#else if (kill(IntOfTerm(ARG1), IntOfTerm(ARG2)) < 0) { /* return an error number */ - return(unify(ARG2, MkIntTerm(errno))); + return(unify(ARG3, MkIntTerm(errno))); } -#else - oops -#endif +#endif /* defined(__MINGW32__) || _MSC_VER */ return(TRUE); } @@ -542,7 +706,6 @@ init_sys(void) UserCPredicate("dir_separator", dir_separator, 1); UserCPredicate("p_environ", p_environ, 2); UserCPredicate("exec_command", execute_command, 6); - UserCPredicate("do_shell", shell, 2); UserCPredicate("do_system", do_system, 2); UserCPredicate("popen", p_popen, 4); UserCPredicate("wait", p_wait, 3); @@ -561,9 +724,9 @@ init_sys(void) #include -int WINAPI PROTO(win_system, (HANDLE, DWORD, LPVOID)); +int WINAPI PROTO(win_sys, (HANDLE, DWORD, LPVOID)); -int WINAPI win_system(HANDLE hinst, DWORD reason, LPVOID reserved) +int WINAPI win_sys(HANDLE hinst, DWORD reason, LPVOID reserved) { switch (reason) { @@ -576,6 +739,6 @@ int WINAPI win_system(HANDLE hinst, DWORD reason, LPVOID reserved) case DLL_THREAD_DETACH: break; } -p return 1; + return 1; } #endif diff --git a/pl/boot.yap b/pl/boot.yap index 49949fd9f..72feed80c 100644 --- a/pl/boot.yap +++ b/pl/boot.yap @@ -866,6 +866,8 @@ break :- '$get_value'('$break',BL), NBL is BL+1, ; throw(error(permission_error(input,stream,Y),consult(X))) ). +'$consult'(M:X) :- + '$mod_switch'(M,'$consult'(X)). '$consult'(library(X)) :- !, '$find_in_path'(library(X),Y), ( open(Y,'$csult',Stream), !, diff --git a/pl/consult.yap b/pl/consult.yap index 98f91a642..62846184e 100644 --- a/pl/consult.yap +++ b/pl/consult.yap @@ -15,6 +15,9 @@ * * *************************************************************************/ +ensure_loaded(V) :- + '$ensure_loaded'(V). + '$ensure_loaded'(V) :- var(V), !, throw(error(instantiation_error,ensure_loaded(V))). '$ensure_loaded'([]) :- !. @@ -40,6 +43,8 @@ throw(error(permission_error(input,stream,X),ensure_loaded(X))) ). +'$ensure_loaded'(M:X) :- + '$mod_switch'(M,'$ensure_loaded'(X)). '$ensure_loaded'(library(X)) :- !, '$find_in_path'(library(X),Y), ( open(Y,'$csult',Stream), !, @@ -100,6 +105,8 @@ reconsult(Fs) :- ; throw(error(permission_error(input,stream,X),reconsult(X))) ). +'$reconsult'(M:X) :- + '$mod_switch'(M,'$reconsult'(X)). '$reconsult'(library(X)) :- !, '$find_in_path'(library(X),Y), ( open(Y,'$csult',Stream), !, diff --git a/pl/listing.yap b/pl/listing.yap index 618069db5..cb0d55ad1 100644 --- a/pl/listing.yap +++ b/pl/listing.yap @@ -54,6 +54,12 @@ listing(_). '$write_clause'(Pred,Body), fail. +portray_clause(Stream, Clause) :- + current_output(OldStream), + set_output(Stream), + portray_clause(Clause), + set_output(OldStream). + portray_clause((Pred:-Body)) :- !, '$beautify_vars'((Pred:-Body)), '$write_clause'(Pred,Body). diff --git a/pl/modules.yap b/pl/modules.yap index 5579c9eb9..34655bc71 100644 --- a/pl/modules.yap +++ b/pl/modules.yap @@ -249,7 +249,6 @@ $check_import(_,_,_,_). ; true ). - '$abolish_module_data'(M) :- @@ -267,12 +266,12 @@ $check_import(_,_,_,_). '$prepare_body_with_correct_modules'(B, M, B0), '$module_u_vars'(H,UVars), % collect head variables in % expanded positions - '$module_expansion'(B0,B1,BO,M,UVars). % expand body + '$module_expansion'(B0,B1,BO,M,M,M,UVars). % expand body '$module_expansion'((H:-B),(H:-B1),(H:-BO)) :- '$module_u_vars'(H,UVars), % collect head variables in % expanded positions '$current_module'(M), - '$module_expansion'(B,B1,BO,M,UVars). % expand body + '$module_expansion'(B,B1,BO,M,M,M,UVars). % expand body % $trace_module((H:-B),(H:-B1)). % expand module names in a body @@ -295,15 +294,15 @@ $check_import(_,_,_,_). '$prepare_body_with_correct_modules'(G,M,M:G). -$trace_module(X) :- +'$trace_module'(X) :- telling(F), tell('P0:debug'), write(X),nl, tell(F), fail. -$trace_module(X). +'$trace_module'(X). -$trace_module(X,Y) :- X==Y, !. -$trace_module(X,Y) :- +'$trace_module'(X,Y) :- X==Y, !. +'$trace_module'(X,Y) :- telling(F), tell('~/.dbg.modules'), write('***************'), nl, @@ -330,72 +329,60 @@ $trace_module(X,Y). '$execute0'(G). -'$complete_goal_expansion'(G, M, _, G1, G2, HVars) :- - '$pred_goal_expansion_on', - user:goal_expansion(G,M,GI), !, - '$prepare_body_with_correct_modules'(GI, M, GF), - '$module_expansion'(GF,G1,G2,M,HVars). -'$complete_goal_expansion'(G, _, _, G, GF, _) :- - '$system_predicate'(G), !, - '$c_built_in'(G,GF). -'$complete_goal_expansion'(G, Mod, Mod, G, G, _) :- '$current_module'(Mod), !. -'$complete_goal_expansion'(G, GMod, _, GMod:G, GMod:G, _). - - % expand module names in a body -'$module_expansion'(V,call(M:V),call(M:V),M,HVars) :- var(V), !. -'$module_expansion'((A,B),(A1,B1),(AO,BO),M,HVars) :- !, - '$module_expansion'(A,A1,AO,M,HVars), - '$module_expansion'(B,B1,BO,M,HVars). -'$module_expansion'((A;B),(A1;B1),(AO;BO),M,HVars) :- !, - '$module_expansion'(A,A1,AO,M,HVars), - '$module_expansion'(B,B1,BO,M,HVars). -'$module_expansion'((A->B),(A1->B1),(AO->BO),M,HVars) :- !, - '$module_expansion'(A,A1,AO,M,HVars), - '$module_expansion'(B,B1,BO,M,HVars). -'$module_expansion'(true,true,true,_,_) :- !. -'$module_expansion'(fail,fail,fail,_,_) :- !. -'$module_expansion'(false,false,false,_,_) :- !. +% args are: +% goals to expand +% code to pass to compiler +% code to pass to listing +% current module for looking up preds +% current module for fixing up meta-call arguments +% current module for predicate +% head variables. +'$module_expansion'(V,call(MM:V),call(MM:V),M,MM,TM,HVars) :- var(V), !. +'$module_expansion'((A,B),(A1,B1),(AO,BO),M,MM,TM,HVars) :- !, + '$module_expansion'(A,A1,AO,M,MM,TM,HVars), + '$module_expansion'(B,B1,BO,M,MM,TM,HVars). +'$module_expansion'((A;B),(A1;B1),(AO;BO),M,MM,TM,HVars) :- !, + '$module_expansion'(A,A1,AO,M,MM,TM,HVars), + '$module_expansion'(B,B1,BO,M,MM,TM,HVars). +'$module_expansion'((A->B),(A1->B1),(AO->BO),M,MM,TM,HVars) :- !, + '$module_expansion'(A,A1,AO,M,MM,TM,HVars), + '$module_expansion'(B,B1,BO,M,MM,TM,HVars). +'$module_expansion'(true,true,true,_,_,_,_) :- !. +'$module_expansion'(fail,fail,fail,_,_,_,_) :- !. +'$module_expansion'(false,false,false,_,_,_,_) :- !. % 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. -'$module_expansion'(M:G,call(M:G),call(M:G),_,HVars) :- var(M), !. -'$module_expansion'(M:(M1:G),G1,GO,M0,HVars) :- !, - '$module_expansion'(M1:G,G1,GO,M0,HVars). -'$module_expansion'(M:G,G1,GO,Mod,HVars) :- !, +'$module_expansion'(M:G,call(M:G),call(M:G),_,_,_,HVars) :- var(M), !. +% if M1 is given explicitly process G within M1's context. +'$module_expansion'(M:G,G1,GO,Mod,MM,TM,HVars) :- !, % is this imported from some other module M1? ( '$imported_pred'(G, M, M1) -> % continue recursively... - '$module_expansion'(M1:G,G1,GO,Mod,HVars) + '$module_expansion'(G,G1,GO,M1,M,TM,HVars) ; ( - '$meta_expansion_of_subgoal'(G, M, Mod, NG, HVars, NM) + '$meta_expansion'(M, M, G, NG, HVars) ; - G = NG, M = NM + G = NG ), - '$complete_goal_expansion'(NG, NM, Mod, G1, GO, HVars) + '$complete_goal_expansion'(NG, M, M, TM, G1, GO, HVars) ). % % next, check if this is something imported. % -'$module_expansion'(G, G1, GO, CurMod, HVars) :- +'$module_expansion'(G, G1, GO, CurMod, MM, TM, HVars) :- % is this imported from some other module M1? ( '$imported_pred'(G, CurMod, M1) -> - % continue recursively... - '$module_expansion'(M1:G,G1,GO,CurMod,HVars) + '$module_expansion'(G, G1, GO, M1, MM, TM, HVars) ; - ( '$meta_expansion_of_subgoal'(G, CurMod, CurMod, GI, HVars, GoalModule) + ( '$meta_expansion'(CurMod, MM, G, GI, HVars) ; - GI = G, GoalModule = CurMod + GI = G ), - '$complete_goal_expansion'(GI, GoalModule, CurMod, G1, GO, HVars) + '$complete_goal_expansion'(GI, CurMod, MM, TM, G1, GO, HVars) ). -'$meta_expansion_of_subgoal'(G, GMod, CurMod, GF, HVars, ImportedMod) :- - functor(G,F,N), - '$recorded'('$import','$import'(ImportedMod,GMod,F,N),_), !, - '$meta_expansion'(ImportedMod, CurMod, G, GF, HVars). -'$meta_expansion_of_subgoal'(G, GMod, CurMod, NG, HVars, GMod) :- - '$meta_expansion'(GMod, CurMod, G, NG, HVars). '$imported_pred'(G, ImportingMod, ExportingMod) :- '$undefined'(ImportingMod:G), @@ -403,27 +390,40 @@ $trace_module(X,Y). '$recorded'('$import','$import'(ExportingMod,ImportingMod,F,N),_), ExportingMod \= ImportingMod. +% args are: +% goal to expand +% current module for looking up pred +% current module from top-level clause +% goal to pass to compiler +% goal to pass to listing +% head variables. +'$complete_goal_expansion'(G, M, CM, TM, G1, G2, HVars) :- + '$pred_goal_expansion_on', + user:goal_expansion(G,M,GI), !, + '$module_expansion'(GI,G1,G2,M,CM,TM,HVars). +'$complete_goal_expansion'(G, _, _, _, G, GF, _) :- + '$system_predicate'(G), !, + '$c_built_in'(G,GF). +'$complete_goal_expansion'(G, Mod, _, Mod, G, G, _) :- !. +'$complete_goal_expansion'(G, GMod, _, _, GMod:G, GMod:G, _). + % meta_predicate declaration % records $meta_predicate(SourceModule,Functor,Arity,Declaration) % directive now meta_predicate Ps :- $meta_predicate(Ps). '$meta_predicate'((P,Ps)) :- !, - $meta_predicate(P), - $meta_predicate(Ps). + '$meta_predicate'(P), + '$meta_predicate'(Ps). '$meta_predicate'(P) :- functor(P,F,N), '$current_module'(M1), ( M1 = prolog -> M = _ ; M1 = M), -% ( '$recorded'($meta_predicate,$meta_predicate(M,F,N,_),R), erase(R), fail; -% true -% ), -% recorda('$meta_predicate','$meta_predicate'(M,F,N,P),_), ( retractall('$meta_predicate'(F,M,N,_)), fail ; true), - asserta($meta_predicate(F,M,N,P)), + asserta('$meta_predicate'(F,M,N,P)), '$flags'(P, Fl, Fl), NFlags is Fl \/ 0x200000, - '$flags'(P, Fl, NFlags). + '$flags'(P, Fl, NFlags). % return list of vars in expanded positions on the head of a clause. % @@ -432,8 +432,8 @@ $trace_module(X,Y). '$module_u_vars'(H,UVars) :- functor(H,F,N), '$current_module'(M), -% '$recorded'($meta_predicate,$meta_predicate(M,F,N,D),_), !, - $meta_predicate(F,M,N,D), !, +% '$recorded'('$meta_predicate','$meta_predicate'(M,F,N,D),_), !, + '$meta_predicate'(F,M,N,D), !, '$module_u_vars'(N,D,H,UVars). '$module_u_vars'(H,[]). @@ -490,15 +490,15 @@ current_module(Mod,TFN) :- source_module(Mod) :- '$current_module'(Mod). - -$member(X,[X|_]) :- !. -$member(X,[_|L]) :- $member(X,L). +'$member'(X,[X|_]) :- !. +'$member'(X,[_|L]) :- '$member'(X,L). % % this declaration should only be here, as meta_predicates should belong % to the user module, not to the prolog module :- meta_predicate +% [:,:], abolish(:), abolish(:,+), all(?,:,?), @@ -512,8 +512,11 @@ $member(X,[_|L]) :- $member(X,L). call(:), clause(:,?), clause(:,?,?), + compile(:), + consult(:), current_predicate(:), current_predicate(?,:), + ensure_loaded(:), findall(?,:,?), findall(?,:,?,?), if(:,:,:), @@ -524,6 +527,7 @@ $member(X,[_|L]) :- $member(X,L). retract(:), retract(:,?), retractall(:), + reconsult(:), setof(?,:,?), spy(:), ^(+,:), diff --git a/pl/preds.yap b/pl/preds.yap index 86fa94e0e..8f3771ea7 100644 --- a/pl/preds.yap +++ b/pl/preds.yap @@ -324,8 +324,8 @@ abolish(X) :- abolish(X) :- '$old_abolish'(X). -'$new_abolish'(V) :- - '$check_error_in_predicate_indicator'(V, abolish(V)), !. +'$new_abolish'(V) :- var(V), !, + '$abolish_all'. '$new_abolish'(M:PS) :- !, '$mod_switch'(M,'$new_abolish'(PS)). '$new_abolish'(Na/Ar) :- @@ -339,6 +339,12 @@ abolish(X) :- '$current_module'(M), throw(error(permission_error(modify,static_procedure,Na/Ar),abolish(M:Na/Ar))). +'$abolish_all' :- + current_predicate(_,P), + functor(P, Na, Ar), + '$new_abolish'(Na, Ar), + fail. +'$abolish_all'. '$check_error_in_predicate_indicator'(V, Msg) :- var(V), !, @@ -377,7 +383,7 @@ abolish(X) :- throw(error(type_error(atom,Na), Msg)). '$old_abolish'(V) :- - '$check_error_in_predicate_indicator'(V, abolish(V)). + '$abolish_all'. '$old_abolish'(M:N) :- !, '$mod_switch'(M,'$old_abolish'(N)). '$old_abolish'([]) :- !. diff --git a/pl/utils.yap b/pl/utils.yap index d3ae190d3..356ca25a4 100644 --- a/pl/utils.yap +++ b/pl/utils.yap @@ -850,7 +850,9 @@ user_defined_directive(Dir,Action) :- '$fast_do'(M:G) :- '$mod_switch'(M,G). '$fast_do'('$spycalls'(G,Res)) :- '$spycalls'(G,Res). '$fast_do'('$profile_data'(P, Parm, Data)) :- '$profile_data'(P, Parm, Data). - +'$fast_do'('$ensure_loaded'(F)) :- '$ensure_loaded'(F). +'$fast_do'('$consult'(F)) :- '$consult'(F). +'$fast_do'('$reconsult'(F)) :- '$reconsult'(F). '$set_toplevel_hook'(_) :- '$recorded'('$toplevel_hooks',_,R), diff --git a/pl/yapor.yap b/pl/yapor.yap index b26aa1eb5..cda887588 100644 --- a/pl/yapor.yap +++ b/pl/yapor.yap @@ -22,7 +22,8 @@ % * -------- YAPOR -------- * % *************************** -default_sequential(X) :- '$default_sequential'(X), !. +default_sequential(X) :- + '$default_sequential'(X), !. default_sequential(_). '$sequential' :- diff --git a/pl/yio.yap b/pl/yio.yap index 963a418dd..989e5459f 100644 --- a/pl/yio.yap +++ b/pl/yio.yap @@ -833,7 +833,7 @@ absolute_file_name(RelFile,AbsFile) :- '$get_value'(fileerrors,V), '$set_value'(fileerrors,0), ( open(F,Mode,S), !, - '$user_file_name'(S, AbsFile), + '$file_name'(S, AbsFile), close(S), '$set_value'(fileerrors,V); '$set_value'(fileerrors,V), fail).