diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

change SWI stuff to swi directory.

Browse Source
This commit is contained in:
Vitor Santos Costa
2013-03-05 15:50:38 -06:00
parent 263a1a548c
commit a5000dab32
55 changed files with 15540 additions and 3255 deletions
Download Patch File Download Diff File Expand all files Collapse all files

75
swi/console/Makefile.in Normal file
View File

@@ -0,0 +1,75 @@
#
# default base directory for YAP installation
# (EROOT for architecture-dependent files)
#
prefix = @prefix@
exec_prefix = @exec_prefix@
ROOTDIR = $(prefix)
EROOTDIR = @exec_prefix@
#
# where YAP should look for libraries
#
LIBDIR=@libdir@/Yap
#
#
CC=@CC@ -municode -DUNICODE -D_UNICODE
CPPFLAGS=@CPPFLAGS@
CFLAGS= @CFLAGS@ $(DEFS) $(CPPFLAGS) -I$(srcdir) -DRLC_VENDOR="\"YAP\""
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
RANLIB=@RANLIB@
AR=@AR@
srcdir=@srcdir@
SOURCES= \
$(srcdir)/complete.c $(srcdir)/console.c \
$(srcdir)/edit.c $(srcdir)/history.c \
$(srcdir)/menu.c
HEADERS= \
$(srcdir)/common.h $(srcdir)/console.h \
$(srcdir)/console_i.h $(srcdir)/history.h \
$(srcdir)/menu.h
OBJECTS= complete.o console.o edit.o history.o menu.o
LIBS=-lgdi32 -lcomdlg32
all: ../../plterm.dll
../../plterm.dll: libplterm.a
$(CC) $(CFLAGS) -shared -o ../../plterm.dll \
-Wl,--export-all-symbols \
-Wl,--enable-auto-import \
-Wl,--whole-archive libplterm.a \
-Wl,--no-whole-archive $(LIBS) $(LDFLAGS)
libplterm.a: $(OBJECTS) $(SOURCES) $(HEADERS)
-rm -f libplterm.a
$(AR) rc libplterm.a $(OBJECTS)
$(RANLIB) libplterm.a
install:
clean:
rm -f *.o *~ *.dll
complete.o: $(srcdir)/complete.c
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/complete.c -o complete.o
console.o: $(srcdir)/console.c
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/console.c -o console.o
history.o: $(srcdir)/history.c
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/history.c -o history.o
menu.o: $(srcdir)/menu.c
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/menu.c -o menu.o
edit.o: $(srcdir)/edit.c
$(CC) -c $(CFLAGS) $(SHLIB_CFLAGS) $(srcdir)/edit.c -o edit.o

92
swi/console/README Normal file
View File

@@ -0,0 +1,92 @@
Win32 `Readline Console'
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
Purpose
=======
The `readline console' provides a simple, but reasonable powerful
console window for running standard I/O based applications that may wish
to access Windows functions.
The console window is inspired by both the X11 xterm application and the
GNU readline library. The text is buffered to provide for window
resizing and scroll-back. When reading input by line, an Emacs like
editor is provided for editing the input line. Old input lines are
remembered and used by the history system.
Edit functions
==============
The following edit functions are provided:
Control-A Beginning of line
Control-B Character backward
Control-C Generate interrupt
Control-D Delete character forwards, or end-of-file
Control-E End of line
Control-F Character forwards
Control-I (TAB) Complete (filename, may be programmed)
Control-J (NL) Enter (make line available)
Control-K Delete to end-of-line
Control-M (RET) Enter (make line available)
Control-N Next line in history
Control-P Previous line in history
Control-T Toggle characters around caret
Control-U Empty line
Control-V Paste
Control-Z End-of-file
DEL Delete character forwards
BACKSPACE Delete character backwards
<-, -> Move caret in line, with SHIFT down, move
by word.
Up, down Move in history list
Mouse-bindings:
Left: Start selection, dragging extends the selection.
Double-click selects in `word-mode'. The
selection is placed on the Windows clipboard.
Middle: Paste the Windows clipboard (also Control-V).
Right: Extends the selection.
Compilation:
============
Includes a project file for MSVC 4.2. Please inspect the settings first.
plterm.dll is made from console.c, edit.c and history.c
Settings:
=========
Settings are kept in the Windows registry under the key
Software\<vendor>\<program>\Console
Where
<vendor> is SWI, unless compiled with a different setting for
RLC_VENDOR
<program> is the basename of the program without extension
(i.e. plwin for the program C:\Program
Files\pl\bin\plwin.exe).
Maintained values on this key are:
Name Type Description
================================================================
SaveLines int (200-100000) # lines saved for scrollback
Width int (20-300) # width in characters
Height int (5-100) # height in characters
X int (0-screen-width) # X-position of window
Y int (0-screen-height) # Y-position of window
FaceName str # Font info (settable using
FontFamily int # extension of Windows menu)
FontSize int
FontWeight int
FontCharSet int

32
swi/console/clp/Makefile.in Normal file
View File

@@ -0,0 +1,32 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for binary libraries
#
LIBDIR=@libdir@/Yap
#
# where YAP should look for architecture-independent Prolog libraries
#
SHAREDIR=$(ROOTDIR)/share
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
PROGRAMS= $(srcdir)/clp_events.pl
install: $(PROGRAMS)
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/clp
for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/clp; done

89
swi/console/clp/clp_events.pl Normal file
View File

@@ -0,0 +1,89 @@
/* $Id: clp_events.pl,v 1.1 2005-10-28 17:53:27 vsc Exp $
Part of SWI-Prolog
Author: Tom Schrijvers
E-mail: tom.schrijvers@cs.kuleuven.ac.be
WWW: http://www.swi-prolog.org
Copyright (C): 2005, K.U.Leuven
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Module for managing constraint solver events.
%
% Author: Tom Schrijvers
% E-mail: tom.schrijvers@cs.kuleuven.ac.be
% Copyright: 2005, K.U.Leuven
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:-module(clp_events,
[
notify/2,
subscribe/4,
unsubscribe/2
]).
notify(V,NMod) :-
( get_attr(V,clp_events,List) ->
notify_list(List,NMod)
;
true
).
subscribe(V,NMod,SMod,Goal) :-
( get_attr(V,clp_events,List) ->
put_attr(V,clp_events,[entry(NMod,SMod,Goal)|List])
;
put_attr(V,clp_events,[entry(NMod,SMod,Goal)])
).
unsubscribe(V,SMod) :-
( get_attr(V,clp_events,List) ->
unsubscribe_list(List,SMod,NList),
put_attr(V,clp_events,NList)
;
true
).
notify_list([],_).
notify_list([entry(Mod,_,Goal)|Rest],NMod) :-
( Mod == NMod ->
call(Goal)
;
true
),
notify_list(Rest,NMod).
unsubscribe_list([],_,_).
unsubscribe_list([Entry|Rest],SMod,List) :-
Entry = entry(_,Mod,_),
( Mod == SMod ->
List = Rest
;
List = [Entry|Tail],
unsubscribe_list(Rest,SMod,Tail)
).
attr_unify_hook(_,_).

27
swi/console/common.h Normal file
View File

@@ -0,0 +1,27 @@
/* $Id: common.h,v 1.1 2008-04-01 08:50:48 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#define IMODE_SWITCH_CHAR -2
#define RL_CANCELED_CHARP ((TCHAR *)-1)

124
swi/console/complete.c Normal file
View File

@@ -0,0 +1,124 @@
/* $Id: complete.c,v 1.1 2008-03-27 00:41:33 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#include <windows.h>
#include <tchar.h>
#include "console.h"
#ifndef __TCHAR_DEFINED
typedef wint_t _TINT;
#endif
#ifndef EOS
#define EOS 0
#endif
static TCHAR *completion_chars = TEXT("~:\\/-.");
static size_t
complete_scan_backwards(Line ln, size_t from)
{ while( from > 0 )
{ _TINT c = ln->data[from-1];
if ( rlc_is_word_char(c) ||
_tcschr(completion_chars, c) )
from--;
else
break;
}
return from;
}
static __inline int
close_quote(int c)
{ return (c == '\'' || c == '"') ? c : 0;
}
int
rlc_complete_file_function(RlcCompleteData data)
{ Line ln = data->line;
WIN32_FIND_DATA fdata;
switch(data->call_type)
{ case COMPLETE_INIT:
{ size_t start = complete_scan_backwards(ln, ln->point);
TCHAR *pattern = data->buf_handle;
TCHAR *s = pattern;
size_t n = start;
size_t ld = start;
HANDLE h;
if ( ln->point - start > 200 )
return FALSE;
for( ; n < ln->point; n++)
{ int c = ln->data[n];
if ( c == '/' )
c = '\\';
if ( c == '\\' )
ld = n + 1;
*s++ = c;
}
*s++ = '*';
*s = EOS;
if ( (h=FindFirstFile(pattern, &fdata)) != INVALID_HANDLE_VALUE )
{ data->replace_from = (int)ld;
if ( start > 0 &&
!(fdata.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY) )
data->quote = close_quote(ln->data[start-1]);
_tcscpy(data->candidate, fdata.cFileName);
data->ptr_handle = h;
data->case_insensitive = TRUE;
data->function = rlc_complete_file_function;
return TRUE;
}
return FALSE;
}
case COMPLETE_ENUMERATE:
{ if ( FindNextFile(data->ptr_handle, &fdata) )
{ _tcscpy(data->candidate, fdata.cFileName);
return TRUE;
}
return FALSE;
}
case COMPLETE_CLOSE:
{ FindClose(data->ptr_handle);
return FALSE;
}
default:
return FALSE;
}
}

3659
swi/console/console.c Normal file
View File

File diff suppressed because it is too large Load Diff

225
swi/console/console.h Normal file
View File

@@ -0,0 +1,225 @@
/* $Id: console.h,v 1.1 2008-04-01 08:45:42 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#ifndef _CONSOLE_H_INCLUDED
#define _CONSOLE_H_INCLUDED
#ifndef RLC_VENDOR
#define RLC_VENDOR TEXT("SWI")
#endif
#define RLC_TITLE_MAX 256 /* max length of window title */
#ifndef _export
#ifdef _MAKE_DLL
#define _export __declspec(dllexport)
#else
#define _export extern
#endif
#endif
#include <signal.h>
#include <stddef.h>
#if __GNUC__
#include <stdint.h>
#else
#if (_MSC_VER < 1300)
typedef long intptr_t;
typedef unsigned long uintptr_t;
#endif
#endif
#define RLC_APPTIMER_ID 100 /* >=100: application timer */
typedef struct
{ int first;
int last;
int size; /* size of the buffer */
TCHAR *buffer; /* character buffer */
int flags; /* flags for the queue */
} rlc_queue, *RlcQueue;
#define RLC_EOF 0x1 /* Flags on the queue */
typedef struct
{ int mark_x;
int mark_y;
} rlc_mark, *RlcMark;
typedef struct
{ const TCHAR *title; /* window title */
const TCHAR *key; /* Last part of registry-key */
int width; /* # characters(0: default) */
int height; /* # characters (0: default) */
int x; /* # pixels (0: default) */
int y; /* # pixels (0: default) */
int savelines; /* # lines to save (0: default) */
TCHAR face_name[32]; /* font name */
int font_family; /* family id */
int font_size;
int font_weight;
int font_char_set;
} rlc_console_attr;
typedef void * rlc_console; /* console handle */
typedef void (*RlcUpdateHook)(void); /* Graphics update hook */
typedef void (*RlcTimerHook)(int); /* Timer fireing hook */
typedef int (*RlcRenderHook)(WPARAM); /* Render one format */
typedef void (*RlcRenderAllHook)(void); /* Render all formats */
typedef int (*RlcMain)(rlc_console c, int, TCHAR**); /* main() */
typedef void (*RlcInterruptHook)(rlc_console, int); /* Hook for Control-C */
typedef void (*RlcResizeHook)(int, int); /* Hook for window change */
typedef void (*RlcMenuHook)(rlc_console, const TCHAR *id); /* Hook for menu-selection */
typedef void (*RlcFreeDataHook)(uintptr_t data); /* release data */
#if defined(_WINDOWS_) || defined(_WINDOWS_H) /* <windows.h> is included */
/* rlc_color(which, ...) */
#define RLC_WINDOW (0) /* window background */
#define RLC_TEXT (1) /* text color */
#define RLC_HIGHLIGHT (2) /* selected text background */
#define RLC_HIGHLIGHTTEXT (3) /* selected text */
_export HANDLE rlc_hinstance(void); /* hInstance of WinMain() */
_export HWND rlc_hwnd(rlc_console c); /* HWND of console window */
_export int rlc_window_pos(rlc_console c,
HWND hWndInsertAfter,
int x, int y, int w, int h,
UINT flags); /* resize/reposition window */
_export int rlc_main(HANDLE hI, HANDLE hPrevI,
LPTSTR cmd, int show, RlcMain main, HICON icon);
_export void rlc_icon(rlc_console c, HICON icon); /* Change icon */
_export COLORREF rlc_color(rlc_console c, int which, COLORREF color);
typedef LRESULT (*RlcMessageHook)(HWND hwnd, UINT message,
WPARAM wParam, LPARAM lParam);
_export RlcMessageHook rlc_message_hook(RlcMessageHook hook);
#endif /*_WINDOWS_*/
_export RlcUpdateHook rlc_update_hook(RlcUpdateHook updatehook);
_export RlcTimerHook rlc_timer_hook(RlcTimerHook timerhook);
_export RlcRenderHook rlc_render_hook(RlcRenderHook renderhook);
_export RlcRenderAllHook rlc_render_all_hook(RlcRenderAllHook renderallhook);
_export RlcInterruptHook rlc_interrupt_hook(RlcInterruptHook interrupthook);
_export RlcResizeHook rlc_resize_hook(RlcResizeHook resizehook);
_export RlcMenuHook rlc_menu_hook(RlcMenuHook menuhook);
_export int rlc_copy_output_to_debug_output(int docopy);
_export rlc_console rlc_create_console(rlc_console_attr *attr);
_export void rlc_title(rlc_console c,
TCHAR *title, TCHAR *old, int size);
_export void rlc_yield(void);
_export void rlc_word_char(int chr, int isword);
_export int rlc_is_word_char(int chr);
_export int rlc_iswin32s(void); /* check for Win32S */
_export void rlc_free(void *ptr);
_export void * rlc_malloc(size_t size);
_export void * rlc_realloc(void *ptr, size_t size);
_export size_t rlc_read(rlc_console c, TCHAR *buf, size_t cnt);
_export size_t rlc_write(rlc_console c, TCHAR *buf, size_t cnt);
_export int rlc_close(rlc_console c);
_export int rlc_flush_output(rlc_console c);
_export int getch(rlc_console c);
_export int getche(rlc_console c);
_export int getkey(rlc_console c);
_export int kbhit(rlc_console c);
_export void ScreenGetCursor(rlc_console c, int *row, int *col);
_export void ScreenSetCursor(rlc_console c, int row, int col);
_export int ScreenCols(rlc_console c);
_export int ScreenRows(rlc_console c);
_export int rlc_insert_menu_item(rlc_console c,
const TCHAR *menu,
const TCHAR *label,
const TCHAR *before);
_export int rlc_insert_menu(rlc_console c,
const TCHAR *label,
const TCHAR *before);
/*******************************
* GET/SET VALUES *
*******************************/
#define RLC_APPLICATION_THREAD 0 /* thread-handle of application */
#define RLC_APPLICATION_THREAD_ID 1 /* thread id of application */
#define RLC_VALUE(N) (1000+(N))
_export int rlc_get(rlc_console c, int what,
uintptr_t *val);
_export int rlc_set(rlc_console c, int what,
uintptr_t val,
RlcFreeDataHook hook);
/*******************************
* LINE EDIT STUFF *
*******************************/
typedef struct _line
{ rlc_mark origin; /* origin of edit */
size_t point; /* location of the caret */
size_t size; /* # characters in buffer */
size_t allocated; /* # characters allocated */
size_t change_start; /* start of change */
int complete; /* line is completed */
int reprompt; /* repeat the prompt */
TCHAR *data; /* the data (malloc'ed) */
rlc_console console; /* console I belong to */
} line, *Line;
#define COMPLETE_MAX_WORD_LEN 256
#define COMPLETE_MAX_MATCHES 100
#define COMPLETE_INIT 0
#define COMPLETE_ENUMERATE 1
#define COMPLETE_CLOSE 2
typedef int (*RlcCompleteFunc)(struct _complete_data *);
typedef struct _complete_data
{ Line line; /* line we are completing */
int call_type; /* COMPLETE_* */
int replace_from; /* index to start replacement */
int quote; /* closing quote */
int case_insensitive; /* if TRUE: insensitive match */
TCHAR candidate[COMPLETE_MAX_WORD_LEN];
TCHAR buf_handle[COMPLETE_MAX_WORD_LEN];
RlcCompleteFunc function; /* function for continuation */
void *ptr_handle; /* pointer handle for client */
intptr_t num_handle; /* numeric handle for client */
} rlc_complete_data, *RlcCompleteData;
_export RlcCompleteFunc rlc_complete_hook(RlcCompleteFunc func);
_export TCHAR *read_line(rlc_console console);
_export int rlc_complete_file_function(RlcCompleteData data);
_export void rlc_init_history(rlc_console c, int size);
_export void rlc_add_history(rlc_console c, const TCHAR *line);
_export int rlc_bind(int chr, const char *fname);
#endif /* _CONSOLE_H_INCLUDED */

199
swi/console/console_i.h Normal file
View File

@@ -0,0 +1,199 @@
/* $Id: console_i.h,v 1.1 2008-04-01 08:50:44 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker and Anjo Anjewierden
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Include file to share stuff inside this library.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/*******************************
* HISTORY *
*******************************/
typedef struct _history
{ int size; /* size of the history */
int tail; /* oldest position */
int head; /* newest position */
int current; /* for retrieval */
TCHAR ** lines; /* the lines */
} history, *History;
/*******************************
* CONSOLE DATA *
*******************************/
#define ANSI_MAX_ARGC 10 /* Ansi-escape sequence argv */
#define MAXPROMPT 80 /* max size of prompt */
#define OQSIZE 4096 /* output queue size */
#define MAX_USER_VALUES 10 /* max user data-handles */
typedef struct lqueued
{ TCHAR * line; /* Lines in queue */
struct lqueued* next; /* Next in queue */
} lqueued, *LQueued;
typedef struct
{ TCHAR * text; /* the storage */
unsigned short size; /* #characters in line */
unsigned adjusted : 1; /* line has been adjusted? */
unsigned changed : 1; /* line needs redraw */
unsigned softreturn : 1; /* wrapped line */
} text_line, *TextLine;
typedef struct
{ uintptr_t data; /* the data itself */
RlcFreeDataHook hook; /* call when destroying console */
} user_data;
#define RLC_MAGIC 0x3b75df1e /* magic number to verify */
typedef struct
{ int magic;
int height; /* number of lines in buffer */
int width; /* #characters ler line */
int first; /* first line of ring */
int last; /* last line of ring */
int caret_x; /* cursor's x-position */
int caret_y; /* its line */
int window_start; /* start line of the window */
int window_size; /* #lines on the window */
TextLine lines; /* the actual lines */
int sel_unit; /* SEL_CHAR, SEL_WORD, SEL_LINE */
int sel_org_line; /* line origin of the selection */
int sel_org_char; /* char origin of the selection */
int sel_start_line; /* starting line for selection */
int sel_start_char; /* starting char for selection */
int sel_end_line; /* ending line for selection */
int sel_end_char; /* ending char for selection */
int cmdstat; /* for parsing ANSI escape */
int argstat; /* argument status ANSI */
int argc; /* argument count for ANSI */
int argv[ANSI_MAX_ARGC]; /* argument vector for ANSI */
int scaret_x; /* saved-caret X */
int scaret_y; /* saved-caret Y */
HWND window; /* MS-Window window handle */
int has_focus; /* Application has the focus */
HFONT hfont; /* Windows font handle */
int fixedfont; /* Font is fixed */
COLORREF foreground; /* Foreground (text) color */
COLORREF background; /* Background color */
COLORREF sel_foreground; /* Selection foreground */
COLORREF sel_background; /* Selection background */
int cw; /* character width */
int ch; /* character height */
int cb; /* baseline */
int changed; /* changes to the whole screen */
int sb_lines; /* #lines the scrollbar thinks */
int sb_start; /* start-line scrollbar thinks */
int caret_is_shown; /* is caret in the window? */
TCHAR current_title[RLC_TITLE_MAX]; /* window title */
/* status */
rlc_console_attr * create_attributes; /* Creation attributes */
TCHAR *regkey_name; /* last part of key */
int win_x; /* window top-left corner */
int win_y; /* window top-left corner */
/* output queue */
TCHAR output_queue[OQSIZE]; /* The output queue */
int output_queued; /* # characters in the queue */
struct
{ TCHAR *line; /* buffered line */
size_t length; /* length of line */
size_t given; /* how much we passed */
} read_buffer;
/* input queuing */
int imode; /* input mode */
int imodeswitch; /* switching imode */
RlcQueue queue; /* input stream */
LQueued lhead; /* line-queue head */
LQueued ltail; /* line-queue tail */
TCHAR promptbuf[MAXPROMPT]; /* Buffer for building prompt */
TCHAR prompt[MAXPROMPT]; /* The prompt */
int promptlen; /* length of the prompt */
int closing; /* closing status */
int modified_options; /* OPT_ */
history history; /* history for this console */
/* Thread handles */
HANDLE console_thread; /* I/O thread */
HANDLE application_thread; /* The application I work for */
DWORD console_thread_id; /* I/O thread id */
DWORD application_thread_id;
HWND kill_window; /* window in app thread for destroy */
user_data values[MAX_USER_VALUES]; /* associated user data */
} rlc_data, *RlcData;
/*******************************
* DATA *
*******************************/
extern RlcData _rlc_stdio; /* global default console */
/*******************************
* FUNCTIONS *
*******************************/
extern void rlc_assert(const TCHAR *msg);
int rlc_at_head_history(RlcData b);
const TCHAR * rlc_bwd_history(RlcData b);
const TCHAR * rlc_fwd_history(RlcData b);
void rlc_get_mark(rlc_console c, RlcMark mark);
void rlc_goto_mark(rlc_console c, RlcMark mark,
const TCHAR *data, size_t offset);
void rlc_erase_from_caret(rlc_console c);
void rlc_putchar(rlc_console c, int chr);
TCHAR * rlc_read_screen(rlc_console c,
RlcMark from, RlcMark to);
void rlc_update(rlc_console c);
const TCHAR * rlc_prompt(rlc_console c, const TCHAR *prompt);
void rlc_clearprompt(rlc_console c);
/*******************************
* INLINE FUNCTIONS *
*******************************/
#ifdef _DEBUG
#define assert(g) if ( !(g) ) rlc_assert(_T(#g))
#else
#define assert(g) (void)0
#endif
static __inline RlcData
rlc_get_data(rlc_console c)
{ if ( c )
{ RlcData b = c;
assert(b->magic == RLC_MAGIC);
if ( b->magic == RLC_MAGIC )
{ return b;
}
return NULL;
}
return _rlc_stdio;
}

741
swi/console/edit.c Normal file
View File

@@ -0,0 +1,741 @@
/* $Id: edit.c,v 1.1 2008-03-27 00:41:33 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#define _MAKE_DLL 1
#undef _export
#include <windows.h>
#include <tchar.h>
#include "console.h"
#include "console_i.h"
#include "common.h"
#include <memory.h>
#include <string.h>
#include <ctype.h>
#ifndef EOF
#define EOF -1
#endif
typedef void (*function)(Line ln, int chr); /* edit-function */
static function dispatch_table[256]; /* general dispatch-table */
static function dispatch_meta[256]; /* ESC-char dispatch */
static RlcCompleteFunc _rlc_complete_function = rlc_complete_file_function;
static void init_line_package(RlcData b);
static void bind_actions(void);
#ifndef min
#define min(a, b) ((a) < (b) ? (a) : (b))
#define max(a, b) ((a) > (b) ? (a) : (b))
#endif
#ifndef TRUE
#define TRUE 1
#define FALSE 0
#endif
#ifndef EOS
#define EOS 0
#endif
#ifndef ESC
#define ESC 27
#endif
#define COMPLETE_NEWLINE 1
#define COMPLETE_EOF 2
#define ctrl(c) ((c) - '@')
#define META_OFFSET 128
#define meta(c) ((c) + META_OFFSET)
/*******************************
* BUFFER *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
make_room(Line, int room)
Make n-characters space after the point.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static void
make_room(Line ln, size_t room)
{ while ( ln->size + room + 1 > ln->allocated )
{ if ( !ln->data )
{ ln->data = rlc_malloc(256 * sizeof(TCHAR));
ln->allocated = 256;
} else
{ ln->allocated *= 2;
ln->data = rlc_realloc(ln->data, ln->allocated * sizeof(TCHAR));
}
}
memmove(&ln->data[ln->point + room], &ln->data[ln->point],
(ln->size - ln->point)*sizeof(TCHAR));
ln->size += room;
if ( room > 0 )
ln->change_start = min(ln->change_start, ln->point);
}
static void
set_line(Line ln, const TCHAR *s)
{ size_t len = _tcslen(s);
ln->size = ln->point = 0;
make_room(ln, len);
_tcsncpy(ln->data, s, len);
}
static void
terminate(Line ln)
{ if ( !ln->data )
{ ln->data = rlc_malloc(sizeof(TCHAR));
ln->allocated = 1;
}
ln->data[ln->size] = EOS;
}
static void
delete(Line ln, size_t from, size_t len)
{ if ( from < 0 || from > ln->size || len < 0 || from + len > ln->size )
return;
_tcsncpy(&ln->data[from], &ln->data[from+len], ln->size - (from+len));
ln->size -= len;
}
/*******************************
* POSITIONING *
*******************************/
static size_t
back_word(Line ln, size_t from)
{ from = min(from, ln->size);
from = max(0, from);
if ( ln->data )
{ while(!rlc_is_word_char(ln->data[from-1]) && from > 0 )
from--;
while(rlc_is_word_char(ln->data[from-1]) && from > 0 )
from--;
}
return from;
}
static size_t
forw_word(Line ln, size_t from)
{ from = min(from, ln->size);
from = max(0, from);
if ( ln->data )
{ while(!rlc_is_word_char(ln->data[from]) && from < ln->size )
from++;
while(rlc_is_word_char(ln->data[from]) && from < ln->size )
from++;
}
return from;
}
/*******************************
* EDITING FUNCTIONS *
*******************************/
static __inline void
changed(Line ln, size_t from)
{ ln->change_start = min(ln->change_start, from);
}
static void
insert_self(Line ln, int chr)
{ make_room(ln, 1);
ln->data[ln->point++] = chr;
}
static void
backward_delete_character(Line ln, int chr)
{ if ( ln->point > 0 )
{ memmove(&ln->data[ln->point-1], &ln->data[ln->point],
(ln->size - ln->point)*sizeof(TCHAR));
ln->size--;
ln->point--;
}
changed(ln, ln->point);
}
static void
delete_character(Line ln, int chr)
{ if ( ln->point < ln->size )
{ ln->point++;
backward_delete_character(ln, chr);
}
}
static void
backward_character(Line ln, int chr)
{ if ( ln->point > 0 )
ln->point--;
}
static void
forward_character(Line ln, int chr)
{ if ( ln->point < ln->size )
ln->point++;
}
static void
backward_word(Line ln, int chr)
{ ln->point = back_word(ln, ln->point);
}
static void
forward_word(Line ln, int chr)
{ ln->point = forw_word(ln, ln->point);
}
static void
backward_delete_word(Line ln, int chr)
{ size_t from = back_word(ln, ln->point);
memmove(&ln->data[from], &ln->data[ln->point],
(ln->size - ln->point)*sizeof(TCHAR));
ln->size -= ln->point - from;
ln->point = from;
changed(ln, from);
}
static void
forward_delete_word(Line ln, int chr)
{ size_t to = forw_word(ln, ln->point);
memmove(&ln->data[ln->point], &ln->data[to], (ln->size - to)*sizeof(TCHAR));
ln->size -= to - ln->point;
changed(ln, ln->point);
}
static void
transpose_chars(Line ln, int chr)
{ if ( ln->point > 0 && ln->point < ln->size )
{ int c0 = ln->data[ln->point-1];
ln->data[ln->point-1] = ln->data[ln->point];
ln->data[ln->point] = c0;
changed(ln, ln->point-1);
}
}
static void
start_of_line(Line ln, int chr)
{ ln->point = 0;
}
static void
end_of_line(Line ln, int chr)
{ ln->point = ln->size;
}
static void
kill_line(Line ln, int chr)
{ ln->size = ln->point;
changed(ln, ln->size);
}
static void
empty_line(Line ln, int chr)
{ ln->size = ln->point = 0;
changed(ln, 0);
}
static void
enter(Line ln, int chr)
{ ln->point = ln->size;
#ifdef DOS_CRNL
make_room(ln, 2);
ln->data[ln->point++] = '\r';
ln->data[ln->point++] = '\n';
#else
make_room(ln, 1);
ln->data[ln->point++] = '\n';
#endif
terminate(ln);
ln->complete = COMPLETE_NEWLINE;
}
static void
eof(Line ln, int chr)
{ ln->point = ln->size;
terminate(ln);
ln->complete = COMPLETE_EOF;
}
static void
delete_character_or_eof(Line ln, int chr)
{ if ( ln->size == 0 )
{ ln->point = ln->size;
terminate(ln);
ln->complete = COMPLETE_EOF;
} else
delete_character(ln, chr);
}
static void
undefined(Line ln, int chr)
{
}
static void
interrupt(Line ln, int chr)
{ raise(SIGINT);
}
/*******************************
* HISTORY *
*******************************/
static void
add_history(rlc_console c, const TCHAR *data)
{ const TCHAR *s = data;
while(*s && *s <= ' ')
s++;
if ( *s )
rlc_add_history(c, s);
}
static void
backward_history(Line ln, int chr)
{ const TCHAR *h;
if ( rlc_at_head_history(ln->console) && ln->size > 0 )
{ terminate(ln);
add_history(ln->console, ln->data);
}
if ( (h = rlc_bwd_history(ln->console)) )
{ set_line(ln, h);
ln->point = ln->size;
}
}
static void
forward_history(Line ln, int chr)
{ if ( !rlc_at_head_history(ln->console) )
{ const TCHAR *h = rlc_fwd_history(ln->console);
if ( h )
{ set_line(ln, h);
ln->point = ln->size;
}
} else
empty_line(ln, chr);
}
/*******************************
* COMPLETE *
*******************************/
RlcCompleteFunc
rlc_complete_hook(RlcCompleteFunc new)
{ RlcCompleteFunc old = _rlc_complete_function;
_rlc_complete_function = new;
return old;
}
static int
common(const TCHAR *s1, const TCHAR *s2, int insensitive)
{ int n = 0;
if ( !insensitive )
{ while(*s1 && *s1 == *s2)
{ s1++, s2++;
n++;
}
return n;
} else
{ while(*s1)
{ if ( _totlower(*s1) == _totlower(*s2) )
{ s1++, s2++;
n++;
} else
break;
}
return n;
}
}
static void
complete(Line ln, int chr)
{ if ( _rlc_complete_function )
{ rlc_complete_data dbuf;
RlcCompleteData data = &dbuf;
memset(data, 0, sizeof(dbuf));
data->line = ln;
data->call_type = COMPLETE_INIT;
if ( (*_rlc_complete_function)(data) )
{ TCHAR match[COMPLETE_MAX_WORD_LEN];
int nmatches = 1;
size_t ncommon = _tcslen(data->candidate);
size_t patlen = ln->point - data->replace_from;
_tcscpy(match, data->candidate);
data->call_type = COMPLETE_ENUMERATE;
while( (*data->function)(data) )
{ ncommon = common(match, data->candidate, data->case_insensitive);
match[ncommon] = EOS;
nmatches++;
}
data->call_type = COMPLETE_CLOSE;
(*data->function)(data);
delete(ln, data->replace_from, patlen);
ln->point = data->replace_from;
make_room(ln, ncommon);
_tcsncpy(&ln->data[data->replace_from], match, ncommon);
ln->point += ncommon;
if ( nmatches == 1 && data->quote )
insert_self(ln, data->quote);
}
}
}
#define MAX_LIST_COMPLETIONS 256
static void
list_completions(Line ln, int chr)
{ if ( _rlc_complete_function )
{ rlc_complete_data dbuf;
RlcCompleteData data = &dbuf;
memset(data, 0, sizeof(dbuf));
data->line = ln;
data->call_type = COMPLETE_INIT;
if ( (*_rlc_complete_function)(data) )
{ TCHAR *buf[COMPLETE_MAX_MATCHES];
int n, nmatches = 0;
size_t len = _tcslen(data->candidate) + 1;
size_t longest = len;
size_t cols;
buf[nmatches] = rlc_malloc(len*sizeof(TCHAR));
_tcsncpy(buf[nmatches], data->candidate, len);
nmatches++;
data->call_type = COMPLETE_ENUMERATE;
while( (*data->function)(data) )
{ len = _tcslen(data->candidate) + 1;
buf[nmatches] = rlc_malloc(len*sizeof(TCHAR));
_tcsncpy(buf[nmatches], data->candidate, len);
nmatches++;
longest = max(longest, len);
if ( nmatches > COMPLETE_MAX_MATCHES )
{ TCHAR *msg = _T("\r\n! Too many matches\r\n");
while(*msg)
rlc_putchar(ln->console, *msg++);
ln->reprompt = TRUE;
data->call_type = COMPLETE_CLOSE;
(*data->function)(data);
return;
}
}
data->call_type = COMPLETE_CLOSE;
(*data->function)(data);
cols = ScreenCols(ln->console) / longest;
rlc_putchar(ln->console, '\r');
rlc_putchar(ln->console, '\n');
for(n=0; n<nmatches; )
{ TCHAR *s = buf[n];
len = 0;
while(*s)
{ len++;
rlc_putchar(ln->console, *s++);
}
rlc_free(buf[n++]);
if ( n % cols == 0 )
{ rlc_putchar(ln->console, '\r');
rlc_putchar(ln->console, '\n');
} else
{ while( len++ < longest )
rlc_putchar(ln->console, ' ');
}
}
if ( nmatches % cols != 0 )
{ rlc_putchar(ln->console, '\r');
rlc_putchar(ln->console, '\n');
}
ln->reprompt = TRUE;
}
}
}
/*******************************
* REPAINT *
*******************************/
static void
output(rlc_console b, TCHAR *s, size_t len)
{ while(len-- > 0)
{ if ( *s == '\n' )
rlc_putchar(b, '\r');
rlc_putchar(b, *s++);
}
}
static void
update_display(Line ln)
{ if ( ln->reprompt )
{ const TCHAR *prompt = rlc_prompt(ln->console, NULL);
const TCHAR *s = prompt;
rlc_putchar(ln->console, '\r');
while(*s)
rlc_putchar(ln->console, *s++);
rlc_get_mark(ln->console, &ln->origin);
ln->change_start = 0;
ln->reprompt = FALSE;
}
rlc_goto_mark(ln->console, &ln->origin, ln->data, ln->change_start);
output(ln->console,
&ln->data[ln->change_start], ln->size - ln->change_start);
rlc_erase_from_caret(ln->console);
rlc_goto_mark(ln->console, &ln->origin, ln->data, ln->point);
rlc_update(ln->console);
ln->change_start = ln->size;
}
/*******************************
* TOPLEVEL *
*******************************/
TCHAR *
read_line(rlc_console b)
{ line ln;
init_line_package(b);
memset(&ln, 0, sizeof(line));
ln.console = b;
rlc_get_mark(b, &ln.origin);
while(!ln.complete)
{ int c;
rlc_mark m0, m1;
function func;
rlc_get_mark(b, &m0);
if ( (c = getch(b)) == IMODE_SWITCH_CHAR )
return RL_CANCELED_CHARP;
if ( c == EOF )
{ eof(&ln, c);
update_display(&ln);
break;
} else if ( c == ESC )
{ if ( (c = getch(b)) == IMODE_SWITCH_CHAR )
return RL_CANCELED_CHARP;
if ( c > 256 )
func = undefined;
else
func = dispatch_meta[c&0xff];
} else
{ if ( c >= 256 )
func = insert_self;
else
func = dispatch_table[c&0xff];
}
rlc_get_mark(b, &m1);
(*func)(&ln, c);
if ( m0.mark_x != m1.mark_x || m0.mark_y != m1.mark_y )
ln.reprompt = TRUE;
update_display(&ln);
}
rlc_clearprompt(b);
add_history(b, ln.data);
return ln.data;
}
/*******************************
* DISPATCH *
*******************************/
static void
init_dispatch_table()
{ static int done;
if ( !done )
{ int n;
for(n=0; n<32; n++)
dispatch_table[n] = undefined;
for(n=32; n<256; n++)
dispatch_table[n] = insert_self;
for(n=0; n<256; n++)
dispatch_meta[n] = undefined;
bind_actions();
done = TRUE;
}
}
static void
init_line_package(RlcData b)
{ init_dispatch_table();
rlc_init_history(b, 50);
}
/*******************************
* BIND *
*******************************/
typedef struct _action
{ char *name;
function function;
unsigned char keys[4];
} action, *Action;
#define ACTION(n, f, k) { n, f, k }
static action actions[] = {
ACTION("insert_self", insert_self, ""),
ACTION("backward_delete_character", backward_delete_character, "\b"),
ACTION("complete", complete, "\t"),
ACTION("enter", enter, "\r\n"),
ACTION("start_of_line", start_of_line, {ctrl('A')}),
ACTION("backward_character", backward_character, {ctrl('B')}),
ACTION("interrupt", interrupt, {ctrl('C')}),
ACTION("end_of_line", end_of_line, {ctrl('E')}),
ACTION("forward_character", forward_character, {ctrl('F')}),
ACTION("transpose_chars", transpose_chars, {ctrl('T')}),
ACTION("kill_line", kill_line, {ctrl('K')}),
ACTION("backward_history", backward_history, {ctrl('P')}),
ACTION("forward_history", forward_history, {ctrl('N')}),
ACTION("empty_line", empty_line, {ctrl('U')}),
ACTION("eof", eof, {ctrl('Z')}),
ACTION("delete_character_or_eof", delete_character_or_eof, {ctrl('D')}),
ACTION("delete_character", delete_character, {127}),
{ "forward_word", forward_word, {meta(ctrl('F')), meta('f')}},
{ "backward_word", backward_word, {meta(ctrl('B')), meta('b')}},
{ "forward_delete_word", forward_delete_word, {meta(127), meta('d')}},
ACTION("list_completions", list_completions, {meta('?')}),
ACTION("backward_delete_word", backward_delete_word, {meta('\b')}),
ACTION(NULL, NULL, "")
};
int
rlc_bind(int chr, const char *fname)
{ if ( chr >= 0 && chr <= 256 )
{ Action a = actions;
for( ; a->name; a++ )
{ if ( strcmp(a->name, fname) == 0 )
{ if ( chr > META_OFFSET )
dispatch_meta[chr-META_OFFSET] = a->function;
else
dispatch_table[chr] = a->function;
return TRUE;
}
}
}
return FALSE;
}
static void
bind_actions()
{ Action a = actions;
for( ; a->name; a++ )
{ unsigned char *k = a->keys;
for( ; *k; k++ )
{ int chr = *k & 0xff;
if ( chr > META_OFFSET )
dispatch_meta[chr-META_OFFSET] = a->function;
else
dispatch_table[chr] = a->function;
}
}
}

160
swi/console/history.c Normal file
View File

@@ -0,0 +1,160 @@
/* $Id: history.c,v 1.1 2008-03-27 00:41:33 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#define _MAKE_DLL 1
#undef _export
#include <windows.h>
#include <tchar.h>
#include "console.h" /* public stuff */
#include "console_i.h" /* internal stuff */
#include <string.h>
#ifndef TRUE
#define TRUE 1
#define FALSE 0
#endif
static __inline int
next(RlcData b, int i)
{ if ( ++i == b->history.size )
return 0;
return i;
}
static __inline int
prev(RlcData b, int i)
{ if ( --i < 0 )
return b->history.size-1;
return i;
}
void
rlc_init_history(rlc_console c, int size)
{ RlcData b = rlc_get_data(c);
int oldsize;
int i;
if ( b->history.lines )
{ b->history.lines = rlc_realloc(b->history.lines, sizeof(TCHAR *) * size);
oldsize = b->history.size;
} else
{ b->history.lines = rlc_malloc(sizeof(TCHAR *) * size);
oldsize = 0;
}
for(i=oldsize; i<size; i++)
b->history.lines[i] = NULL;
b->history.size = size;
b->history.current = -1;
}
void
rlc_add_history(rlc_console c, const TCHAR *line)
{ RlcData b = rlc_get_data(c);
if ( b->history.size )
{ int i = next(b, b->history.head);
size_t len = _tcslen(line);
while(*line && *line <= ' ') /* strip leading white-space */
line++;
len = _tcslen(line);
/* strip trailing white-space */
while ( len > 0 && line[len-1] <= ' ' )
len--;
if ( len == 0 )
{ b->history.current = -1;
return;
}
if ( b->history.lines[b->history.head] &&
_tcsncmp(b->history.lines[b->history.head], line, len) == 0 )
{ b->history.current = -1;
return; /* same as last line added */
}
if ( i == b->history.tail ) /* this one is lost */
b->history.tail = next(b, b->history.tail);
b->history.head = i;
b->history.current = -1;
if ( b->history.lines[i] )
b->history.lines[i] = rlc_realloc(b->history.lines[i],
(len+1)*sizeof(TCHAR));
else
b->history.lines[i] = rlc_malloc((len+1)*sizeof(TCHAR));
if ( b->history.lines[i] )
{ _tcsncpy(b->history.lines[i], line, len);
b->history.lines[i][len] = '\0';
}
}
}
int
rlc_at_head_history(RlcData b)
{ return b->history.current == -1 ? TRUE : FALSE;
}
const TCHAR *
rlc_bwd_history(RlcData b)
{ if ( b->history.size )
{ if ( b->history.current == -1 )
b->history.current = b->history.head;
else if ( b->history.current == b->history.tail )
return NULL;
else
b->history.current = prev(b, b->history.current);
return b->history.lines[b->history.current];
}
return NULL;
}
const TCHAR *
rlc_fwd_history(RlcData b)
{ if ( b->history.size && b->history.current != -1 )
{ const TCHAR *s;
b->history.current = next(b, b->history.current);
s = b->history.lines[b->history.current];
if ( b->history.current == b->history.head )
b->history.current = -1;
return s;
}
return NULL;
}

30
swi/console/history.h Normal file
View File

@@ -0,0 +1,30 @@
/* $Id: history.h,v 1.1 2008-04-01 08:52:50 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
/* history.c */
void rlc_init_history(int auto_add, int size);
void rlc_add_history(const TCHAR *line);
int rlc_at_head_history(void);
const TCHAR * rlc_bwd_history(void);
const TCHAR * rlc_fwd_history(void);

299
swi/console/menu.c Normal file
View File

@@ -0,0 +1,299 @@
/* $Id: menu.c,v 1.1 2008-03-27 00:41:33 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#include <windows.h>
#include <tchar.h>
#define _MAKE_DLL
#include "console.h"
#include "console_i.h"
#include "menu.h"
#ifndef EOS
#define EOS 0
#endif
#define streq(s,q) (_tcscmp((s), (q)) == 0)
static TCHAR **menuids;
static int nmenus;
static int nmenualloc;
static struct rl_item
{ UINT id;
const TCHAR *name;
} rl_items[] =
{ { IDM_EXIT, _T("&Exit") },
{ IDM_CUT, _T("&Cut") },
{ IDM_COPY, _T("&Copy") },
{ IDM_PASTE, _T("&Paste") },
{ IDM_BREAK, _T("&Interrupt") },
{ IDM_FONT, _T("&Font ...") },
{ 0, NULL }
};
static UINT
lookupMenuLabel(const TCHAR *label)
{ int i;
size_t llen;
struct rl_item *builtin;
for(builtin = rl_items; builtin->id; builtin++)
{ if ( streq(builtin->name, label) )
return builtin->id;
}
for(i=0; i<nmenus; i++)
{ if ( streq(menuids[i], label) )
return i + IDM_USER;
}
if ( nmenus + 1 > nmenualloc )
{ if ( nmenualloc )
{ nmenualloc *= 2;
menuids = rlc_realloc(menuids, nmenualloc*sizeof(TCHAR *));
} else
{ nmenualloc = 32;
menuids = rlc_malloc(nmenualloc*sizeof(TCHAR *));
}
}
llen = _tcslen(label);
menuids[nmenus] = rlc_malloc((llen+1)*sizeof(TCHAR));
_tcsncpy(menuids[nmenus], label, llen+1);
return nmenus++ + IDM_USER;
}
const TCHAR *
lookupMenuId(UINT id)
{ struct rl_item *builtin;
if ( id >= IDM_USER && (int)id - IDM_USER < nmenus )
return menuids[id-IDM_USER];
for(builtin = rl_items; builtin->id; builtin++)
{ if ( builtin->id == id )
return builtin->name;
}
return NULL;
}
int
insertMenu(HMENU in, const TCHAR *label, const TCHAR *before)
{ if ( !before )
{ if ( !label )
AppendMenu(in, MF_SEPARATOR, 0, NULL);
else
{ UINT id = lookupMenuLabel(label);
AppendMenu(in, MF_STRING, id, label);
}
} else
{ UINT bid = lookupMenuLabel(before);
MENUITEMINFO info;
memset(&info, 0, sizeof(info));
info.cbSize = sizeof(info);
info.fMask = MIIM_TYPE;
if ( label )
{ info.fType = MFT_STRING;
info.fMask |= MIIM_ID;
info.wID = lookupMenuLabel(label);
info.dwTypeData = (TCHAR *)label;
info.cch = (int)_tcslen(label);
} else
{ info.fType = MFT_SEPARATOR;
}
InsertMenuItem(in, bid, FALSE, &info);
}
return TRUE;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Find popup with given name.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static HMENU
findPopup(RlcData b, const TCHAR *name, int *pos)
{ HMENU mb = GetMenu(rlc_hwnd(b));
if ( mb )
{ int i;
MENUITEMINFO info;
memset(&info, 0, sizeof(info));
info.cbSize = sizeof(info);
info.fMask = MIIM_TYPE;
for(i=0; ; i++)
{ MENUITEMINFO info;
TCHAR nbuf[MAXLABELLEN];
memset(&info, 0, sizeof(info));
info.cbSize = sizeof(info);
info.fMask = MIIM_TYPE|MIIM_SUBMENU;
info.dwTypeData = nbuf;
info.cch = sizeof(nbuf);
if ( !GetMenuItemInfo(mb, i, TRUE, &info) )
return NULL;
if ( info.fType == MF_STRING )
{ if ( streq(name, nbuf) )
{ if ( pos )
*pos = i;
return info.hSubMenu;
}
}
}
}
return 0;
}
static void
append_builtin(HMENU menu, UINT id)
{ AppendMenu(menu, MF_STRING, id, lookupMenuId(id));
}
void
rlc_add_menu_bar(HWND cwin)
{ HMENU menu = CreateMenu();
HMENU file = CreatePopupMenu();
HMENU edit = CreatePopupMenu();
HMENU settings = CreatePopupMenu();
HMENU run = CreatePopupMenu();
append_builtin(file, IDM_EXIT);
/*append_builtin(edit, IDM_CUT);*/
append_builtin(edit, IDM_COPY);
append_builtin(edit, IDM_PASTE);
append_builtin(settings, IDM_FONT);
append_builtin(run, IDM_BREAK);
AppendMenu(menu, MF_POPUP, (UINT)file, _T("&File"));
AppendMenu(menu, MF_POPUP, (UINT)edit, _T("&Edit"));
AppendMenu(menu, MF_POPUP, (UINT)settings, _T("&Settings"));
AppendMenu(menu, MF_POPUP, (UINT)run, _T("&Run"));
SetMenu(cwin, menu);
}
/*******************************
* EXTERNAL *
*******************************/
#define MEN_MAGIC 0x6c4a58e0
void
rlc_menu_action(rlc_console c, menu_data *data)
{ RlcData b = rlc_get_data(c);
if ( !data || !data->magic == MEN_MAGIC )
return;
if ( data->menu ) /* rlc_insert_menu_item() */
{ HMENU popup;
if ( (popup = findPopup(b, data->menu, NULL)) )
data->rc = insertMenu(popup, data->label, data->before);
else
data->rc = FALSE;
} else /* insert_menu() */
{ HMENU mb;
HWND hwnd = rlc_hwnd(c);
if ( !(mb = GetMenu(hwnd)) )
{ data->rc = FALSE;
return;
}
if ( !findPopup(b, data->label, NULL) ) /* already there */
{ MENUITEMINFO info;
int bid = -1;
if ( data->before )
findPopup(b, data->before, &bid);
memset(&info, 0, sizeof(info));
info.cbSize = sizeof(info);
info.fMask = MIIM_TYPE|MIIM_SUBMENU;
info.fType = MFT_STRING;
info.hSubMenu = CreatePopupMenu();
info.dwTypeData = (TCHAR *)data->label;
info.cch = (int)_tcslen(data->label);
InsertMenuItem(mb, bid, TRUE, &info);
/* force redraw; not automatic! */
DrawMenuBar(hwnd);
}
data->rc = TRUE;
}
}
int
rlc_insert_menu(rlc_console c, const TCHAR *label, const TCHAR *before)
{ HWND hwnd = rlc_hwnd(c);
menu_data data;
data.magic = MEN_MAGIC;
data.menu = NULL;
data.label = label;
data.before = before;
SendMessage(hwnd, WM_RLC_MENU, 0, (LPARAM)&data);
return data.rc;
}
int
rlc_insert_menu_item(rlc_console c,
const TCHAR *menu, const TCHAR *label, const TCHAR *before)
{ HWND hwnd = rlc_hwnd(c);
menu_data data;
data.magic = MEN_MAGIC;
data.menu = menu;
data.label = label;
data.before = before;
SendMessage(hwnd, WM_RLC_MENU, 0, (LPARAM)&data);
return data.rc;
}

49
swi/console/menu.h Normal file
View File

@@ -0,0 +1,49 @@
/* $Id: menu.h,v 1.1 2008-04-01 08:50:44 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
/* see also console.c */
#define WM_RLC_MENU WM_USER+15 /* Insert a menu */
#define IDM_USER 100 /* reserve below 100 */
#define MAXLABELLEN 256 /* max length of menu-item label */
#define IDM_EXIT 10
#define IDM_CUT 11
#define IDM_COPY 12
#define IDM_PASTE 13
#define IDM_BREAK 14
#define IDM_FONT 15
typedef struct menu_data
{ intptr_t magic; /* safety */
const TCHAR *menu; /* menu to operate on */
const TCHAR *label; /* new label */
const TCHAR *before; /* add before this one */
int rc; /* result */
} menu_data;
const TCHAR *lookupMenuId(UINT id);
void rlc_add_menu_bar(HWND win);
void rlc_menu_action(rlc_console c, struct menu_data *data);

89
swi/console/registry.c Normal file
View File

@@ -0,0 +1,89 @@
/* $Id: registry.c,v 1.1 2008-03-27 00:41:33 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.
This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*/
#include <windows.h>
#include "registry.h"
#define MAXKEYLEN 256
#define MAXKEYPATHLEN 1024
static TCHAR _rlc_regbase[MAXKEYPATHLEN] = TEXT("current_user/PrologConsole");
static HKEY
reg_open_key(const TCHAR *path, HKEY parent, REGSAM access)
{ TCHAR buf[MAXKEYLEN];
TCHAR *sep;
if ( *path )
return parent;
for(sep = path; *sep && *sep != '/' && *sep != '\\'; sep++)
;
strncpy(buf, path, sep-path);
if ( *sep )
sep++;
if ( strchr(sep, '/') || strchr(sep, '\\') ) /* there is more */
{ HKEY sub;
if ( RegOpenKeyEx(parent, buf, 0L, KEY_READ, &sub) != ERROR_SUCCESS )
return NULL;
return reg_open_key(sep, sub, access);
} else
{ HKEY sub;
if ( RegOpenKeyEx(parent, buf, 0L, KEY_READ, access) != ERROR_SUCCESS )
return NULL;
return sub;
}
}
HKEY
RegOpenKeyFromPath(const TCHAR *path, REGSAM access)
{ TCHAR buf[MAXKEYLEN];
TCHAR *sep;
HKEY root;
for(sep = path; *sep && *sep != '/' && *sep != '\\'; sep++)
;
strncpy(buf, path, sep-path);
if ( streq(buf, TEXT("classes_root")) )
root = HKEY_CLASSES_ROOT;
else if ( streq(buf, TEXT("current_user")) )
root = HKEY_CURRENT_USER;
else if ( streq(buf, TEXT("local_machine")) )
root = HKEY_LOCAL_MACHINE;
else if ( streq(buf, TEXT("users")) )
root = HKEY_USERS;
else
return NULL;
if ( *sep )
sep++;
return reg_open_key(sep, root, REGSAM);
}

64
swi/library/Makefile.in Normal file
View File

@@ -0,0 +1,64 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for binary libraries
#
LIBDIR=@libdir@/Yap
#
# where YAP should look for architecture-independent Prolog libraries
#
SHAREDIR=$(ROOTDIR)/share
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
YAP_EXTRAS=@YAP_EXTRAS@
PROGRAMS= \
$(srcdir)/aggregate.pl \
$(srcdir)/base64.pl \
$(srcdir)/broadcast.pl \
$(srcdir)/ctypes.pl \
$(srcdir)/date.pl \
$(srcdir)/debug.pl \
$(srcdir)/error.pl \
$(srcdir)/main.pl \
$(srcdir)/maplist.pl \
$(srcdir)/menu.pl \
$(srcdir)/nb_set.pl \
$(srcdir)/occurs.yap \
$(srcdir)/operators.pl \
$(srcdir)/option.pl \
$(srcdir)/pairs.pl \
$(srcdir)/predicate_options.pl \
$(srcdir)/predopts.pl \
$(srcdir)/prolog_clause.pl \
$(srcdir)/prolog_colour.pl \
$(srcdir)/prolog_source.pl \
$(srcdir)/prolog_xref.pl \
$(srcdir)/quintus.pl \
$(srcdir)/readutil.pl \
$(srcdir)/record.pl \
$(srcdir)/settings.pl \
$(srcdir)/shlib.pl \
$(srcdir)/thread_pool.pl \
$(srcdir)/url.pl \
$(srcdir)/utf8.pl \
$(srcdir)/win_menu.pl \
$(srcdir)/www_browser.pl
install: $(PROGRAMS)
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap; done

544
swi/library/aggregate.pl Normal file
View File

@@ -0,0 +1,544 @@
/* $Id: aggregate.pl,v 1.4 2008-07-22 23:34:49 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2008, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(aggretate,
[ foreach/2, % :Generator, :Goal
aggregate/3, % +Templ, :Goal, -Result
aggregate/4, % +Templ, +Discrim, :Goal, -Result
aggregate_all/3, % +Templ, :Goal, -Result
aggregate_all/4, % +Templ, +Discrim, :Goal, -Result
free_variables/4 % :Generator, :Template, +Vars0, -Vars
]).
:- use_module(library(ordsets)).
:- use_module(library(pairs)).
:- use_module(library(error)).
:- use_module(library(lists)).
:- meta_predicate
foreach(0,0),
aggregate(?,0,-),
aggregate(?,?,0,-),
aggregate_all(?,0,-),
aggregate_all(?,?,0,-).
/** <module> Aggregation operators on backtrackable predicates
This library provides aggregating operators over the solutions of a
predicate. The operations are a generalisation of the bagof/3, setof/3
and findall/3 built-in predicates. The defined aggregation operations
are counting, computing the sum, minimum, maximum, a bag of solutions
and a set of solutions. We first give a simple example, computing the
country with the smallest area:
==
average_country_area(Name, Area) :-
aggregate(min(A, N), country(N, A), min(Area, Name)).
==
There are four aggregation predicates, distinguished on two properties.
$ aggregate vs. aggregate_all :
The aggregate predicates use setof/3 (aggregate/4) or bagof/3
(aggregate/3), dealing with existential qualified variables
(Var^Goal) and providing multiple solutions for the remaining free
variables in Goal. The aggregate_all/3 predicate uses findall/3,
implicitely qualifying all free variables and providing exactly one
solution, while aggregate_all/4 uses sort/2 over solutions and
Distinguish (see below) generated using findall/3.
$ The Distinguish argument :
The versions with 4 arguments provide a Distinguish argument that
allow for keeping duplicate bindings of a variable in the result.
For example, if we wish to compute the total population of all
countries we do not want to loose results because two countries
have the same population. Therefore we use:
==
aggregate(sum(P), Name, country(Name, P), Total)
==
All aggregation predicates support the following operator below in
Template. In addition, they allow for an arbitrary named compound term
where each of the arguments is a term from the list below. I.e. the term
r(min(X), max(X)) computes both the minimum and maximum binding for X.
* count
Count number of solutions. Same as sum(1).
* sum(Expr)
Sum of Expr for all solutions.
* min(Expr)
Minimum of Expr for all solutions.
* min(Expr, Witness)
A term min(Min, Witness), where Min is the minimal version
of Expr over all Solution and Witness is any other template
the applied to the solution that produced Min. If multiple
solutions provide the same minimum, Witness corresponds to
the first solution.
* max(Expr)
Maximum of Expr for all solutions.
* max(Expr, Witness)
As min(Expr, Witness), but producing the maximum result.
* set(X)
An ordered set with all solutions for X.
* bag(X)
A list of all solutions for X.
---+++ Acknowledgements
_|The development of this library was sponsored by SecuritEase,
http://www.securitease.com
|_
@compat Quintus, SICStus 4. The forall/2 is a SWI-Prolog built-in and
term_variables/3 is a SWI-Prolog with a *|different definition|*.
@tbd Analysing the aggregation template and compiling a predicate
for the list aggregation can be done at compile time.
@tbd aggregate_all/3 can be rewritten to run in constant space using
non-backtrackable assignment on a term.
*/
/*******************************
* AGGREGATE *
*******************************/
%% aggregate(+Template, :Goal, -Result) is nondet.
%
% Aggregate bindings in Goal according to Template. The aggregate/3
% version performs bagof/3 on Goal.
aggregate(Template, Goal0, Result) :-
template_to_pattern(bag, Template, Pattern, Goal0, Goal, Aggregate),
bagof(Pattern, Goal, List),
aggregate_list(Aggregate, List, Result).
%% aggregate(+Template, +Discriminator, :Goal, -Result) is nondet.
%
% Aggregate bindings in Goal according to Template. The aggregate/3
% version performs setof/3 on Goal.
aggregate(Template, Discriminator, Goal0, Result) :-
template_to_pattern(bag, Template, Pattern, Goal0, Goal, Aggregate),
setof(Discriminator-Pattern, Goal, Pairs),
pairs_values(Pairs, List),
aggregate_list(Aggregate, List, Result).
%% aggregate_all(+Template, :Goal, -Result) is semidet.
%
% Aggregate bindings in Goal according to Template. The aggregate_all/3
% version performs findall/3 on Goal.
aggregate_all(Template, Goal0, Result) :-
template_to_pattern(all, Template, Pattern, Goal0, Goal, Aggregate),
findall(Pattern, Goal, List),
aggregate_list(Aggregate, List, Result).
%% aggregate_all(+Template, +Discriminator, :Goal, -Result) is semidet.
%
% Aggregate bindings in Goal according to Template. The aggregate_all/3
% version performs findall/3 followed by sort/2 on Goal.
aggregate_all(Template, Discriminator, Goal0, Result) :-
template_to_pattern(all, Template, Pattern, Goal0, Goal, Aggregate),
findall(Discriminator-Pattern, Goal, Pairs0),
sort(Pairs0, Pairs),
pairs_values(Pairs, List),
aggregate_list(Aggregate, List, Result).
template_to_pattern(_All, Template, Pattern, Goal0, Goal, Aggregate) :-
template_to_pattern(Template, Pattern, Post, Vars, Aggregate),
existential_vars(Goal0, Goal1, AllVars, Vars),
clean_body((Goal1, Post), Goal2),
add_existential_vars(AllVars, Goal2, Goal).
existential_vars(Var, Var) -->
{ var(Var) }, !.
existential_vars(Var^G0, G) --> !,
[Var],
existential_vars(G0, G).
existential_vars(G, G) -->
[].
add_existential_vars([], G, G).
add_existential_vars([H|T], G0, H^G1) :-
add_existential_vars(T, G0, G1).
%% clean_body(+Goal0, -Goal) is det.
%
% Remove redundant =true= from Goal0.
clean_body((Goal0,Goal1), Goal) :- !,
clean_body(Goal0, GoalA),
clean_body(Goal1, GoalB),
( GoalA == true
-> Goal = GoalB
; GoalB == true
-> Goal = GoalA
; Goal = (GoalA,GoalB)
).
clean_body(Goal, Goal).
%% template_to_pattern(+Template, -Pattern, -Post, -Vars, -Agregate)
%
% Determine which parts of the goal we must remember in the
% findall/3 pattern.
%
% @param Post is a body-term that evaluates expressions to reduce
% storage requirements.
% @param Vars is a list of intermediate variables that must be
% added to the existential variables for bagof/3.
% @param Agregate defines the aggregation operation to execute.
template_to_pattern(sum(X), X, true, [], sum) :- var(X), !.
template_to_pattern(sum(X0), X, X is X0, [X0], sum) :- !.
template_to_pattern(count, 1, true, [], count) :- !.
template_to_pattern(min(X), X, true, [], min) :- var(X), !.
template_to_pattern(min(X0), X, X is X0, [X0], min) :- !.
template_to_pattern(min(X0, Witness), X-Witness, X is X0, [X0], min_witness) :- !.
template_to_pattern(max(X0), X, X is X0, [X0], max) :- !.
template_to_pattern(max(X0, Witness), X-Witness, X is X0, [X0], max_witness) :- !.
template_to_pattern(set(X), X, true, [], set) :- !.
template_to_pattern(bag(X), X, true, [], bag) :- !.
template_to_pattern(Term, Pattern, Goal, Vars, term(MinNeeded, Functor, AggregateArgs)) :-
compound(Term), !,
Term =.. [Functor|Args0],
templates_to_patterns(Args0, Args, Goal, Vars, AggregateArgs),
needs_one(AggregateArgs, MinNeeded),
Pattern =.. [Functor|Args].
template_to_pattern(Term, _, _, _, _) :-
type_error(aggregate_template, Term).
templates_to_patterns([], [], true, [], []).
templates_to_patterns([H0], [H], G, Vars, [A]) :- !,
template_to_pattern(H0, H, G, Vars, A).
templates_to_patterns([H0|T0], [H|T], (G0,G), Vars, [A0|A]) :-
template_to_pattern(H0, H, G0, V0, A0),
append(V0, RV, Vars),
templates_to_patterns(T0, T, G, RV, A).
%% needs_one(+Ops, -OneOrZero)
%
% If one of the operations in Ops needs at least one answer,
% unify OneOrZero to 1. Else 0.
needs_one(Ops, 1) :-
member(Op, Ops),
needs_one(Op), !.
needs_one(_, 0).
needs_one(min).
needs_one(min_witness).
needs_one(max).
needs_one(max_witness).
%% aggregate_list(+Op, +List, -Answer) is semidet.
%
% Aggregate the answer from the list produced by findall/3,
% bagof/3 or setof/3. The latter two cases deal with compound
% answers.
%
% @tbd Compile code for incremental state update, which we will use
% for aggregate_all/3 as well. We should be using goal_expansion
% to generate these clauses.
aggregate_list(bag, List0, List) :- !,
List = List0.
aggregate_list(set, List, Set) :- !,
sort(List, Set).
aggregate_list(sum, List, Sum) :-
sumlist(List, Sum).
aggregate_list(count, List, Count) :-
length(List, Count).
aggregate_list(max, List, Sum) :-
max_list(List, Sum).
aggregate_list(max_witness, List, max(Max, Witness)) :-
max_pair(List, Max, Witness).
aggregate_list(min, List, Sum) :-
min_list(List, Sum).
aggregate_list(min_witness, List, min(Min, Witness)) :-
min_pair(List, Min, Witness).
aggregate_list(term(0, Functor, Ops), List, Result) :- !,
maplist(state0, Ops, StateArgs, FinishArgs),
State0 =.. [Functor|StateArgs],
aggregate_term_list(List, Ops, State0, Result0),
finish_result(Ops, FinishArgs, Result0, Result).
aggregate_list(term(1, Functor, Ops), [H|List], Result) :-
H =.. [Functor|Args],
maplist(state1, Ops, Args, StateArgs, FinishArgs),
State0 =.. [Functor|StateArgs],
aggregate_term_list(List, Ops, State0, Result0),
finish_result(Ops, FinishArgs, Result0, Result).
aggregate_term_list([], _, State, State).
aggregate_term_list([H|T], Ops, State0, State) :-
step_term(Ops, H, State0, State1),
aggregate_term_list(T, Ops, State1, State).
%% min_pair(+Pairs, -Key, -Value) is det.
%% max_pair(+Pairs, -Key, -Value) is det.
%
% True if Key-Value has the smallest/largest key in Pairs. If
% multiple pairs share the smallest/largest key, the first pair is
% returned.
min_pair([M0-W0|T], M, W) :-
min_pair(T, M0, W0, M, W).
min_pair([], M, W, M, W).
min_pair([M0-W0|T], M1, W1, M, W) :-
( M0 > M1
-> min_pair(T, M0, W0, M, W)
; min_pair(T, M1, W1, M, W)
).
max_pair([M0-W0|T], M, W) :-
max_pair(T, M0, W0, M, W).
max_pair([], M, W, M, W).
max_pair([M0-W0|T], M1, W1, M, W) :-
( M0 > M1
-> max_pair(T, M0, W0, M, W)
; max_pair(T, M1, W1, M, W)
).
%% step(+AggregateAction, +New, +State0, -State1).
step(bag, X, [X|L], L).
step(set, X, [X|L], L).
step(count, _, X0, X1) :-
succ(X0, X1).
step(sum, X, X0, X1) :-
X1 is X0+X.
step(max, X, X0, X1) :-
X1 is max(X0, X).
step(min, X, X0, X1) :-
X1 is min(X0, X).
step(max_witness, X-W, X0-W0, X1-W1) :-
( X > X0
-> X1 = X, W1 = W
; X1 = X0, W1 = W0
).
step(min_witness, X-W, X0-W0, X1-W1) :-
( X < X0
-> X1 = X, W1 = W
; X1 = X0, W1 = W0
).
step(term(Ops), Row, Row0, Row1) :-
step_term(Ops, Row, Row0, Row1).
step_term(Ops, Row, Row0, Row1) :-
functor(Row, Name, Arity),
functor(Row1, Name, Arity),
step_list(Ops, 1, Row, Row0, Row1).
step_list([], _, _, _, _).
step_list([Op|OpT], Arg, Row, Row0, Row1) :-
arg(Arg, Row, X),
arg(Arg, Row0, X0),
arg(Arg, Row1, X1),
step(Op, X, X0, X1),
succ(Arg, Arg1),
step_list(OpT, Arg1, Row, Row0, Row1).
finish_result(Ops, Finish, R0, R) :-
functor(R0, Functor, Arity),
functor(R, Functor, Arity),
finish_result(Ops, Finish, 1, R0, R).
finish_result([], _, _, _, _).
finish_result([Op|OpT], [F|FT], I, R0, R) :-
arg(I, R0, A0),
arg(I, R, A),
finish_result1(Op, F, A0, A),
succ(I, I2),
finish_result(OpT, FT, I2, R0, R).
finish_result1(bag, Bag0, [], Bag) :- !,
Bag = Bag0.
finish_result1(set, Bag, [], Set) :- !,
sort(Bag, Set).
finish_result1(max_witness, _, M-W, R) :- !,
R = max(M,W).
finish_result1(min_witness, _, M-W, R) :- !,
R = min(M,W).
finish_result1(_, _, A, A).
%% state0(+Op, -State, -Finish)
state0(bag, L, L).
state0(set, L, L).
state0(count, 0, _).
state0(sum, 0, _).
%% state1(+Op, +First, -State, -Finish)
state1(bag, X, [X|L], L).
state1(set, X, [X|L], L).
state1(_, X, X, _).
/*******************************
* FOREACH *
*******************************/
%% foreach(:Generator, :Goal)
%
% True if the conjunction of instances of Goal using the bindings
% from Generator is true. Unlike forall/2, which runs a
% failure-driven loop that proves Goal for each solution of
% Generator, foreach creates a conjunction. Each member of the
% conjunction is a copy of Goal, where the variables it shares
% with Generator are filled with the values from the corresponding
% solution.
%
% The implementation executes forall/2 if Goal does not contain
% any variables that are not shared with Generator.
%
% Here is an example:
%
% ==
% ?- foreach(between(1,4,X), dif(X,Y)), Y = 5.
% Y = 5
% ?- foreach(between(1,4,X), dif(X,Y)), Y = 3.
% No
% ==
%
% @bug Goal is copied repeatetly, which may cause problems if
% attributed variables are involved.
foreach(Generator, Goal0) :-
strip_module(Goal0, M, G),
Goal = M:G,
term_variables(Generator, GenVars0), sort(GenVars0, GenVars),
term_variables(Goal, GoalVars0), sort(GoalVars0, GoalVars),
ord_subtract(GoalVars, GenVars, SharedGoalVars),
( SharedGoalVars == []
-> \+ (Generator, \+Goal) % = forall(Generator, Goal)
; ord_intersection(GenVars, GoalVars, SharedVars),
Templ =.. [v|SharedVars],
SharedTempl =.. [v|SharedGoalVars],
findall(Templ, Generator, List),
prove_list(List, Templ, SharedTempl, Goal)
).
prove_list([], _, _, _).
prove_list([H|T], Templ, SharedTempl, Goal) :-
copy_term(Templ+SharedTempl+Goal,
H+SharedTempl+Copy),
Copy,
prove_list(T, Templ, SharedTempl, Goal).
%% free_variables(:Generator, +Template, +VarList0, -VarList) is det.
%
% In order to handle variables properly, we have to find all the
% universally quantified variables in the Generator. All variables
% as yet unbound are universally quantified, unless
%
% 1. they occur in the template
% 2. they are bound by X^P, setof, or bagof
%
% free_variables(Generator, Template, OldList, NewList) finds this
% set, using OldList as an accumulator.
%
% @author Richard O'Keefe
% @author Jan Wielemaker (made some SWI-Prolog enhancements)
% @license Public domain (from DEC10 library).
% @tbd Distinguish between control-structures and data terms.
% @tbd Exploit our built-in term_variables/2 at some places?
free_variables(Term, Bound, VarList, [Term|VarList]) :-
var(Term),
term_is_free_of(Bound, Term),
list_is_free_of(VarList, Term), !.
free_variables(Term, _Bound, VarList, VarList) :-
var(Term), !.
free_variables(Term, Bound, OldList, NewList) :-
explicit_binding(Term, Bound, NewTerm, NewBound), !,
free_variables(NewTerm, NewBound, OldList, NewList).
free_variables(Term, Bound, OldList, NewList) :-
functor(Term, _, N),
free_variables(N, Term, Bound, OldList, NewList).
free_variables(0, _, _, VarList, VarList) :- !.
free_variables(N, Term, Bound, OldList, NewList) :-
arg(N, Term, Argument),
free_variables(Argument, Bound, OldList, MidList),
M is N-1, !,
free_variables(M, Term, Bound, MidList, NewList).
% explicit_binding checks for goals known to existentially quantify
% one or more variables. In particular \+ is quite common.
explicit_binding(\+ _Goal, Bound, fail, Bound ) :- !.
explicit_binding(not(_Goal), Bound, fail, Bound ) :- !.
explicit_binding(Var^Goal, Bound, Goal, Bound+Var) :- !.
explicit_binding(setof(Var,Goal,Set), Bound, Goal-Set, Bound+Var) :- !.
explicit_binding(bagof(Var,Goal,Bag), Bound, Goal-Bag, Bound+Var) :- !.
%% term_is_free_of(+Term, +Var) is semidet.
%
% True if Var does not appear in Term. This has been rewritten
% from the DEC10 library source to exploit our non-deterministic
% arg/3.
term_is_free_of(Term, Var) :-
\+ var_in_term(Term, Var).
var_in_term(Term, Var) :-
Var == Term, !.
var_in_term(Term, Var) :-
compound(Term),
genarg(_, Term, Arg),
var_in_term(Arg, Var), !.
%% list_is_free_of(+List, +Var) is semidet.
%
% True if Var is not in List.
list_is_free_of([Head|Tail], Var) :-
Head \== Var, !,
list_is_free_of(Tail, Var).
list_is_free_of([], _).
% term_variables(+Term, +Vars0, -Vars) is det.
%
% True if Vars is the union of variables in Term and Vars0.
% We cannot have this as term_variables/3 is already defined
% as a difference-list version of term_variables/2.
%term_variables(Term, Vars0, Vars) :-
% term_variables(Term+Vars0, Vars).

230
swi/library/base64.pl Normal file
View File

@@ -0,0 +1,230 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2007, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(base64,
[ base64/2, % ?PlainText, ?Encoded
base64//1 % ?PlainText
]).
/** <module> Base64 encoding and decoding
Prolog-based base64 encoding using DCG rules. Encoding according to
rfc2045. For example:
==
1 ?- base64('Hello World', X).
X = 'SGVsbG8gV29ybGQ='
Yes
2 ?- base64(H, 'SGVsbG8gV29ybGQ=').
H = 'Hello World'
==
@tbd Stream I/O
@tbd White-space introduction and parsing
@author Jan Wielemaker
*/
%% base64(+Plain, -Encoded) is det.
%% base64(-Plain, +Encoded) is det.
%
% Translates between plaintext and base64 encoded atom or string.
% See also base64//1.
base64(Plain, Encoded) :-
nonvar(Plain), !,
atom_codes(Plain, PlainCodes),
phrase(base64(PlainCodes), EncCodes),
atom_codes(Encoded, EncCodes).
base64(Plain, Encoded) :-
nonvar(Encoded), !,
atom_codes(Encoded, EncCodes),
phrase(base64(PlainCodes), EncCodes),
atom_codes(Plain, PlainCodes).
base64(_, _) :-
throw(error(instantiation_error, _)).
%% base64(+PlainText)// is det.
%% base64(-PlainText)// is det.
%
% Encode/decode list of character codes using _base64_. See also
% base64/2.
base64(Input) -->
{ nonvar(Input) }, !,
encode(Input).
base64(Output) -->
decode(Output).
/*******************************
* ENCODING *
*******************************/
encode([I0, I1, I2|Rest]) --> !,
[O0, O1, O2, O3],
{ A is (I0<<16)+(I1<<8)+I2,
O00 is (A>>18) /\ 0x3f,
O01 is (A>>12) /\ 0x3f,
O02 is (A>>6) /\ 0x3f,
O03 is A /\ 0x3f,
base64_char(O00, O0),
base64_char(O01, O1),
base64_char(O02, O2),
base64_char(O03, O3)
},
encode(Rest).
encode([I0, I1]) --> !,
[O0, O1, O2, 0'=],
{ A is (I0<<16)+(I1<<8),
O00 is (A>>18) /\ 0x3f,
O01 is (A>>12) /\ 0x3f,
O02 is (A>>6) /\ 0x3f,
base64_char(O00, O0),
base64_char(O01, O1),
base64_char(O02, O2)
}.
encode([I0]) --> !,
[O0, O1, 0'=, 0'=],
{ A is (I0<<16),
O00 is (A>>18) /\ 0x3f,
O01 is (A>>12) /\ 0x3f,
base64_char(O00, O0),
base64_char(O01, O1)
}.
encode([]) -->
[].
/*******************************
* DECODE *
*******************************/
decode(Text) -->
[C0, C1, C2, C3], !,
{ base64_char(B0, C0),
base64_char(B1, C1)
}, !,
{ C3 == 0'=
-> ( C2 == 0'=
-> A is (B0<<18) + (B1<<12),
I0 is (A>>16) /\ 0xff,
Text = [I0|Rest]
; base64_char(B2, C2)
-> A is (B0<<18) + (B1<<12) + (B2<<6),
I0 is (A>>16) /\ 0xff,
I1 is (A>>8) /\ 0xff,
Text = [I0,I1|Rest]
)
; base64_char(B2, C2),
base64_char(B3, C3)
-> A is (B0<<18) + (B1<<12) + (B2<<6) + B3,
I0 is (A>>16) /\ 0xff,
I1 is (A>>8) /\ 0xff,
I2 is A /\ 0xff,
Text = [I0,I1,I2|Rest]
},
decode(Rest).
decode([]) -->
[].
/*******************************
* BASIC CHARACTER ENCODING *
*******************************/
base64_char(00, 0'A).
base64_char(01, 0'B).
base64_char(02, 0'C).
base64_char(03, 0'D).
base64_char(04, 0'E).
base64_char(05, 0'F).
base64_char(06, 0'G).
base64_char(07, 0'H).
base64_char(08, 0'I).
base64_char(09, 0'J).
base64_char(10, 0'K).
base64_char(11, 0'L).
base64_char(12, 0'M).
base64_char(13, 0'N).
base64_char(14, 0'O).
base64_char(15, 0'P).
base64_char(16, 0'Q).
base64_char(17, 0'R).
base64_char(18, 0'S).
base64_char(19, 0'T).
base64_char(20, 0'U).
base64_char(21, 0'V).
base64_char(22, 0'W).
base64_char(23, 0'X).
base64_char(24, 0'Y).
base64_char(25, 0'Z).
base64_char(26, 0'a).
base64_char(27, 0'b).
base64_char(28, 0'c).
base64_char(29, 0'd).
base64_char(30, 0'e).
base64_char(31, 0'f).
base64_char(32, 0'g).
base64_char(33, 0'h).
base64_char(34, 0'i).
base64_char(35, 0'j).
base64_char(36, 0'k).
base64_char(37, 0'l).
base64_char(38, 0'm).
base64_char(39, 0'n).
base64_char(40, 0'o).
base64_char(41, 0'p).
base64_char(42, 0'q).
base64_char(43, 0'r).
base64_char(44, 0's).
base64_char(45, 0't).
base64_char(46, 0'u).
base64_char(47, 0'v).
base64_char(48, 0'w).
base64_char(49, 0'x).
base64_char(50, 0'y).
base64_char(51, 0'z).
base64_char(52, 0'0).
base64_char(53, 0'1).
base64_char(54, 0'2).
base64_char(55, 0'3).
base64_char(56, 0'4).
base64_char(57, 0'5).
base64_char(58, 0'6).
base64_char(59, 0'7).
base64_char(60, 0'8).
base64_char(61, 0'9).
base64_char(62, 0'+).
base64_char(63, 0'/).

177
swi/library/broadcast.pl Normal file
View File

@@ -0,0 +1,177 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2006, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(broadcast,
[ listen/3, % Listener x Templ x Goal
listen/2, % Templ x Goal
unlisten/1, % Listener
unlisten/2, % Listener x Templ
unlisten/3, % Listener x Templ x Goal
listening/3, % Listener x Templ x Goal
broadcast/1, % Templ
broadcast_request/1 % Templ
]).
:- meta_predicate
listen(+, :),
listen(+, +, :),
unlisten(+, +, :).
:- dynamic
listener/4.
/** <module> Event service
Generic broadcasting service. Broadcasts are made using the predicate
broadcast(+Templ). All registered `listeners' will have their goal
called. Success or failure of this is ignored. The listener can not bind
arguments.
This library is particulary useful for disconnecting modules in an
application. Modules can broadcast events such as changes, anticipating
other modules need to react on such changes. For example, settings.pl
broadcasts changes to settings, allowing dependent modules to react on
changes:
==
:- listing(setting(changed(http:workers, New)),
change_workers(New)).
change_workers(New) :-
setting(http:port, Port),
http_workers(Port, New).
==
*/
%% listen(+Listener, +Templ, :Goal) is det.
%% listen(+Templ, :Goal) is det.
%
% Open a channel for listening for events of the given `Templ'.
listen(Listener0, Templ, Goal) :-
canonical_listener(Listener0, Listener),
strip_module(Goal, Module, TheGoal),
assert_listener(Templ, Listener, Module, TheGoal).
listen(Templ, Goal) :-
strip_module(Goal, Module, TheGoal),
assert_listener(Templ, Module, Module, TheGoal).
%% unlisten(+Listener) is det.
%% unlisten(+Listener, +Templ) is det.
%% unlisten(+Listener, +Templ, :Goal) is det.
%
% Destroy a channel. All arguments may be variables, removing the
% all matching listening channals.
unlisten(Listener0) :-
canonical_listener(Listener0, Listener),
retractall(listener(_, Listener, _, _)).
unlisten(Listener0, Templ) :-
canonical_listener(Listener0, Listener),
retractall(listener(Templ, Listener, _, _)).
unlisten(Listener0, Templ, Goal) :-
canonical_listener(Listener0, Listener),
( var(Goal)
-> true
; strip_module(Goal, Module, TheGoal)
),
retract_listener(Templ, Listener, Module, TheGoal).
%% listening(?Listener, ?Templ, ?Goal) is nondet.
%
% returns currently open channels
listening(Listener0, Templ, Module:Goal) :-
canonical_listener(Listener0, Listener),
listener(Templ, Listener, Module, Goal).
%% broadcast(+Templ) is det.
%
% Broadcast given event.
broadcast(Templ) :-
( listener(Templ, _Listener, Module, Goal),
( Module:Goal
-> fail
)
; true
).
%% broadcast_request(+Templ) is nonet.
%
% Broadcast given event till accepted. Succeeds then, fail if no
% listener accepts the call. Bindings made by the listener goal
% are maintained. May be used to make broadcast requests.
broadcast_request(Templ) :-
listener(Templ, _Listener, Module, Goal),
Module:Goal.
% {assert,retract}_listener(+Templ, +Listener, +Module, +Goal)
%
% Implemented as sub-predicate to ensure storage in this module.
% Second registration is ignored. Is this ok? It avoids problems
% using multiple registration of global listen channels.
assert_listener(Templ, Listener, Module, TheGoal) :-
listener(Templ, Listener, Module, TheGoal), !.
assert_listener(Templ, Listener, Module, TheGoal) :-
asserta(listener(Templ, Listener, Module, TheGoal)).
retract_listener(Templ, Listener, Module, TheGoal) :-
retractall(listener(Templ, Listener, Module, TheGoal)).
%% canonical_listener(+Raw, -Canonical)
%
% Entry for later optimization.
canonical_listener(Templ, Templ).
/*******************************
* GOAL EXPANSION *
*******************************/
:- multifile
user:goal_expansion/2.
user:goal_expansion(listen(L,T,G0), listen(L,T,G)) :-
expand_goal(G0, G).
user:goal_expansion(listen(T,G0), listen(T,G)) :-
expand_goal(G0, G).
user:goal_expansion(unlisten(L,T,G0), unlisten(L,T,G)) :-
expand_goal(G0, G).

32
swi/library/clp/Makefile.in Normal file
View File

@@ -0,0 +1,32 @@
#
# default base directory for YAP installation
#
ROOTDIR = @prefix@
#
# where the binary should be
#
BINDIR = $(ROOTDIR)/bin
#
# where YAP should look for binary libraries
#
LIBDIR=@libdir@/Yap
#
# where YAP should look for architecture-independent Prolog libraries
#
SHAREDIR=$(ROOTDIR)/share
#
#
# You shouldn't need to change what follows.
#
INSTALL=@INSTALL@
INSTALL_DATA=@INSTALL_DATA@
INSTALL_PROGRAM=@INSTALL_PROGRAM@
srcdir=@srcdir@
PROGRAMS= $(srcdir)/clp_events.pl
install: $(PROGRAMS)
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap
mkdir -p $(DESTDIR)$(SHAREDIR)/Yap/clp
for p in $(PROGRAMS); do $(INSTALL_DATA) $$p $(DESTDIR)$(SHAREDIR)/Yap/clp; done

89
swi/library/clp/clp_events.pl Normal file
View File

@@ -0,0 +1,89 @@
/* $Id: clp_events.pl,v 1.1 2005-10-28 17:53:27 vsc Exp $
Part of SWI-Prolog
Author: Tom Schrijvers
E-mail: tom.schrijvers@cs.kuleuven.ac.be
WWW: http://www.swi-prolog.org
Copyright (C): 2005, K.U.Leuven
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%
% Module for managing constraint solver events.
%
% Author: Tom Schrijvers
% E-mail: tom.schrijvers@cs.kuleuven.ac.be
% Copyright: 2005, K.U.Leuven
%
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
:-module(clp_events,
[
notify/2,
subscribe/4,
unsubscribe/2
]).
notify(V,NMod) :-
( get_attr(V,clp_events,List) ->
notify_list(List,NMod)
;
true
).
subscribe(V,NMod,SMod,Goal) :-
( get_attr(V,clp_events,List) ->
put_attr(V,clp_events,[entry(NMod,SMod,Goal)|List])
;
put_attr(V,clp_events,[entry(NMod,SMod,Goal)])
).
unsubscribe(V,SMod) :-
( get_attr(V,clp_events,List) ->
unsubscribe_list(List,SMod,NList),
put_attr(V,clp_events,NList)
;
true
).
notify_list([],_).
notify_list([entry(Mod,_,Goal)|Rest],NMod) :-
( Mod == NMod ->
call(Goal)
;
true
),
notify_list(Rest,NMod).
unsubscribe_list([],_,_).
unsubscribe_list([Entry|Rest],SMod,List) :-
Entry = entry(_,Mod,_),
( Mod == SMod ->
List = Rest
;
List = [Entry|Tail],
unsubscribe_list(Rest,SMod,Tail)
).
attr_unify_hook(_,_).

134
swi/library/ctypes.pl Normal file
View File

@@ -0,0 +1,134 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2006, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(ctypes,
[ is_alnum/1,
is_alpha/1,
is_ascii/1,
is_cntrl/1,
is_csym/1,
is_csymf/1,
is_digit/1,
is_digit/3,
is_endfile/1,
is_endline/1,
is_graph/1,
is_lower/1,
is_newline/1,
is_newpage/1,
is_paren/2,
is_period/1,
is_print/1,
is_punct/1,
is_quote/1,
is_space/1,
is_upper/1,
is_white/1,
to_lower/2,
to_upper/2
]).
/** <module> Character code classification
This file implements the functionality of the corresponding Quintus
library based on SWI-Prolog's code_type/2 predicate. Please check the
documentation of this predicate to find the definitions of the classes.
@see code_type/2
@see char_type/2
*/
is_alnum(C) :- code_type(C, alnum).
is_alpha(C) :- code_type(C, alpha).
is_ascii(C) :- code_type(C, ascii).
is_cntrl(C) :- code_type(C, cntrl).
is_csym(C) :- code_type(C, csym).
is_csymf(C) :- code_type(C, csymf).
is_digit(C) :- code_type(C, digit).
is_graph(C) :- code_type(C, graph).
is_lower(C) :- code_type(C, lower).
is_upper(C) :- code_type(C, upper).
is_period(C) :- code_type(C, period).
is_endline(C) :- code_type(C, end_of_line).
is_print(C) :- is_graph(C).
is_punct(C) :- code_type(C, punct).
is_quote(C) :- code_type(C, quote).
is_space(C) :- code_type(C, space).
is_white(C) :- code_type(C, white).
is_endfile(-1).
is_newpage(12). % Control-L
is_newline(10).
%% is_paren(?Open, ?Close) is semidet.
%
% True if Open is the open-parenthesis of Close.
is_paren(0'(, 0')). % Prolog is too good at this
is_paren(0'[, 0']).
is_paren(0'{, 0'}).
%% to_lower(+U, -L) is det.
%% to_lower(-U, +L) is det.
%
% Succeeds if `U' is upper case character and `L' is the
% corresponding lower case character or `U' is an ascii character,
% but not an upper case letter and `L' is equal to `U'.
to_lower(U, L) :-
code_type(L, to_lower(U)).
to_upper(U, L) :-
code_type(L, to_upper(U)).
%% is_digit(+C, +Base, -Weight) is det.
%% is_digit(-C, +Base, +Weight) is det.
%
% Succeeds if `C' is a digit using `Base' as base and `Weight'
% represents its value. Only the base-10 case is handled by code_type.
is_digit(C, Base, Weight) :-
Base == 10, !,
code_type(C, digit(Weight)).
is_digit(C, Base, Weight) :-
between(2, 36, Base),
succ(X, Base),
between(0, X, Weight),
is_digit(C, Weight).
is_digit(C, Weight) :-
Weight < 10, !,
plus(Weight, 0'0, C).
is_digit(C, Weight) :-
plus(Weight, 87, C), !. /* `a`-10 */
is_digit(C, Weight) :-
plus(Weight, 55, C). /* `A`-10 */

254
swi/library/date.pl Normal file
View File

@@ -0,0 +1,254 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker and Willem Robert van Hage
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2005, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(date,
[ date_time_value/3, % ?Field, ?DaTime, ?Value
parse_time/2, % +Date, -Stamp
parse_time/3, % +Date, ?Format, -Stamp
day_of_the_week/2 % +Date, -DayOfTheWeek
]).
%% date_time_value(?Field:atom, +Struct:datime, -Value) is nondet.
%
% Extract values from a date-time structure. Provided fields are
%
% | year | integer | |
% | month | 1..12 | |
% | day | 1..31 | |
% | hour | 0..23 | |
% | minute | 0..59 | |
% | second | 0.0..60.0 | |
% | utc_offset | integer | Offset to UTC in seconds (positive is west) |
% | daylight_saving | bool | Name of timezone; fails if unknown |
% | date | date(Y,M,D) | |
% | time | time(H,M,S) | |
date_time_value(year, date(Y,_,_,_,_,_,_,_,_), Y).
date_time_value(month, date(_,M,_,_,_,_,_,_,_), M).
date_time_value(day, date(_,_,D,_,_,_,_,_,_), D).
date_time_value(hour, date(_,_,_,H,_,_,_,_,_), H).
date_time_value(minute, date(_,_,_,_,M,_,_,_,_), M).
date_time_value(second, date(_,_,_,_,_,S,_,_,_), S).
date_time_value(utc_offset, date(_,_,_,_,_,_,O,_,_), O).
date_time_value(time_zone, date(_,_,_,_,_,_,_,Z,_), Z) :- Z \== (-).
date_time_value(daylight_saving, date(_,_,_,_,_,_,_,_,D), D) :- D \== (-).
date_time_value(date, date(Y,M,D,_,_,_,_,_,_), date(Y,M,D)).
date_time_value(time, date(_,_,_,H,M,S,_,_,_), time(H,M,S)).
%% parse_time(+Text, -Stamp) is semidet.
%% parse_time(+Text, ?Format, -Stamp) is semidet.
%
% Stamp is a timestamp created from parsing Text using the
% representation Format. Currently supported formats are:
%
% * rfc_1123
% Used for the HTTP protocol to represent time-stamps
% * iso_8601
% Commonly used in XML documents.
parse_time(Text, Stamp) :-
parse_time(Text, _Format, Stamp).
parse_time(Text, Format, Stamp) :-
atom_codes(Text, Codes),
phrase(date(Format, Y,Mon,D,H,Min,S,UTCOffset), Codes), !,
date_time_stamp(date(Y,Mon,D,H,Min,S,UTCOffset,-,-), Stamp).
date(iso_8601, Yr, Mon, D, H, Min, S, 0) --> % BC
"-", date(iso_8601, Y, Mon, D, H, Min, S, 0),
{ Yr is -1 * Y }.
date(iso_8601, Y, Mon, D, H, Min, S, 0) -->
year(Y),
iso_8601_rest(Y, Mon, D, H, Min, S).
date(rfc_1123, Y, Mon, D, H, Min, S, 0) --> % RFC 1123: "Fri, 08 Dec 2006 15:29:44 GMT"
day_name(_), ", ", ws,
day_of_the_month(D), ws,
month_name(Mon), ws,
year(Y), ws,
hour(H), ":", minute(Min), ":", second(S), ws,
( "GMT"
-> []
; []
).
%% iso_8601_rest(+Year:int, -Mon, -Day, -H, -M, -S)
%
% Process ISO 8601 time-values after parsing the 4-digit year.
iso_8601_rest(_, Mon, D, H, Min, S) -->
"-", month(Mon), "-", day(D),
opt_time(H, Min, S).
iso_8601_rest(_, Mon, 0, 0, 0, 0) -->
"-", month(Mon).
iso_8601_rest(_, Mon, D, H, Min, S) -->
month(Mon), day(D),
opt_time(H, Min, S).
iso_8601_rest(_, 1, D, H, Min, S) -->
"-", ordinal(D),
opt_time(H, Min, S).
iso_8601_rest(Yr, 1, D, H, Min, S) -->
"-W", week(W), "-", day_of_the_week(DW),
opt_time(H, Min, S),
{ week_ordinal(Yr, W, DW, D) }.
iso_8601_rest(Yr, 1, D, H, Min, S) -->
"W", week(W), day_of_the_week(DW),
opt_time(H, Min, S),
{ week_ordinal(Yr, W, DW, D) }.
iso_8601_rest(Yr, 1, D, 0, 0, 0) -->
"W", week(W),
{ week_ordinal(Yr, W, 1, D) }.
opt_time(Hr, Min, Sec) -->
"T", !, iso_time(Hr, Min, Sec).
opt_time(0, 0, 0) --> "".
% TIMEX2 ISO: "2006-12-08T15:29:44 UTC" or "20061208T"
iso_time(Hr, Min, Sec) -->
hour(H), ":", minute(M), ":", second(S),
timezone(DH, DM, DS),
{ Hr is H + DH, Min is M + DM, Sec is S + DS }.
iso_time(Hr, Min, Sec) -->
hour(H), ":", minute(M),
timezone(DH, DM, DS),
{ Hr is H + DH, Min is M + DM, Sec is DS }.
iso_time(Hr, Min, Sec) -->
hour(H), minute(M), second(S),
timezone(DH, DM, DS),
{ Hr is H + DH, Min is M + DM, Sec is S + DS }.
iso_time(Hr, Min, Sec) -->
hour(H), minute(M),
timezone(DH, DM, DS),
{ Hr is H + DH, Min is M + DM, Sec is DS }.
iso_time(Hr, Min, Sec) -->
hour(H),
timezone(DH, DM, DS),
{ Hr is H + DH, Min is DM, Sec is DS }.
% FIXME: deal with leap seconds
timezone(Hr, Min, 0) -->
"+", hour(H), ":", minute(M), { Hr is -1 * H, Min is -1 * M }.
timezone(Hr, Min, 0) -->
"+", hour(H), minute(M), { Hr is -1 * H, Min is -1 * M }.
timezone(Hr, 0, 0) -->
"+", hour(H), { Hr is -1 * H }.
timezone(Hr, Min, 0) -->
"-", hour(H), ":", minute(M), { Hr is H, Min is M }.
timezone(Hr, Min, 0) -->
"-", hour(H), minute(M), { Hr is H, Min is M }.
timezone(Hr, 0, 0) -->
"-", hour(H), { Hr is H }.
timezone(0, 0, 0) -->
"Z".
timezone(0, 0, 0) -->
ws, "UTC".
timezone(0, 0, 0) -->
ws, "GMT". % remove this?
timezone(0, 0, 0) -->
[].
day_name(0) --> "Sun".
day_name(1) --> "Mon".
day_name(2) --> "Tue".
day_name(3) --> "Wed".
day_name(4) --> "Thu".
day_name(5) --> "Fri".
day_name(6) --> "Sat".
day_name(7) --> "Sun".
month_name(1) --> "Jan".
month_name(2) --> "Feb".
month_name(3) --> "Mar".
month_name(4) --> "Apr".
month_name(5) --> "May".
month_name(6) --> "Jun".
month_name(7) --> "Jul".
month_name(8) --> "Aug".
month_name(9) --> "Sep".
month_name(10) --> "Oct".
month_name(11) --> "Nov".
month_name(12) --> "Dec".
day_of_the_month(N) --> int2digit(N), { between(1, 31, N) }.
day_of_the_week(N) --> digit(N), { between(1, 7, N) }.
month(M) --> int2digit(M), { between(1, 12, M) }.
week(W) --> int2digit(W), { between(1, 53, W) }.
day(D) --> int2digit(D), { between(1, 31, D) }.
hour(N) --> int2digit(N), { between(0, 23, N) }.
minute(N) --> int2digit(N), { between(0, 59, N) }.
second(N) --> int2digit(N), { between(0, 60, N) }. % leap second
int2digit(N) -->
digit(D0),
digit(D1),
{ N is D0*10+D1 }.
year(Y) -->
digit(D0),
digit(D1),
digit(D2),
digit(D3),
{ Y is D0*1000+D1*100+D2*10+D3 }.
ordinal(N) --> % Nth day of the year, jan 1 = 1, dec 31 = 365 or 366
digit(D0),
digit(D1),
digit(D2),
{ N is D0*100+D1*10+D2, between(1, 366, N) }.
digit(D) -->
[C],
{ code_type(C, digit(D)) }.
ws -->
" ", !,
ws.
ws -->
[].
%% day_of_the_week(+Date, -DayOfTheWeek) is det.
%
% Computes the day of the week for a given date.
% Days of the week are numbered from one to seven:
% monday = 1, tuesday = 2, ..., sunday = 7.
%
% @param Date is a term of the form date(+Year, +Month, +Day)
day_of_the_week(date(Year, Mon, Day), DotW) :-
format_time(atom(A), '%u', date(Year, Mon, Day, 0, 0, 0, 0, -, -)),
atom_number(A, DotW).
week_ordinal(Year, Week, Day, Ordinal) :-
format_time(atom(A), '%w', date(Year, 1, 1, 0, 0, 0, 0, -, -)),
atom_number(A, DotW0),
Ordinal is ((Week-1) * 7) - DotW0 + Day + 1.

400
swi/library/debug.pl Normal file
View File

@@ -0,0 +1,400 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2012, University of Amsterdam
VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(prolog_debug,
[ debug/3, % +Topic, +Format, :Args
debug/1, % +Topic
nodebug/1, % +Topic
debugging/1, % ?Topic
debugging/2, % ?Topic, ?Bool
list_debug_topics/0,
debug_message_context/1, % (+|-)What
assertion/1 % :Goal
]).
:- use_module(library(error)).
:- use_module(library(lists)).
:- set_prolog_flag(generate_debug_info, false).
:- meta_predicate
assertion(0),
debug(+,+,:).
:- multifile prolog:assertion_failed/2.
:- dynamic prolog:assertion_failed/2.
/*:- use_module(library(prolog_stack)).*/ % We use the autoloader if needed
:- if(current_prolog_flag(dialect, yap)).
:- use_module(library(hacks), [stack_dump/1]).
% this is as good as I can do.
backtrace(N) :-
stack_dump(N).
:- endif.
%:- set_prolog_flag(generate_debug_info, false).
:- dynamic
debugging/3, % Topic, Enabled, To
debug_context/1.
debug_context(thread).
/** <module> Print debug messages and test assertions
This library is a replacement for format/3 for printing debug messages.
Messages are assigned a _topic_. By dynamically enabling or disabling
topics the user can select desired messages. Debug statements are
removed when the code is compiled for optimization.
See manual for details. With XPCE, you can use the call below to start a
graphical monitoring tool.
==
?- prolog_ide(debug_monitor).
==
Using the predicate assertion/1 you can make assumptions about your
program explicit, trapping the debugger if the condition does not hold.
@author Jan Wielemaker
*/
%% debugging(+Topic) is semidet.
%% debugging(-Topic) is nondet.
%% debugging(?Topic, ?Bool) is nondet.
%
% Examine debug topics. The form debugging(+Topic) may be used to
% perform more complex debugging tasks. A typical usage skeleton
% is:
%
% ==
% ( debugging(mytopic)
% -> <perform debugging actions>
% ; true
% ),
% ...
% ==
%
% The other two calls are intended to examine existing and enabled
% debugging tokens and are typically not used in user programs.
debugging(Topic) :-
debugging(Topic, true, _To).
debugging(Topic, Bool) :-
debugging(Topic, Bool, _To).
%% debug(+Topic) is det.
%% nodebug(+Topic) is det.
%
% Add/remove a topic from being printed. nodebug(_) removes all
% topics. Gives a warning if the topic is not defined unless it is
% used from a directive. The latter allows placing debug topics at
% the start of a (load-)file without warnings.
%
% For debug/1, Topic can be a term Topic > Out, where Out is
% either a stream or stream-alias or a filename (atom). This
% redirects debug information on this topic to the given output.
debug(Topic) :-
debug(Topic, true).
nodebug(Topic) :-
debug(Topic, false).
debug(Spec, Val) :-
debug_target(Spec, Topic, Out),
( ( retract(debugging(Topic, Enabled0, To0))
*-> update_debug(Enabled0, To0, Val, Out, Enabled, To),
assert(debugging(Topic, Enabled, To)),
fail
; ( prolog_load_context(file, _)
-> true
; print_message(warning, debug_no_topic(Topic))
),
update_debug(false, [], Val, Out, Enabled, To),
assert(debugging(Topic, Enabled, To))
)
-> true
; true
).
debug_target(Spec, Topic, To) :-
nonvar(Spec),
Spec = (Topic > To), !.
debug_target(Topic, Topic, -).
update_debug(_, To0, true, -, true, To) :- !,
ensure_output(To0, To).
update_debug(true, To0, true, Out, true, Output) :- !,
append(To0, [Out], Output).
update_debug(false, _, true, Out, true, [Out]) :- !.
update_debug(_, _, false, -, false, []) :- !.
update_debug(true, [Out], false, Out, false, []) :- !.
update_debug(true, To0, false, Out, true, Output) :- !,
delete(To0, Out, Output).
ensure_output([], [user_error]) :- !.
ensure_output(List, List).
%% debug_topic(+Topic) is det.
%
% Declare a topic for debugging. This can be used to find all
% topics available for debugging.
debug_topic(Topic) :-
( debugging(Registered, _, _),
Registered =@= Topic
-> true
; assert(debugging(Topic, false, []))
).
%% list_debug_topics is det.
%
% List currently known debug topics and their setting.
list_debug_topics :-
format(user_error, '~*t~45|~n', "-"),
format(user_error, '~w~t ~w~35| ~w~n',
['Debug Topic', 'Activated', 'To']),
format(user_error, '~*t~45|~n', "-"),
( debugging(Topic, Value, To),
format(user_error, '~w~t ~w~35| ~w~n', [Topic, Value, To]),
fail
; true
).
%% debug_message_context(+What) is det.
%
% Specify additional context for debug messages. What is one of
% +Context or -Context, and Context is one of =thread=, =time= or
% time(Format), where Format is a format specification for
% format_time/3 (default is =|%T.%3f|=). Initially, debug/3 shows
% only thread information.
debug_message_context(+Topic) :- !,
valid_topic(Topic, Del, Add),
retractall(debug_context(Del)),
assert(debug_context(Add)).
debug_message_context(-Topic) :- !,
valid_topic(Topic, Del, _),
retractall(debug_context(Del)).
debug_message_context(Term) :-
type_error(debug_message_context, Term).
valid_topic(thread, thread, thread) :- !.
valid_topic(time, time(_), time('%T.%3f')) :- !.
valid_topic(time(Format), time(_), time(Format)) :- !.
valid_topic(X, _, _) :-
domain_error(debug_message_context, X).
%% debug(+Topic, +Format, :Args) is det.
%
% Format a message if debug topic is enabled. Similar to format/3
% to =user_error=, but only prints if Topic is activated through
% debug/1. Args is a meta-argument to deal with goal for the
% @-command. Output is first handed to the hook
% prolog:debug_print_hook/3. If this fails, Format+Args is
% translated to text using the message-translation (see
% print_message/2) for the term debug(Format, Args) and then
% printed to every matching destination (controlled by debug/1)
% using print_message_lines/3.
%
% The message is preceded by '% ' and terminated with a newline.
%
% @see format/3.
debug(Topic, Format, Args) :-
debugging(Topic, true, To), !,
print_debug(Topic, To, Format, Args).
debug(_, _, _).
%% prolog:debug_print_hook(+Topic, +Format, +Args) is semidet.
%
% Hook called by debug/3. This hook is used by the graphical
% frontend that can be activated using prolog_ide/1:
%
% ==
% ?- prolog_ide(debug_monitor).
% ==
:- multifile
prolog:debug_print_hook/3.
print_debug(Topic, _To, Format, Args) :-
prolog:debug_print_hook(Topic, Format, Args), !.
print_debug(_, [], _, _) :- !.
print_debug(Topic, To, Format, Args) :-
phrase('$messages':translate_message(debug(Format, Args)), Lines),
( member(T, To),
debug_output(T, Stream),
print_message_lines(Stream, kind(debug(Topic)), Lines),
fail
; true
).
debug_output(user, user_error) :- !.
debug_output(Stream, Stream) :-
is_stream(Stream), !.
debug_output(File, Stream) :-
open(File, append, Stream,
[ close_on_abort(false),
alias(File),
buffer(line)
]).
/*******************************
* ASSERTION *
*******************************/
%% assertion(:Goal) is det.
%
% Acts similar to C assert() macro. It has no effect if Goal
% succeeds. If Goal fails or throws an exception, the following
% steps are taken:
%
% * call prolog:assertion_failed/2. If prolog:assertion_failed/2
% fails, then:
%
% - If this is an interactive toplevel thread, print a
% message, the stack-trace, and finally trap the debugger.
% - Otherwise, throw error(assertion_error(Reason, G),_) where
% Reason is one of =fail= or the exception raised.
assertion(G) :-
\+ \+ catch(G,
Error,
assertion_failed(Error, G)),
!.
assertion(G) :-
assertion_failed(fail, G),
assertion_failed. % prevent last call optimization.
assertion_failed(Reason, G) :-
prolog:assertion_failed(Reason, G), !.
assertion_failed(Reason, G) :-
print_message(error, assertion_failed(Reason, G)),
backtrace(10),
( current_prolog_flag(break_level, _) % interactive thread
-> trace
; throw(error(assertion_error(Reason, G), _))
).
assertion_failed.
%% assume(:Goal) is det.
%
% Acts similar to C assert() macro. It has no effect of Goal
% succeeds. If Goal fails it prints a message, a stack-trace
% and finally traps the debugger.
%
% @deprecated Use assertion/1 in new code.
/*******************************
* EXPANSION *
*******************************/
:- multifile
system:goal_expansion/2.
system:goal_expansion(debug(Topic,_,_), true) :-
( current_prolog_flag(optimise, true)
-> true
; debug_topic(Topic),
fail
).
system:goal_expansion(debugging(Topic), fail) :-
( current_prolog_flag(optimise, true)
-> true
; debug_topic(Topic),
fail
).
system:goal_expansion(assertion(_), Goal) :-
current_prolog_flag(optimise, true),
Goal = true.
system:goal_expansion(assume(_), Goal) :-
print_message(informational,
compatibility(renamed(assume/1, assertion/1))),
current_prolog_flag(optimise, true),
Goal = true.
/*******************************
* MESSAGES *
*******************************/
:- multifile
prolog:message/3.
prolog:message(assertion_failed(_, G)) -->
[ 'Assertion failed: ~q'-[G] ].
prolog:message(debug(Fmt, Args)) -->
show_thread_context,
show_time_context,
[ Fmt-Args ].
prolog:message(debug_no_topic(Topic)) -->
[ '~q: no matching debug topic (yet)'-[Topic] ].
show_thread_context -->
{ debug_context(thread),
thread_self(Me) ,
Me \== main
},
[ '[Thread ~w] '-[Me] ].
show_thread_context -->
[].
show_time_context -->
{ debug_context(time(Format)),
get_time(Now),
format_time(string(S), Format, Now)
},
[ '[~w] '-[S] ].
show_time_context -->
[].
/*******************************
* HOOKS *
*******************************/
%% prolog:assertion_failed(+Reason, +Goal) is semidet.
%
% This hook is called if the Goal of assertion/1 fails. Reason is
% unified with either =fail= if Goal simply failed or an exception
% call otherwise. If this hook fails, the default behaviour is
% activated. If the hooks throws an exception it will be
% propagated into the caller of assertion/1.

248
swi/library/error.pl Normal file
View File

@@ -0,0 +1,248 @@
/* $Id: error.pl,v 1.3 2008-07-22 23:34:49 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2007, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(error,
[ type_error/2, % +Type, +Term
domain_error/2, % +Domain, +Term
existence_error/2, % +Type, +Term
permission_error/3, % +Action, +Type, +Term
instantiation_error/1, % +Term
representation_error/1, % +Reason
must_be/2, % +Type, +Term
is_of_type/2 % +Type, +Term
]).
:- if(current_prolog_flag(dialect, yap)).
:- use_module(library(lists),[memberchk/2]).
:- endif.
/** <module> Error generating support
This module provides predicates to simplify error generation and
checking. It's 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.
@author Jan Wielemaker
@author Richard O'Keefe
@see library(debug) and library(prolog_stack).
*/
:- multifile
has_type/2.
%% type_error(+Type, +Term).
%% domain_error(+Type, +Term).
%% existence_error(+Type, +Term).
%% permission_error(+Action, +Type, +Term).
%% instantiation_error(+Term).
%% 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(+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 |
%
% @throws instantiation_error if Term is insufficiently
% instantiated and type_error(Type, Term) if Term is not of Type.
must_be(Type, X) :-
( has_type(Type, X)
-> true
; is_not(Type, X)
).
%% 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), 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).
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 == [] ).

114
swi/library/main.pl Normal file
View File

@@ -0,0 +1,114 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2011, University of Amsterdam
VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(prolog_main,
[ main/0
]).
:- use_module(library(lists)).
/** <module> Provide entry point for scripts
This library is intended for supporting PrologScript on Unix using the
=|#!|= magic sequence for scripts using commandline options. The entry
point main/0 calls the user-supplied predicate main/1 passing a list of
commandline options. Below is `echo' in Prolog (adjust /usr/bin/pl to
where SWI-Prolog is installed)
==
#!/usr/bin/pl -q -g main -s
main(Argv) :-
echo(Argv).
echo([]) :- nl.
echo([Last]) :- !,
write(Last), nl.
echo([H|T]) :-
write(H), write(' '),
echo(T).
==
@see XPCE users should have a look at library(pce_main), which
starts the GUI and processes events until all windows have gone.
*/
:- module_transparent
main/0.
%% main
%
% Call main/1 using the passed command-line arguments.
main :-
context_module(M),
set_signals,
argv(Av),
run_main(M, Av).
%% run_main(+Module, +Args)
%
% Run the main routine, guarding for exceptions and failure of the
% main/1 routine
run_main(Module, Av) :-
( catch(call(Module:main, Av), E, true)
-> ( var(E)
-> halt(0)
; print_message(error, E),
halt(1)
)
; print_message(error, goal_failed(main(Av))),
halt(1)
).
argv(Av) :-
current_prolog_flag(argv, Argv),
( append(_, [--|Av], Argv)
-> true
; current_prolog_flag(dialect, yap)
-> Argv = Av
; current_prolog_flag(windows, true)
-> Argv = [_Prog|Av]
; Av = []
).
set_signals :-
on_signal(int, _, interrupt).
%% interrupt(+Signal)
%
% We received an interrupt. This handler is installed using
% on_signal/3.
interrupt(_Sig) :-
halt(1).

103
swi/library/maplist.pl Normal file
View File

@@ -0,0 +1,103 @@
/* $Id: maplist.pl,v 1.2 2008-06-05 19:33:51 rzf Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(maplist,
[ maplist/2, % :Goal, +List
maplist/3, % :Goal, ?List1, ?List2
maplist/4, % :Goal, ?List1, ?List2, ?List3
maplist/5, % :Goal, ?List1, ?List2, ?List3, List4
forall/2 % :Goal, :Goal
]).
:- module_transparent
maplist/2,
maplist2/2,
maplist/3,
maplist2/3,
maplist/4,
maplist2/4,
maplist/5,
maplist2/5,
forall/2.
% maplist(:Goal, +List)
%
% True if Goal can succesfully be applied on all elements of List.
% Arguments are reordered to gain performance as well as to make
% the predicate deterministic under normal circumstances.
maplist(Goal, List) :-
maplist2(List, Goal).
maplist2([], _).
maplist2([Elem|Tail], Goal) :-
call(Goal, Elem),
maplist2(Tail, Goal).
% maplist(:Goal, ?List1, ?List2)
%
% True if Goal can succesfully be applied to all succesive pairs
% of elements of List1 and List2.
maplist(Goal, List1, List2) :-
maplist2(List1, List2, Goal).
maplist2([], [], _).
maplist2([Elem1|Tail1], [Elem2|Tail2], Goal) :-
call(Goal, Elem1, Elem2),
maplist2(Tail1, Tail2, Goal).
% maplist(:Goal, ?List1, ?List2, ?List3)
%
% True if Goal can succesfully be applied to all succesive triples
% of elements of List1..List3.
maplist(Goal, List1, List2, List3) :-
maplist2(List1, List2, List3, Goal).
maplist2([], [], [], _).
maplist2([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], Goal) :-
call(Goal, Elem1, Elem2, Elem3),
maplist2(Tail1, Tail2, Tail3, Goal).
% maplist(:Goal, ?List1, ?List2, ?List3, List4)
%
% True if Goal can succesfully be applied to all succesive
% quadruples of elements of List1..List4
maplist(Goal, List1, List2, List3, List4) :-
maplist2(List1, List2, List3, List4, Goal).
maplist2([], [], [], [], _).
maplist2([Elem1|Tail1], [Elem2|Tail2], [Elem3|Tail3], [Elem4|Tail4], Goal) :-
call(Goal, Elem1, Elem2, Elem3, Elem4),
maplist2(Tail1, Tail2, Tail3, Tail4, Goal).

76
swi/library/menu.pl Executable file
View File

@@ -0,0 +1,76 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2009, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module('$win_menu',
[ win_insert_menu_item/4, % +PopupName, +Item, +Before, :Goal
win_has_menu/0 % Test whether we have menus
]).
:- meta_predicate
win_insert_menu_item(+,+,+,:).
%:- multifile
% prolog:on_menu/1.
:- dynamic
menu_action/2.
:- volatile
menu_action/2.
prolog:on_menu(Label) :-
menu_action(Label, Action),
catch(Action, Error,
print_message(error, Error)).
% win_has_menu
%
% Test whether the system provides the menu interface
prolog:win_has_menu :-
current_predicate(_, system:'$win_insert_menu_item'(_, _, _)).
% win_insert_menu_item(+Popup, +Item, +Before, :Goal)
%
% Add a menu-item to the PLWIN.EXE menu. See the reference manual
% for details.
prolog:win_insert_menu_item(Popup, --, Before, _Goal) :- !,
call(system:'$win_insert_menu_item'(Popup, --, Before)). % fool check/0
prolog:win_insert_menu_item(Popup, Item, Before, Goal) :-
insert_menu_item(Popup, Item, Before, Goal).
insert_menu_item(Popup, Item, Before, Goal) :-
( menu_action(Item, OldGoal),
OldGoal \== Goal
-> throw(error(permission_error(redefine, Item),
win_insert_menu_item/4))
; true
),
call(system:'$win_insert_menu_item'(Popup, Item, Before)),
assert(menu_action(Item, Goal)).

124
swi/library/nb_set.pl Normal file
View File

@@ -0,0 +1,124 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2005, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(nb_set,
[ empty_nb_set/1, % -EmptySet
add_nb_set/2, % +Key, !Set
add_nb_set/3, % +Key, !Set, ?New
gen_nb_set/2, % +Set, -Key
size_nb_set/2, % +Set, -Size
nb_set_to_list/2 % +Set, -List
]).
/** <module> Non-backtrackable sets
This library provides a non-backtrackabe set. It is based on
nb_setarg/3. See the SWI-Prolog manual for details.
@author Jan Wielemaker
@tbd Base this work on AVL trees rather then unbalanced trees.
*/
/*******************************
* NON-BACKTRACKABLE SETS *
*******************************/
%% empty_nb_set(-Set)
%
% Create an empty non-backtrackable set.
empty_nb_set(nb_set(t)).
%% add_nb_set(+Key, !Set) is det.
%% add_nb_set(+Key, !Set, ?New) is semidet.
%
% Insert an element into the set. If the element is already in the
% set, nothing happens. New is =true= if Key was added as a new
% element to the set and =false= otherwise.
add_nb_set(Key, Set) :-
add_nb_set(Key, Set, _).
add_nb_set(Key, Set, New) :-
( empty_nb_set(Set)
-> New = true,
nb_setarg(1, Set, t(Key, t, t))
; arg(1, Set, Tree),
'$btree_find_node'(Key, Tree, Node, Arg),
( Arg == 1
-> New = false
; New = true,
nb_setarg(Arg, Node, t(Key, t, t))
)
).
%% nb_set_to_list(+Set, -List)
%
% Get the elements of a an nb_set. List is sorted to the standard
% order of terms.
nb_set_to_list(nb_set(Set), List) :-
phrase(nb_set_to_list(Set), List).
nb_set_to_list(t) -->
[].
nb_set_to_list(t(Val, Left, Right)) -->
nb_set_to_list(Left),
[Val],
nb_set_to_list(Right).
%% gen_nb_set(+Set, -Key)
%
% Enumerate the members of a set in the standard order of terms.
gen_nb_set(nb_set(Tree), Key) :-
gen_set(Tree, Key).
gen_set(t(Val, Left, Right), Key) :-
( gen_set(Left, Key)
; Key = Val
; gen_set(Right, Key)
).
%% size_nb_set(+Set, -Size)
%
% Unify Size with the number of elements in the set
size_nb_set(nb_set(Tree), Size) :-
set_size(Tree, Size).
set_size(t, 0).
set_size(t(_,L,R), Size) :-
set_size(L, SL),
set_size(R, SR),
Size is SL+SR+1.

141
swi/library/occurs.yap Normal file
View File

@@ -0,0 +1,141 @@
/* $Id: occurs.yap,v 1.1 2008-02-12 17:03:52 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(occurs,
[ contains_term/2, % +SubTerm, +Term
contains_var/2, % +SubTerm, +Term
free_of_term/2, % +SubTerm, +Term
free_of_var/2, % +SubTerm, +Term
occurrences_of_term/3, % +SubTerm, +Term, ?Tally
occurrences_of_var/3, % +SubTerm, +Term, ?Tally
sub_term/2, % -SubTerm, +Term
sub_var/2 % -SubTerm, +Term (SWI extra)
]).
:- use_module(library(arg),
[genarg/3]).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This is a SWI-Prolog implementation of the corresponding Quintus
library, based on the generalised arg/3 predicate of SWI-Prolog.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
%% contains_term(+Sub, +Term) is semidet.
%
% Succeeds if Sub is contained in Term (=, deterministically)
contains_term(X, X) :- !.
contains_term(X, Term) :-
compound(Term),
genarg(_, Term, Arg),
contains_term(X, Arg), !.
%% contains_var(+Sub, +Term) is det.
%
% Succeeds if Sub is contained in Term (==, deterministically)
contains_var(X0, X1) :-
X0 == X1, !.
contains_var(X, Term) :-
compound(Term),
genarg(_, Term, Arg),
contains_var(X, Arg), !.
%% free_of_term(+Sub, +Term)
%
% Succeeds of Sub does not unify to any subterm of Term
free_of_term(Sub, Term) :-
\+ contains_term(Sub, Term).
%% free_of_var(+Sub, +Term)
%
% Succeeds of Sub is not equal (==) to any subterm of Term
free_of_var(Sub, Term) :-
\+ contains_var(Sub, Term).
%% occurrences_of_term(+SubTerm, +Term, ?Count)
%
% Count the number of SubTerms in Term
occurrences_of_term(Sub, Term, Count) :-
count(sub_term(Sub, Term), Count).
%% occurrences_of_var(+SubTerm, +Term, ?Count)
%
% Count the number of SubTerms in Term
occurrences_of_var(Sub, Term, Count) :-
count(sub_var(Sub, Term), Count).
%% sub_term(-Sub, +Term)
%
% Generates (on backtracking) all subterms of Term.
sub_term(X, X).
sub_term(X, Term) :-
compound(Term),
genarg(_, Term, Arg),
sub_term(X, Arg).
%% sub_var(-Sub, +Term)
%
% Generates (on backtracking) all subterms (==) of Term.
sub_var(X0, X1) :-
X0 == X1.
sub_var(X, Term) :-
compound(Term),
genarg(_, Term, Arg),
sub_var(X, Arg).
/*******************************
* UTIL *
*******************************/
%% count(+Goal, -Count)
%
% Count number of times Goal succeeds.
count(Goal, Count) :-
State = count(0),
( Goal,
arg(1, State, N0),
N is N0 + 1,
nb_setarg(1, State, N),
fail
; arg(1, State, Count)
).

198
swi/library/operators.pl Normal file
View File

@@ -0,0 +1,198 @@
/* $Id: operators.pl,v 1.1 2008-02-12 17:03:53 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2004, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(prolog_operator,
[ push_operators/1, % +List
push_operators/2, % +List, -Undo
pop_operators/0,
pop_operators/1, % +Undo
push_op/3 % Precedence, Type, Name
]).
/** <module> Manage operators
Often, one wants to define operators to improve the readibility of some
very specific code. Operators in Prolog are global objects and changing
operators changes syntax and possible semantics of existing sources. For
this reason it is desirable to reset operator declarations after the
code that needs them has been read. This module defines a rather cruel
-but portable- method to do this.
Usage:
==
:- push_operators(
[ op(900, fx, hello_world)
, op(600, xf, *)
]).
hello_world World :-
....
:- pop_operators.
==
While the above are for source-code, the calls push_operators/2 and
pop_operators/1 can be used for local processing where it is more
comfortable to carry the undo context around.
NOTE: In recent versions of SWI-Prolog operators are local to a module
and can be exported using the syntax below. This is not portable, but
otherwise a more structured approach for operator handling.
==
:- module(mymodule,
[ mypred/1,
op(500, fx, myop)
]).
==
@compat SWI-Prolog
*/
:- thread_local
operator_stack/1.
:- module_transparent
push_operators/1,
push_operators/2,
push_op/3.
%% push_operators(:New) is det.
%% push_operators(:New, -Undo) is det.
%
% Installs the operators from New, where New is a list of op(Prec,
% Type, :Name). The modifications to the operator table are undone
% in a matching call to pop_operators/0.
push_operators(New, Undo) :-
strip_module(New, Module, Ops0),
tag_ops(Ops0, Module, Ops),
undo_operators(Ops, Undo),
set_operators(Ops).
push_operators(New) :-
push_operators(New, Undo),
assert_op(mark),
assert_op(Undo).
%% push_op(+Precedence, +Type, :Name) is det.
%
% As op/3, but this call must appear between push_operators/1 and
% pop_operators/0. The change is undone by the call to
% pop_operators/0
push_op(P, T, A0) :-
( A0 = _:_
-> A = A0
; context_module(M),
A = M:A0
),
undo_operator(op(P,T,A), Undo),
assert_op(Undo),
op(P, T, A).
%% pop_operators is det.
%
% Revert all changes to the operator table realised since the last
% push_operators/1.
pop_operators :-
retract_op(Undo),
( Undo == mark
-> !
; set_operators(Undo),
fail
).
%% pop_operators(+Undo) is det.
%
% Reset operators as pushed by push_operators/2.
pop_operators(Undo) :-
set_operators(Undo).
tag_ops([], _, []).
tag_ops([op(P,Tp,N0)|T0], M, [op(P,Tp,N)|T]) :-
( N0 = _:_
-> N = N0
; N = M:N0
),
tag_ops(T0, M, T).
set_operators([]).
set_operators([H|R]) :-
set_operators(H),
set_operators(R).
set_operators(op(P,T,A)) :-
op(P, T, A).
undo_operators([], []).
undo_operators([O0|T0], [U0|T]) :-
undo_operator(O0, U0),
undo_operators(T0, T).
undo_operator(op(_P, T, N), op(OP, OT, N)) :-
current_op(OP, OT, N),
same_op_type(T, OT), !.
undo_operator(op(P, T, [H|R]), [OH|OT]) :- !,
undo_operator(op(P, T, H), OH),
undo_operator(op(P, T, R), OT).
undo_operator(op(_, _, []), []) :- !.
undo_operator(op(_P, T, N), op(0, T, N)).
same_op_type(T, OT) :-
op_type(T, Type),
op_type(OT, Type).
op_type(fx, prefix).
op_type(fy, prefix).
op_type(xfx, infix).
op_type(xfy, infix).
op_type(yfx, infix).
op_type(yfy, infix).
op_type(xf, postfix).
op_type(yf, postfix).
%% assert_op(+Term) is det.
%% retract_op(-Term) is det.
%
% Force local assert/retract.
assert_op(Term) :-
asserta(operator_stack(Term)).
retract_op(Term) :-
retract(operator_stack(Term)).

256
swi/library/option.pl Normal file
View File

@@ -0,0 +1,256 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2009, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(swi_option,
[ option/2, % +Term, +List
option/3, % +Term, +List, +Default
select_option/3, % +Term, +Options, -RestOpts
select_option/4, % +Term, +Options, -RestOpts, +Default
merge_options/3, % +New, +Old, -Merged
meta_options/3 % :IsMeta, :OptionsIn, -OptionsOut
]).
:- use_module(library(lists)).
/** <module> Option list processing
The library(option) provides some utilities for processing option lists.
Option lists are commonly used as an alternative for many arguments.
Examples built-in predicates are open/4 and write_term/3. Naming the
arguments results in more readable code and the list nature makes it
easy to extend the list of options accepted by a predicate. Option lists
come in two styles, both of which are handled by this library.
$ Name(Value) :
This is the preferred style.
$ Name = Value :
This is often used, but deprecated.
Processing options inside time critical code (loops) can cause serious
overhead. One possibility is to define a record using library(record)
and initialise this using make_<record>/2. In addition to providing good
performance, this also provides type-checking and central declaration of
defaults.
==
:- record atts(width:integer=100, shape:oneof([box,circle])=box).
process(Data, Options) :-
make_atts(Options, Attributes),
action(Data, Attributes).
action(Data, Attributes) :-
atts_shape(Attributes, Shape),
...
==
@tbd We should consider putting many options in an assoc or record
with appropriate preprocessing to achieve better performance.
@tbd We should provide some standard to to automatic type-checking
on option lists.
@see library(record)
*/
%% option(?Option, +OptionList, +Default)
%
% Get an option from a OptionList. OptionList can use the
% Name=Value as well as the Name(Value) convention.
%
% @param Option Term of the form Name(?Value).
option(Opt, Options, Default) :- % make option processing stead-fast
arg(1, Opt, OptVal),
ground(OptVal), !,
functor(Opt, OptName, 1),
functor(Gen, OptName, 1),
option(Gen, Options, Default),
Opt = Gen.
option(Opt, Options, _) :-
get_option(Opt, Options), !.
option(Opt, _, Default) :-
arg(1, Opt, Default).
%% option(?Option, +OptionList)
%
% Get an option from a OptionList. OptionList can use the
% Name=Value as well as the Name(Value) convention. Fails silently
% if the option does not appear in OptionList.
%
% @param Option Term of the form Name(?Value).
option(Opt, Options) :- % make option processing stead-fast
arg(1, Opt, OptVal),
nonvar(OptVal), !,
functor(Opt, OptName, 1),
functor(Gen, OptName, 1),
option(Gen, Options),
Opt = Gen.
option(Opt, Options) :-
get_option(Opt, Options), !.
get_option(Opt, Options) :-
memberchk(Opt, Options), !.
get_option(Opt, Options) :-
functor(Opt, OptName, 1),
arg(1, Opt, OptVal),
memberchk(OptName=OptVal, Options), !.
%% select_option(?Option, +Options, -RestOptions) is semidet.
%
% Get and remove option from an option list. As option/2, removing
% the matching option from Options and unifying the remaining
% options with RestOptions.
select_option(Opt, Options0, Options) :- % stead-fast
arg(1, Opt, OptVal),
nonvar(OptVal), !,
functor(Opt, OptName, 1),
functor(Gen, OptName, 1),
select_option(Gen, Options0, Options),
Opt = Gen.
select_option(Opt, Options0, Options) :-
get_option(Opt, Options0, Options), !.
get_option(Opt, Options0, Options) :-
select(Opt, Options0, Options), !.
get_option(Opt, Options0, Options) :-
functor(Opt, OptName, 1),
arg(1, Opt, OptVal),
select(OptName=OptVal, Options0, Options), !.
%% select_option(?Option, +Options, -RestOptions, +Default) is det.
%
% Get and remove option with default value. As select_option/3,
% but if Option is not in Options, its value is unified with
% Default and RestOptions with Options.
select_option(Option, Options, RestOptions, _Default) :-
select_option(Option, Options, RestOptions), !.
select_option(Option, Options, Options, Default) :-
arg(1, Option, Default).
%% merge_options(+New, +Old, -Merged) is det.
%
% Merge two option lists. Merged is a sorted list of options using
% the canonical format Name(Value) holding all options from New
% and Old, after removing conflicting options from Old.
merge_options([], Old, Merged) :- !, Merged = Old.
merge_options(New, [], Merged) :- !, Merged = New.
merge_options(New, Old, Merged) :-
canonise_options(New, NCanonical),
canonise_options(Old, OCanonical),
sort(NCanonical, NSorted),
sort(OCanonical, OSorted),
ord_merge(NSorted, OSorted, Merged).
ord_merge([], L, L) :- !.
ord_merge(L, [], L) :- !.
ord_merge([NO|TN], [OO|TO], Merged) :-
functor(NO, NName, 1),
functor(OO, OName, 1),
compare(Diff, NName, OName),
ord_merge(Diff, NO, NName, OO, OName, TN, TO, Merged).
ord_merge(=, NO, _, _, _, TN, TO, [NO|T]) :-
ord_merge(TN, TO, T).
ord_merge(<, NO, _, OO, OName, TN, TO, [NO|T]) :-
( TN = [H|TN2]
-> functor(H, NName, 1),
compare(Diff, NName, OName),
ord_merge(Diff, H, NName, OO, OName, TN2, TO, T)
; T = [OO|TO]
).
ord_merge(>, NO, NName, OO, _, TN, TO, [OO|T]) :-
( TO = [H|TO2]
-> functor(H, OName, 1),
compare(Diff, NName, OName),
ord_merge(Diff, NO, NName, H, OName, TN, TO2, T)
; T = [NO|TN]
).
%% canonise_options(+OptionsIn, -OptionsOut) is det.
%
% Rewrite option list from possible Name=Value to Name(Value)
canonise_options(In, Out) :-
memberchk(_=_, In), !, % speedup a bit if already ok.
canonise_options2(In, Out).
canonise_options(Options, Options).
canonise_options2([], []).
canonise_options2([Name=Value|T0], [H|T]) :- !,
H =.. [Name,Value],
canonise_options2(T0, T).
canonise_options2([H|T0], [H|T]) :- !,
canonise_options2(T0, T).
%% meta_options(+IsMeta, :Options0, -Options) is det.
%
% Perform meta-expansion on options that are module-sensitive.
% Whether an option name is module sensitive is determined by
% calling call(IsMeta, Name). Here is an example:
%
% ==
% meta_options(is_meta, OptionsIn, Options),
% ...
%
% is_meta(callback).
% ==
:- meta_predicate
meta_options(1, :, -).
meta_options(IsMeta, Context:Options0, Options) :-
meta_options(Options0, IsMeta, Context, Options).
meta_options([], _, _, []).
meta_options([H0|T0], IM, Context, [H|T]) :-
meta_option(H0, IM, Context, H),
meta_options(T0, IM, Context, T).
meta_option(Name=V0, IM, Context, Name=M:V) :-
call(IM, Name), !,
strip_module(Context:V0, M, V).
meta_option(O0, IM, Context, O) :-
compound(O0),
O0 =.. [Name,V0],
call(IM, Name), !,
strip_module(Context:V0, M, V),
O =.. [Name,M:V].
meta_option(O, _, _, O).

162
swi/library/pairs.pl Normal file
View File

@@ -0,0 +1,162 @@
/* $Id: pairs.pl,v 1.1 2008-02-12 17:03:52 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2006, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(pairs,
[ pairs_keys_values/3,
pairs_values/2,
pairs_keys/2,
group_pairs_by_key/2,
transpose_pairs/2,
map_list_to_pairs/3
]).
/** <module> Operations on key-value lists
This module implements common operations on Key-Value lists, also known
as _Pairs_. Pairs have great practical value, especially due to
keysort/2 and the library assoc.pl.
This library is based on disussion in the SWI-Prolog mailinglist,
including specifications from Quintus and a library proposal by Richard
O'Keefe.
@see keysort/2, library(assoc)
@author Jan Wielemaker
*/
%% pairs_keys_values(?Pairs, ?Keys, ?Values) is det.
%
% True if Keys holds the keys of Pairs and Values the values.
%
% Deterministic if any argument is instantiated to a finite list
% and the others are either free or finite lists.
pairs_keys_values(Pairs, Keys, Values) :-
( nonvar(Pairs) ->
pairs_keys_values_(Pairs, Keys, Values)
; nonvar(Keys) ->
keys_values_pairs(Keys, Values, Pairs)
; values_keys_pairs(Values, Keys, Pairs)
).
pairs_keys_values_([], [], []).
pairs_keys_values_([K-V|Pairs], [K|Keys], [V|Values]) :-
pairs_keys_values_(Pairs, Keys, Values).
keys_values_pairs([], [], []).
keys_values_pairs([K|Ks], [V|Vs], [K-V|Pairs]) :-
keys_values_pairs(Ks, Vs, Pairs).
values_keys_pairs([], [], []).
values_keys_pairs([V|Vs], [K|Ks], [K-V|Pairs]) :-
values_keys_pairs(Vs, Ks, Pairs).
%% pairs_values(+Pairs, -Values) is det.
%
% Remove the keys from a list of Key-Value pairs. Same as
% pairs_keys_values(Pairs, _, Values)
pairs_values([], []).
pairs_values([_-V|T0], [V|T]) :-
pairs_values(T0, T).
%% pairs_keys(+Pairs, -Keys) is det.
%
% Remove the values from a list of Key-Value pairs. Same as
% pairs_keys_values(Pairs, Keys, _)
pairs_keys([], []).
pairs_keys([K-_|T0], [K|T]) :-
pairs_keys(T0, T).
%% group_pairs_by_key(+Pairs, -Joined:list(Key-Values)) is det.
%
% Group values with the same key. For example:
%
% ==
% ?- group_pairs_by_key([a-2, a-1, b-4], X).
%
% X = [a-[2,1], b-[4]]
% ==
%
% @param Pairs Key-Value list, sorted to the standard order
% of terms (as keysort/2 does)
% @param Joined List of Key-Group, where Group is the
% list of Values associated with Key.
group_pairs_by_key([], []).
group_pairs_by_key([M-N|T0], [M-[N|TN]|T]) :-
same_key(M, T0, TN, T1),
group_pairs_by_key(T1, T).
same_key(M, [M-N|T0], [N|TN], T) :- !,
same_key(M, T0, TN, T).
same_key(_, L, [], L).
%% transpose_pairs(+Pairs, -Transposed) is det.
%
% Swap Key-Value to Value-Key and sort the result on Value
% (the new key) using keysort/2.
transpose_pairs(Pairs, Transposed) :-
flip_pairs(Pairs, Flipped),
keysort(Flipped, Transposed).
flip_pairs([], []).
flip_pairs([Key-Val|Pairs], [Val-Key|Flipped]) :-
flip_pairs(Pairs, Flipped).
%% map_list_to_pairs(:Function, +List, -Keyed)
%
% Create a key-value list by mapping each element of List.
% For example, if we have a list of lists we can create a
% list of Length-List using
%
% ==
% map_list_to_pairs(length, ListOfLists, Pairs),
% ==
:- module_transparent
map_list_to_pairs/3,
map_list_to_pairs2/3.
map_list_to_pairs(Function, List, Pairs) :-
map_list_to_pairs2(List, Function, Pairs).
map_list_to_pairs2([], _, []).
map_list_to_pairs2([H|T0], Pred, [K-H|T]) :-
call(Pred, H, K),
map_list_to_pairs2(T0, Pred, T).

309
swi/library/persistence.yap Normal file
View File

@@ -0,0 +1,309 @@
/*
persistence.yap - make assertions and retracts persistent
Copyright (C) 2006, Christian Thaeter <chth@gmx.net>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License version 2 as
published by the Free Software Foundation.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, contact me.
*/
:- module(persistence,
[
persistent_open/3,
persistent_close/1,
persistent_assert/1,
persistent_retract/1
]).
:- use_module(library(system),[]).
:- dynamic(persistent_desc/2).
/*
persistent_open(PredDesc, File, Opts).
declare Module:Functor/Arity (Functor/Arity) to be persistent
stored in File's (*.db *.log *log.$PID *.lock *.bak)
Opts are:
db - use dbfile (flat file containing all persistent predicates)
log - use logfile (logfile with either +(Term) for asserts and -(Term) for retracts)
bak - make backupfiles when regenerating the dbfile
sync - flush data always
ro - readonly, can load locked files, never changes data on disk
wo - (planned) writeonly, implies [log], data is only written to the log and not
asserted into prolog, the database will not be loaded at persistent_open.
conc - (planned) concurrency, extends the locking for multiple readers/single writer locks
trans - (planned) support for transactions (begin/commit/abort)
Guides:
- if the data mutates a lot, use [db,log].
- if you mostly append data [log] suffices.
- if the data is not important (can be regenerated) and mostly readonly then [db] is ok.
- when using only [db] you must not forget to persistent_close!
- for extra security against failures add [bak,sync].
- don't use [bak] if you need to conserve disk space and the database is huge.
- don't use [sync] if you need very fast writes.
- turning all on [db,log,bak,sync] is probably the best, if you are undecided.
- [ro,db] loads only the last saved db file.
- [ro,log] loads the last saved db file if it exists and replays the log.
- note that [ro] will fail if the db is not intact (.bak file present).
(planned features)
- [wo] is very limited and only useful if you want to log data to a file
- [wo,db] will replay the log at close
- [conc] is useful for shareing data between prolog processes, but this is not a
high performance solution.
- [trans] can improve performance of concurrent access somewhat
*/
persistent_open(PredDesc, File, Opts) :-
module_goal(PredDesc, Module:Functor/Arity),
atom(Functor), integer(Arity), atom(File),
\+ persistent_desc(Module:Functor/Arity,_),
atom_concat(File,'.db',DBfile),
assertz(persistent_desc(Module:Functor/Arity,dbfile(DBfile))),
atom_concat(File,'.bak',Backupfile),
assertz(persistent_desc(Module:Functor/Arity,backupfile(Backupfile))),
atom_concat(File,'.log',Logfile),
assertz(persistent_desc(Module:Functor/Arity,logfile(Logfile))),
system:pid(Pid),
assertz(persistent_desc(Module:Functor/Arity,pid(Pid))),
number_atom(Pid,P),
atom_concat(Logfile,P,Mylogfile),
assertz(persistent_desc(Module:Functor/Arity,mylogfile(Mylogfile))),
atom_concat(File,'.lock',Lockfile),
assertz(persistent_desc(Module:Functor/Arity,lockfile(Lockfile))),
persistent_opts_store(Module:Functor/Arity,Opts),
persistent_load(Module:Functor/Arity),
( \+ persistent_desc(Module:Functor/Arity, ro), persistent_desc(Module:Functor/Arity, log)
-> open(Logfile, append, Log),
assertz(persistent_desc(Module:Functor/Arity,logstream(Log)))
; true
).
/*
closes the database associated with PredDesc ([Module:]Functor/Arity)
*/
persistent_close(PredDesc0) :-
module_goal(PredDesc0,PredDesc),
( persistent_desc(PredDesc, logstream(Log))
-> close(Log)
; true
),
persistent_save(PredDesc),
persistent_desc(PredDesc, backupfile(Backupfile)),
(system:delete_file(Backupfile,[ignore]); true),
persistent_lock_release(PredDesc),
retractall(persistent_desc(PredDesc,_)).
/*
assert data to the database, this is always an assertz, if you need some ordering,
then store some kind of key within your data.
rules can be asserted too
*/
persistent_assert(Term) :-
Term = (Head0 :- Body),
module_goal(Head0, Module:Head),
functor(Head, Functor, Arity),
once(persistent_desc(Module:Functor/Arity,_)),!,
( persistent_desc(Module:Functor/Arity, logstream(Log))
-> writeq(Log,+(((Module:Head):-Body))), write(Log,'.\n'),
( persistent_desc(Module:Functor/Arity, sync)
-> flush_output(Log)
; true
)
; true
),
assertz((Module:Head:-Body)).
persistent_assert(Term0) :-
module_goal(Term0, Module:Term),
functor(Term,Functor,Arity),
once(persistent_desc(Module:Functor/Arity,_)),!,
( persistent_desc(Module:Functor/Arity,logstream(Log))
-> writeq(Log,+(Module:Term)), write(Log,'.\n'),
( persistent_desc(Module:Functor/Arity, sync)
-> flush_output(Log)
; true
)
; true
),
assertz(Module:Term).
/*
retract a persistent Term
*/
persistent_retract(Term0) :-
module_goal(Term0, Module:Term),
functor(Term,Functor,Arity),
once(persistent_desc(Module:Functor/Arity,_)),!,
retract(Module:Term),
( persistent_desc(Module:Functor/Arity, logstream(Log))
-> writeq(Log,-(Module:Term)), write(Log,'.\n'),
( persistent_desc(Module:Functor/Arity, sync)
-> flush_output(Log)
; true
)
; true
).
% transaction support for future
persistent_begin.
persistent_commit.
persistent_abort.
/*
PRIVATE PREDICATES, DONT USE THESE
*/
% save all data to a .db file
persistent_save(PredDesc) :-
\+ persistent_desc(PredDesc,ro),
( persistent_desc(PredDesc,db)
-> persistent_desc(PredDesc,dbfile(DBfile)),
(
persistent_desc(PredDesc,bak)
-> persistent_desc(PredDesc,backupfile(Backupfile)),
( system:file_exists(DBfile)
-> system:rename_file(DBfile,Backupfile)
; true
)
; true
),
open(DBfile, write, S),
persistent_writeall(PredDesc,S),
close(S),
persistent_desc(PredDesc,logfile(Logfile)),
(system:delete_file(Logfile,[ignore]); true)
; true
).
% write all predicates matching Functor/Arity to stream S
persistent_writeall(PredDesc, S) :-
module_goal(PredDesc, Module:Functor/Arity),
functor(Clause, Functor, Arity),
clause(Module:Clause, Body),
( Body = true
-> writeq(S,Module:Clause)
; writeq(S,(Module:Clause:-Body))
),
write(S,'.\n'),
fail.
persistent_writeall(_,_).
% load a database, recover logfile, recreate .db
persistent_load(PredDesc) :-
persistent_desc(PredDesc,dbfile(DBfile)),
persistent_desc(PredDesc,backupfile(Backupfile)),
persistent_desc(PredDesc,logfile(Logfile)),
( persistent_desc(PredDesc,ro)
-> \+ system:file_exists(Backupfile),
( system:file_exists(DBfile)
-> persistent_load_file(DBfile)
; true
),
( persistent_desc(PredDesc,log), system:file_exists(Logfile)
-> persistent_load_file(Logfile)
; true
)
;
persistent_lock_exclusive(PredDesc),
( system:file_exists(Backupfile)
-> system:rename_file(Backupfile, DBfile)
; true
),
( system:file_exists(DBfile)
-> persistent_load_file(DBfile)
; true
),
( system:file_exists(Logfile)
-> persistent_load_file(Logfile),
( persistent_desc(PredDesc, db)
-> persistent_save(PredDesc)
; true
)
; true
)
).
% load a .db file or replay a .log file
persistent_load_file(File) :-
open(File, read, S),
repeat,
read(S, TermIn),
(
TermIn == end_of_file,
close(S),
!
;
(
TermIn = +(Term),
assertz(Term)
;
TermIn = -(Term),
retract(Term)
;
assertz(TermIn)
),
fail
).
%lock handling, so far only exclusive locks
persistent_lock_exclusive(PredDesc) :-
persistent_desc(PredDesc,lockfile(Lockfile)),
persistent_desc(PredDesc,pid(Pid)),
open(Lockfile, append, Lockappend),
write(Lockappend,lock(write,Pid)),write(Lockappend,'.\n'),
close(Lockappend),
open(Lockfile, read, Lockread),
read(Lockread,LPid),
close(Lockread),
LPid = lock(_,Pid).
% recover lock
persistent_lock_exclusive(PredDesc) :-
persistent_desc(PredDesc, lockfile(Lockfile)),
open(Lockfile, read, Lockread),
read(Lockread,lock(_,LPid)),
close(Lockread),
\+ catch(kill(LPid,0),_,fail),
(system:delete_file(Lockfile,[ignore]); true),
%system:sleep(1),
persistent_lock_exclusive(PredDesc).
persistent_lock_release(PredDesc) :-
persistent_lock_exclusive(PredDesc),
persistent_desc(PredDesc,lockfile(Lockfile)),
(system:delete_file(Lockfile,[ignore]); true).
persistent_opts_store(_,[]).
persistent_opts_store(PredDesc,[H|T]) :-
assertz(persistent_desc(PredDesc,H)),
persistent_opts_store(PredDesc,T).
module_goal(Module:Goal,Module:Goal) :-
callable(Goal), nonvar(Module),!.
module_goal(Goal,Module:Goal) :-
callable(Goal), prolog_flag(typein_module,Module).

912
swi/library/predicate_options.pl Normal file
View File

@@ -0,0 +1,912 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2011, VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(predicate_options,
[ predicate_options/3, % +PI, +Arg, +Options
assert_predicate_options/4, % +PI, +Arg, +Options, ?New
current_option_arg/2, % ?PI, ?Arg
current_predicate_option/3, % ?PI, ?Arg, ?Option
check_predicate_option/3, % +PI, +Arg, +Option
% Create declarations
current_predicate_options/3, % ?PI, ?Arg, ?Options
retractall_predicate_options/0,
derived_predicate_options/3, % :PI, ?Arg, ?Options
derived_predicate_options/1, % +Module
% Checking
check_predicate_options/0,
derive_predicate_options/0,
check_predicate_options/1 % :PredicateIndicator
]).
:- use_module(library(lists)).
:- use_module(library(pairs)).
:- use_module(library(error)).
:- use_module(library(lists)).
:- use_module(library(debug)).
:- use_module(library(prolog_clause)).
:- meta_predicate
predicate_options(:, +, +),
assert_predicate_options(:, +, +, ?),
current_predicate_option(:, ?, ?),
check_predicate_option(:, ?, ?),
current_predicate_options(:, ?, ?),
current_option_arg(:, ?),
pred_option(:,-),
derived_predicate_options(:,?,?),
check_predicate_options(:).
/** <module> Access and analyse predicate options
This module provides the developers interface for the directive
predicate_options/3. This directive allows us to specify that e.g.,
open/4 processes options using the 4th argument and supports the option
=type= using the values =text= and =binary=. Declaring options that are
processed allows for more reliable handling of predicate options and
simplifies porting applications. This libarry provides the following
functionality:
* Query supported options through current_predicate_option/3
or current_predicate_options/3. This is intended to support
conditional compilation and an IDE.
* Derive additional declarations through dataflow analysis using
derive_predicate_options/0.
* Perform a compile-time analysis of the entire loaded program using
check_predicate_options/0.
Below, we describe some use-cases.
$ Quick check of a program :
This scenario is useful as an occasional check or to assess problems
with option-handling for porting an application to SWI-Prolog. It
consists of three steps: loading the program (1 and 2), deriving
option handling for application predicates (3) and running the
checker (4).
==
1 ?- [load].
2 ?- autoload.
3 ?- derive_predicate_options.
4 ?- check_predicate_options.
==
$ Add declaations to your program :
Adding declarations about option processes improves the quality of
the checking. The analysis of derive_predicate_options/0 may miss
options and does not derive the types for options that are processed
in Prolog code. The process is similar to the above. In steps 4 and
further, the inferred declarations are listed, inspected and added to
the source-code of the module.
==
1 ?- [load].
2 ?- autoload.
3 ?- derive_predicate_options.
4 ?- derived_predicate_options(module_1).
5 ?- derived_predicate_options(module_2).
6 ?- ...
==
$ Declare option processing requirements :
If an application requires that open/4 needs to support lock(write),
it may do so using the derective below. This directive raises an
exception when loaded on a Prolog implementation that does not support
this option.
==
:- current_predicate_option(open/4, 4, lock(write)).
==
@see library(option) for accessing options in Prolog code.
*/
:- multifile option_decl/3, pred_option/3.
:- dynamic dyn_option_decl/3.
%% predicate_options(:PI, +Arg, +Options) is det.
%
% Declare that the predicate PI processes options on Arg. Options
% is a list of options processed. Each element is one of:
%
% * Option(ModeAndType)
% PI processes Option. The option-value must comply to
% ModeAndType. Mode is one of + or - and Type is a type as
% accepted by must_be/2.
%
% * pass_to(:PI,Arg)
% The option-list is passed to the indicated predicate.
%
% Below is an example that processes the option header(boolean)
% and passes all options to open/4:
%
% ==
% :- predicate_options(write_xml_file/3, 3,
% [ header(boolean),
% pass_to(open/4, 4)
% ]).
%
% write_xml_file(File, XMLTerm, Options) :-
% open(File, write, Out, Options),
% ( option(header(true), Option, true)
% -> write_xml_header(Out)
% ; true
% ),
% ...
% ==
%
% This predicate may only be used as a _directive_ and is
% processed by expand_term/2. Option processing can be be
% specified at runtime using assert_predicate_options/3, which is
% intended to support program analysis.
predicate_options(PI, Arg, Options) :-
throw(error(context_error(nodirective,
predicate_options(PI, Arg, Options)), _)).
%% assert_predicate_options(:PI, +Arg, +Options, ?New) is semidet.
%
% As predicate_options(:PI, +Arg, +Options). New is a boolean
% indicating whether the declarations have changed. If new is
% provided and =false=, the predicate becomes semidet and fails
% without modifications if modifications are required.
assert_predicate_options(PI, Arg, Options, New) :-
canonical_pi(PI, M:Name/Arity),
functor(Head, Name, Arity),
( dyn_option_decl(Head, M, Arg)
-> true
; New = true,
assertz(dyn_option_decl(Head, M, Arg))
),
phrase('$predopts':option_clauses(Options, Head, M, Arg),
OptionClauses),
forall(member(Clause, OptionClauses),
assert_option_clause(Clause, New)),
( var(New)
-> New = false
; true
).
assert_option_clause(Clause, New) :-
rename_clause(Clause, NewClause,
'$pred_option'(A,B,C,D), '$dyn_pred_option'(A,B,C,D)),
clause_head(NewClause, NewHead),
( clause(NewHead, _)
-> true
; New = true,
assertz(NewClause)
).
clause_head(M:(Head:-_Body), M:Head) :- !.
clause_head((M:Head :-_Body), M:Head) :- !.
clause_head(Head, Head).
rename_clause(M:Clause, M:NewClause, Head, NewHead) :- !,
rename_clause(Clause, NewClause, Head, NewHead).
rename_clause((Head :- Body), (NewHead :- Body), Head, NewHead) :- !.
rename_clause(Head, NewHead, Head, NewHead) :- !.
rename_clause(Head, Head, _, _).
/*******************************
* QUERY OPTIONS *
*******************************/
%% current_option_arg(:PI, ?Arg) is nondet.
%
% True when Arg of PI processes predicate options. Which options
% are processed can be accessed using current_predicate_option/3.
current_option_arg(Module:Name/Arity, Arg) :-
current_option_arg(Module:Name/Arity, Arg, _DefM).
current_option_arg(Module:Name/Arity, Arg, DefM) :-
atom(Name), integer(Arity), !,
resolve_module(Module:Name/Arity, DefM:Name/Arity),
functor(Head, Name, Arity),
( option_decl(Head, DefM, Arg)
; dyn_option_decl(Head, DefM, Arg)
).
current_option_arg(M:Name/Arity, Arg, M) :-
( option_decl(Head, M, Arg)
; dyn_option_decl(Head, M, Arg)
),
functor(Head, Name, Arity).
%% current_predicate_option(:PI, ?Arg, ?Option) is nondet.
%
% True when Arg of PI processes Option. For example, the following
% is true:
%
% ==
% ?- current_predicate_option(open/4, 4, type(text)).
% true.
% ==
%
% This predicate is intended to support conditional compilation
% using if/1 ... endif/0. The predicate
% current_predicate_options/3 can be used to access the full
% capabilities of a predicate.
current_predicate_option(Module:PI, Arg, Option) :-
current_option_arg(Module:PI, Arg, DefM),
PI = Name/Arity,
functor(Head, Name, Arity),
catch(pred_option(DefM:Head, Option),
error(type_error(_,_),_),
fail).
%% check_predicate_option(:PI, +Arg, +Option) is det.
%
% Similar to current_predicate_option/3, but intended to support
% runtime checking.
%
% @error existence_error(option, OptionName) if the option is not
% supported by PI.
% @error type_error(Type, Value) if the option is supported but
% the value does not match the option type. See must_be/2.
check_predicate_option(Module:PI, Arg, Option) :-
define_predicate(Module:PI),
current_option_arg(Module:PI, Arg, DefM),
PI = Name/Arity,
functor(Head, Name, Arity),
( pred_option(DefM:Head, Option)
-> true
; existence_error(option, Option)
).
pred_option(M:Head, Option) :-
pred_option(M:Head, Option, []).
pred_option(M:Head, Option, Seen) :-
( has_static_option_decl(M),
M:'$pred_option'(Head, _, Option, Seen)
; has_dynamic_option_decl(M),
M:'$dyn_pred_option'(Head, _, Option, Seen)
).
has_static_option_decl(M) :-
'$c_current_predicate'(_, M:'$pred_option'(_,_,_,_)).
has_dynamic_option_decl(M) :-
'$c_current_predicate'(_, M:'$dyn_pred_option'(_,_,_,_)).
/*******************************
* TYPE&MODE CONSTRAINTS *
*******************************/
:- public
system:predicate_option_mode/2,
system:predicate_option_type/2.
add_attr(Var, Value) :-
( get_attr(Var, predicate_options, Old)
-> put_attr(Var, predicate_options, [Value|Old])
; put_attr(Var, predicate_options, [Value])
).
system:predicate_option_type(Type, Arg) :-
var(Arg), !,
add_attr(Arg, option_type(Type)).
system:predicate_option_type(Type, Arg) :-
must_be(Type, Arg).
system:predicate_option_mode(Mode, Arg) :-
var(Arg), !,
add_attr(Arg, option_mode(Mode)).
system:predicate_option_mode(Mode, Arg) :-
check_mode(Mode, Arg).
check_mode(input, Arg) :-
( nonvar(Arg)
-> true
; instantiation_error(Arg)
).
check_mode(output, Arg) :-
( var(Arg)
-> true
; instantiation_error(Arg) % TBD: Uninstantiated
).
attr_unify_hook([], _).
attr_unify_hook([H|T], Var) :-
option_hook(H, Var),
attr_unify_hook(T, Var).
option_hook(option_type(Type), Value) :-
is_of_type(Type, Value).
option_hook(option_mode(Mode), Value) :-
check_mode(Mode, Value).
attribute_goals(Var) -->
{ get_attr(Var, predicate_options, Attrs) },
option_goals(Attrs, Var).
option_goals([], _) --> [].
option_goals([H|T], Var) -->
option_goal(H, Var),
option_goals(T, Var).
option_goal(option_type(Type), Var) --> [predicate_option_type(Type, Var)].
option_goal(option_mode(Mode), Var) --> [predicate_option_mode(Mode, Var)].
/*******************************
* OUTPUT DECLARATIONS *
*******************************/
%% current_predicate_options(:PI, ?Arg, ?Options) is nondet.
%
% True when Options is the current active option declaration for
% PI on Arg. See predicate_options/3 for the argument
% descriptions. If PI is ground and refers to an undefined
% predicate, the autoloader is used to obtain a definition of the
% predicate.
current_predicate_options(PI, Arg, Options) :-
define_predicate(PI),
setof(Arg-Option,
current_predicate_option_decl(PI, Arg, Option),
Options0),
group_pairs_by_key(Options0, Grouped),
member(Arg-Options, Grouped).
current_predicate_option_decl(PI, Arg, Option) :-
current_predicate_option(PI, Arg, Option0),
Option0 =.. [Name|Values],
maplist(mode_and_type, Values, Types),
Option =.. [Name|Types].
mode_and_type(Value, ModeAndType) :-
copy_term(Value,_,Goals),
( memberchk(predicate_option_mode(output, _), Goals)
-> ModeAndType = -(Type)
; ModeAndType = Type
),
( memberchk(predicate_option_type(Type, _), Goals)
-> true
; Type = any
).
define_predicate(PI) :-
ground(PI), !,
PI = M:Name/Arity,
functor(Head, Name, Arity),
once(predicate_property(M:Head, _)).
define_predicate(_).
%% derived_predicate_options(:PI, ?Arg, ?Options) is nondet.
%
% True when Options is the current _derived_ active option
% declaration for PI on Arg.
derived_predicate_options(PI, Arg, Options) :-
define_predicate(PI),
setof(Arg-Option,
derived_predicate_option(PI, Arg, Option),
Options0),
group_pairs_by_key(Options0, Grouped),
member(Arg-Options1, Grouped),
PI = M:_,
phrase(expand_pass_to_options(Options1, M), Options2),
sort(Options2, Options).
derived_predicate_option(PI, Arg, Decl) :-
current_option_arg(PI, Arg, DefM),
PI = _:Name/Arity,
functor(Head, Name, Arity),
has_dynamic_option_decl(DefM),
( has_static_option_decl(DefM),
DefM:'$pred_option'(Head, Decl, _, [])
; DefM:'$dyn_pred_option'(Head, Decl, _, [])
).
%% expand_pass_to_options(+OptionsIn, +Module, -OptionsOut)// is det.
%
% Expand the options of pass_to(PI,Arg) if PI does not refer to a
% public predicate.
expand_pass_to_options([], _) --> [].
expand_pass_to_options([H|T], M) -->
expand_pass_to(H, M),
expand_pass_to_options(T, M).
expand_pass_to(pass_to(PI, Arg), Module) -->
{ strip_module(Module:PI, M, Name/Arity),
functor(Head, Name, Arity),
\+ ( predicate_property(M:Head, exported)
; predicate_property(M:Head, public)
; M == system
), !,
current_predicate_options(M:Name/Arity, Arg, Options)
},
list(Options).
expand_pass_to(Option, _) -->
[Option].
list([]) --> [].
list([H|T]) --> [H], list(T).
%% derived_predicate_options(+Module) is det.
%
% Derive predicate option declarations for the given module and
% print them to the current output.
derived_predicate_options(Module) :-
var(Module), !,
forall(current_module(Module),
derived_predicate_options(Module)).
derived_predicate_options(Module) :-
findall(predicate_options(Module:PI, Arg, Options),
( derived_predicate_options(Module:PI, Arg, Options),
PI = Name/Arity,
functor(Head, Name, Arity),
( predicate_property(Module:Head, exported)
-> true
; predicate_property(Module:Head, public)
)
),
Decls0),
maplist(qualify_decl(Module), Decls0, Decls1),
sort(Decls1, Decls),
( Decls \== []
-> format('~N~n~n% Predicate option declarations for module ~q~n~n',
[Module]),
forall(member(Decl, Decls),
portray_clause((:-Decl)))
; true
).
qualify_decl(M,
predicate_options(PI0, Arg, Options0),
predicate_options(PI1, Arg, Options1)) :-
qualify(PI0, M, PI1),
maplist(qualify_option(M), Options0, Options1).
qualify_option(M, pass_to(PI0, Arg), pass_to(PI1, Arg)) :- !,
qualify(PI0, M, PI1).
qualify_option(_, Opt, Opt).
qualify(M:Term, M, Term) :- !.
qualify(QTerm, _, QTerm).
/*******************************
* CLEANUP *
*******************************/
%% retractall_predicate_options is det.
%
% Remove all dynamically (derived) predicate options.
retractall_predicate_options :-
forall(retract(dyn_option_decl(_,M,_)),
abolish(M:'$dyn_pred_option'/4)).
/*******************************
* COMPILE-TIME CHECKER *
*******************************/
:- thread_local
new_decl/1.
%% check_predicate_options is det.
%
% Analyse loaded program for errornous options. This predicate
% decompiles the current program and searches for calls to
% predicates that process options. For each option list, it
% validates whether the provided options are supported and
% validates the argument type. This predicate performs partial
% dataflow analysis to track option-lists inside a clause.
%
% @see derive_predicate_options/0 can be used to derive
% declarations for predicates that pass options. This
% predicate should normally be called before
% check_predicate_options/0.
check_predicate_options :-
forall(current_module(Module),
check_predicate_options_module(Module)).
%% derive_predicate_options is det.
%
% Derive new predicate option declarations. This predicate
% analyses the loaded program to find clauses that process options
% using one of the predicates from library(option) or passes
% options to other predicates that are known to process options.
% The process is repeated until no new declarations are retrieved.
%
% @see autoload/0 may be used to complete the loaded program.
derive_predicate_options :-
derive_predicate_options(NewDecls),
( NewDecls == []
-> true
; print_message(informational, check_options(new(NewDecls))),
new_decls(NewDecls),
derive_predicate_options
).
new_decls([]).
new_decls([predicate_options(PI, A, O)|T]) :-
assert_predicate_options(PI, A, O, _),
new_decls(T).
derive_predicate_options(NewDecls) :-
call_cleanup(
( forall(
current_module(Module),
forall(
( predicate_in_module(Module, PI),
PI = Name/Arity,
functor(Head, Name, Arity),
catch(Module:clause(Head, Body, Ref), _, fail)
),
check_clause((Head:-Body), Module, Ref, decl))),
( setof(Decl, retract(new_decl(Decl)), NewDecls)
-> true
; NewDecls = []
)
),
retractall(new_decl(_))).
check_predicate_options_module(Module) :-
forall(predicate_in_module(Module, PI),
check_predicate_options(Module:PI)).
predicate_in_module(Module, PI) :-
current_predicate(Module:PI),
PI = Name/Arity,
functor(Head, Name, Arity),
\+ predicate_property(Module:Head, imported_from(_)).
%% check_predicate_options(:PredicateIndicator) is det.
%
% Verify calls to predicates that have options in all clauses of
% the predicate indicated by PredicateIndicator.
check_predicate_options(Module:Name/Arity) :-
debug(predicate_options, 'Checking ~q', [Module:Name/Arity]),
functor(Head, Name, Arity),
forall(catch(Module:clause(Head, Body, Ref), _, fail),
check_clause((Head:-Body), Module, Ref, check)).
%% check_clause(+Clause, +Module, +Ref, +Action) is det.
%
% Action is one of
%
% * decl
% Create additional declarations
% * check
% Produce error messages
check_clause((Head:-Body), M, ClauseRef, Action) :- !,
catch(check_body(Body, M, _, Action), E, true),
( var(E)
-> option_decl(M:Head, Action)
; ( clause_info(ClauseRef, File, TermPos, _NameOffset),
TermPos = term_position(_,_,_,_,[_,BodyPos]),
catch(check_body(Body, M, BodyPos, Action),
error(Formal, ArgPos), true),
compound(ArgPos),
arg(1, ArgPos, CharCount),
integer(CharCount)
-> Location = file_char_count(File, CharCount)
; Location = clause(ClauseRef),
E = error(Formal, _)
),
print_message(error, predicate_option_error(Formal, Location))
).
%% check_body(+Body, +Module, +TermPos, +Action)
check_body(Var, _, _, _) :-
var(Var), !.
check_body(M:G, _, term_position(_,_,_,_,[_,Pos]), Action) :- !,
check_body(G, M, Pos, Action).
check_body((A,B), M, term_position(_,_,_,_,[PA,PB]), Action) :- !,
check_body(A, M, PA, Action),
check_body(B, M, PB, Action).
check_body(A=B, _, _, _) :- % partial evaluation
unify_with_occurs_check(A,B), !.
check_body(Goal, M, term_position(_,_,_,_,ArgPosList), Action) :-
callable(Goal),
functor(Goal, Name, Arity),
( '$get_predicate_attribute'(M:Goal, imported, DefM)
-> true
; DefM = M
),
( eval_option_pred(DefM:Goal)
-> true
; current_option_arg(DefM:Name/Arity, OptArg), !,
arg(OptArg, Goal, Options),
nth1(OptArg, ArgPosList, ArgPos),
check_options(DefM:Name/Arity, OptArg, Options, ArgPos, Action)
).
check_body(Goal, M, _, Action) :-
prolog:called_by(Goal, Called), !,
check_called_by(Called, M, Action).
check_body(Meta, M, term_position(_,_,_,_,ArgPosList), Action) :-
'$get_predicate_attribute'(M:Meta, meta_predicate, Head), !,
check_meta_args(1, Head, Meta, M, ArgPosList, Action).
check_body(_, _, _, _).
check_meta_args(I, Head, Meta, M, [ArgPos|ArgPosList], Action) :-
arg(I, Head, AS), !,
( AS == 0
-> arg(I, Meta, MA),
check_body(MA, M, ArgPos, Action)
; true
),
succ(I, I2),
check_meta_args(I2, Head, Meta, M, ArgPosList, Action).
check_meta_args(_,_,_,_, _, _).
%% check_called_by(+CalledBy, +M, +Action) is det.
%
% Handle results from prolog:called_by/2.
check_called_by([], _, _).
check_called_by([H|T], M, Action) :-
( H = G+N
-> ( extend(G, N, G2)
-> check_body(G2, M, _, Action)
; true
)
; check_body(H, M, _, Action)
),
check_called_by(T, M, Action).
extend(Goal, N, GoalEx) :-
callable(Goal),
Goal =.. List,
length(Extra, N),
append(List, Extra, ListEx),
GoalEx =.. ListEx.
%% check_options(:Predicate, +OptionArg, +Options, +ArgPos, +Action)
%
% Verify the list Options, that is passed into Predicate on
% argument OptionArg. ArgPos is a term-position term describing
% the location of the Options list. If Options is a partial list,
% the tail is annotated with pass_to(PI, OptArg).
check_options(PI, OptArg, QOptions, ArgPos, Action) :-
debug(predicate_options, '\tChecking call to ~q', [PI]),
remove_qualifier(QOptions, Options),
must_be(list_or_partial_list, Options),
check_option_list(Options, PI, OptArg, Options, ArgPos, Action).
remove_qualifier(X, X) :-
var(X), !.
remove_qualifier(_:X, X) :- !.
remove_qualifier(X, X).
check_option_list(Var, PI, OptArg, _, _, _) :-
var(Var), !,
annotate(Var, pass_to(PI, OptArg)).
check_option_list([], _, _, _, _, _).
check_option_list([H|T], PI, OptArg, Options, ArgPos, Action) :-
check_option(PI, OptArg, H, ArgPos, Action),
check_option_list(T, PI, OptArg, Options, ArgPos, Action).
check_option(_, _, _, _, decl) :- !.
check_option(PI, OptArg, Opt, ArgPos, _) :-
catch(check_predicate_option(PI, OptArg, Opt), E, true), !,
( var(E)
-> true
; E = error(Formal,_),
throw(error(Formal,ArgPos))
).
/*******************************
* ANNOTATIONS *
*******************************/
%% annotate(+Var, +Term) is det.
%
% Use constraints to accumulate annotations about variables. If
% two annotated variables are unified, the attributes are joined.
annotate(Var, Term) :-
( get_attr(Var, predopts_analysis, Old)
-> put_attr(Var, predopts_analysis, [Term|Old])
; var(Var)
-> put_attr(Var, predopts_analysis, [Term])
; true
).
annotations(Var, Annotations) :-
get_attr(Var, predopts_analysis, Annotations).
predopts_analysis:attr_unify_hook(Opts, Value) :-
get_attr(Value, predopts_analysis, Others), !,
append(Opts, Others, All),
put_attr(Value, predopts_analysis, All).
predopts_analysis:attr_unify_hook(_, _).
/*******************************
* PARTIAL EVAL *
*******************************/
eval_option_pred(swi_option:option(Opt, Options)) :-
processes(Opt, Spec),
annotate(Options, Spec).
eval_option_pred(swi_option:option(Opt, Options, _Default)) :-
processes(Opt, Spec),
annotate(Options, Spec).
eval_option_pred(swi_option:select_option(Opt, Options, Rest)) :-
ignore(unify_with_occurs_check(Rest, Options)),
processes(Opt, Spec),
annotate(Options, Spec).
eval_option_pred(swi_option:select_option(Opt, Options, Rest, _Default)) :-
ignore(unify_with_occurs_check(Rest, Options)),
processes(Opt, Spec),
annotate(Options, Spec).
eval_option_pred(swi_option:meta_options(_Cond, QOptionsIn, QOptionsOut)) :-
remove_qualifier(QOptionsIn, OptionsIn),
remove_qualifier(QOptionsOut, OptionsOut),
ignore(unify_with_occurs_check(OptionsIn, OptionsOut)).
processes(Opt, Spec) :-
compound(Opt),
functor(Opt, OptName, 1),
Spec =.. [OptName,any].
/*******************************
* NEW DECLARTIONS *
*******************************/
%% option_decl(:Head, +Action) is det.
%
% Add new declarations based on attributes left by the analysis
% pass. We do not add declarations for system modules or modules
% that already contain static declarations.
%
% @tbd Should we add a mode to include generating declarations
% for system modules and modules with static declarations?
option_decl(_, check) :- !.
option_decl(M:_, _) :-
system_module(M), !.
option_decl(M:_, _) :-
has_static_option_decl(M), !.
option_decl(M:Head, _) :-
arg(AP, Head, QA),
remove_qualifier(QA, A),
annotations(A, Annotations0),
functor(Head, Name, Arity),
PI = M:Name/Arity,
delete(Annotations0, pass_to(PI,AP), Annotations),
Annotations \== [],
Decl = predicate_options(PI, AP, Annotations),
( new_decl(Decl)
-> true
; assert_predicate_options(M:Name/Arity, AP, Annotations, false)
-> true
; assertz(new_decl(Decl)),
debug(predicate_options(decl), '~q', [Decl])
),
fail.
option_decl(_, _).
system_module(system) :- !.
system_module(Module) :-
sub_atom(Module, 0, _, _, $).
/*******************************
* MISC *
*******************************/
canonical_pi(M:Name//Arity, M:Name/PArity) :-
integer(Arity),
PArity is Arity+2.
canonical_pi(PI, PI).
%% resolve_module(:PI, -DefPI) is det.
%
% Find the real predicate indicator pointing to the definition
% module of PI. This is similar to using predicate_property/3 with
% the property imported_from, but using
% '$get_predicate_attribute'/3 avoids auto-importing the
% predicate.
resolve_module(Module:Name/Arity, DefM:Name/Arity) :-
functor(Head, Name, Arity),
( '$get_predicate_attribute'(Module:Head, imported, M)
-> DefM = M
; DefM = Module
).
/*******************************
* MESSAGES *
*******************************/
:- multifile
prolog:message//1.
prolog:message(predicate_option_error(Formal, Location)) -->
error_location(Location),
'$messages':term_message(Formal). % TBD: clean interface
prolog:message(check_options(new(Decls))) -->
[ 'Inferred declarations:'-[], nl ],
new_decls(Decls).
error_location(file_char_count(File, CharPos)) -->
{ filepos_line(File, CharPos, Line, LinePos) },
[ '~w:~d:~d: '-[File, Line, LinePos] ].
error_location(clause(ClauseRef)) -->
{ clause_property(ClauseRef, file(File)),
clause_property(ClauseRef, line_count(Line))
}, !,
[ '~w:~d: '-[File, Line] ].
error_location(clause(ClauseRef)) -->
[ 'Clause ~q: '-[ClauseRef] ].
filepos_line(File, CharPos, Line, LinePos) :-
setup_call_cleanup(
( open(File, read, In),
open_null_stream(Out)
),
( Skip is CharPos-1,
copy_stream_data(In, Out, Skip),
stream_property(In, position(Pos)),
stream_position_data(line_count, Pos, Line),
stream_position_data(line_position, Pos, LinePos)
),
( close(Out),
close(In)
)).
new_decls([]) --> [].
new_decls([H|T]) -->
[ ' :- ~q'-[H], nl ],
new_decls(T).
/*******************************
* SYSTEM DECLARATIONS *
*******************************/
:- use_module(library(dialect/swi/syspred_options)).

141
swi/library/predopts.pl Normal file
View File

@@ -0,0 +1,141 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2011, VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module('$predopts',
[
]).
:- multifile
predicate_options:option_decl/3,
predicate_options:pred_option/3.
:- multifile % provided by library(predicate_options)
system:predicate_option_type/2,
system:predicate_option_mode/2.
:- public
option_clauses//4.
%% expand_predicate_options(:PI, +Arg, +OptionList, -Clauses) is det.
%
% Term-expansion code for predicate_options(PI, Arg, OptionList).
expand_predicate_options(PI, Arg, Options,
[ predicate_options:option_decl(Head, M, Arg),
(:-multifile(M:'$pred_option'/4))
| OptionClauses
]) :-
canonical_pi(PI, CPI),
prolog_load_context(module, M0),
strip_module(M0:CPI, M, Name/Arity),
functor(Head, Name, Arity),
( is_list(Options)
-> true
; throw(error(type_error(list, Options), _))
),
phrase(option_clauses(Options, Head, M, Arg), OptionClauses0),
qualify_list(OptionClauses0, M0, OptionClauses).
qualify_list([], _, []).
qualify_list([H0|T0], M, [H|T]) :-
qualify(H0, M, H),
qualify_list(T0, M, T).
qualify(M:Term, M, Term) :- !.
qualify(QTerm, _, QTerm).
option_clauses([], _, _, _) --> [].
option_clauses([H|T], Head, M, A) -->
option_clause(H, Head, M),
option_clauses(T, Head, M, A).
option_clause(Var, _, _) -->
{ var(Var), !,
throw(error(instantiation_error, _))
}.
option_clause(pass_to(PI0, Arg), Head, M) --> !,
{ canonical_pi(PI0, PI),
strip_module(M:PI, TM, Name/Arity),
functor(THead, Name, Arity),
Clause = ('$pred_option'(Head, pass_to(PI0, Arg), Opt, Seen) :-
\+ memberchk(PI-Arg, Seen),
predicate_options:pred_option(TM:THead, Opt, [PI-Arg|Seen]))
},
[ M:Clause ].
option_clause(Option, Head, M) -->
{ Option =.. [Name|ModeAndTypes], !,
modes_and_types(ModeAndTypes, Args, Body),
Opt =.. [Name|Args],
Clause = ('$pred_option'(Head, Option, Opt, _) :- Body)
},
[ M:Clause ].
option_clause(Option, _, _) -->
{ throw(error(type_error(option_specifier, Option)))
}.
modes_and_types([], [], true).
modes_and_types([H|T], [A|AT], Body) :-
mode_and_type(H, A, Body0),
( T == []
-> Body = Body0,
AT = []
; Body0 == true
-> modes_and_types(T, AT, Body)
; Body = (Body0,Body1),
modes_and_types(T, AT, Body1)
).
mode_and_type(-Type, A, (predicate_option_mode(output, A), Body)) :- !,
type_goal(Type, A, Body).
mode_and_type(+Type, A, Body) :- !,
type_goal(Type, A, Body).
mode_and_type(Type, A, Body) :-
type_goal(Type, A, Body).
type_goal(Type, A, predicate_option_type(Type, A)).
%% canonical_pi(+PIIn, -PIout)
canonical_pi(M:Name//Arity, M:Name/PArity) :-
integer(Arity), !,
PArity is Arity+2.
canonical_pi(Name//Arity, Name/PArity) :-
integer(Arity), !,
PArity is Arity+2.
canonical_pi(PI, PI).
/*******************************
* EXPAND *
*******************************/
%system:term_expansion((:- predicate_options(PI, Arg, Options)), Clauses) :-
% expand_predicate_options(PI, Arg, Options, Clauses).

675
swi/library/prolog_clause.pl Normal file
View File

@@ -0,0 +1,675 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2011, University of Amsterdam
VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(prolog_clause,
[ clause_info/4, % +ClauseRef, -File, -TermPos, -VarNames
predicate_name/2, % +Head, -Name
clause_name/2 % +ClauseRef, -Name
]).
:- use_module(library(lists), [append/3]).
:- use_module(library(occurs), [sub_term/2]).
:- use_module(library(debug)).
:- use_module(library(listing)).
:- use_module(library(prolog_source)).
:- public % called from library(trace/clause)
unify_term/2,
make_varnames/5,
do_make_varnames/3.
:- multifile
make_varnames_hook/5.
/** <module> Get detailed source-information about a clause
This module started life as part of the GUI tracer. As it is generally
useful for debugging purposes it has moved to the general Prolog
library.
The tracer library library(trace/clause) adds caching and dealing with
dynamic predicates using listing to XPCE objects to this. Note that
clause_info/4 as below can be slow.
*/
%% clause_info(+ClauseRef, -File, -TermPos, -VarNames)
%
% Fetches source information for the given clause. File is the
% file from which the clause was loaded. TermPos describes the
% source layout in a format compatible to the subterm_positions
% option of read_term/2. VarNames provides access to the variable
% allocation in a stack-frame. See make_varnames/5 for details.
clause_info(ClauseRef, File, TermPos, NameOffset) :-
( debugging(clause_info)
-> clause_name(ClauseRef, Name),
debug(clause_info, 'clause_info(~w) (~w)... ',
[ClauseRef, Name])
; true
),
clause_property(ClauseRef, file(File)),
'$clause'(Head, Body, ClauseRef, VarOffset),
( Body == true
-> DecompiledClause = Head
; DecompiledClause = (Head :- Body)
),
File \== user, % loaded using ?- [user].
clause_property(ClauseRef, line_count(LineNo)),
( module_property(Module, file(File))
-> true
; strip_module(user:Head, Module, _)
),
debug(clause_info, 'from ~w:~d ... ', [File, LineNo]),
read_term_at_line(File, LineNo, Module, Clause, TermPos0, VarNames),
debug(clause_info, 'read ...', []),
unify_clause(Clause, DecompiledClause, Module, TermPos0, TermPos),
debug(clause_info, 'unified ...', []),
make_varnames(Clause, DecompiledClause, VarOffset, VarNames, NameOffset),
debug(clause_info, 'got names~n', []), !.
%% unify_term(+T1, +T2)
%
% Unify the two terms, where T2 is created by writing the term and
% reading it back in, but be aware that rounding problems may
% cause floating point numbers not to unify. Also, if the initial
% term has a string object, it is written as "..." and read as a
% code-list. We compensate for that.
%
% NOTE: Called directly from library(trace/clause) for the GUI
% tracer.
unify_term(X, X) :- !.
unify_term(X1, X2) :-
compound(X1),
compound(X2),
functor(X1, F, Arity),
functor(X2, F, Arity), !,
unify_args(0, Arity, X1, X2).
unify_term(X, Y) :-
float(X), float(Y), !.
unify_term(X, Y) :-
string(X),
is_list(Y),
string_to_list(X, Y), !.
unify_term(_, Y) :-
Y == '...', !. % elipses left by max_depth
unify_term(_:X, Y) :-
unify_term(X, Y), !.
unify_term(X, _:Y) :-
unify_term(X, Y), !.
unify_term(X, Y) :-
format('[INTERNAL ERROR: Diff:~n'),
portray_clause(X),
format('~N*** <->~n'),
portray_clause(Y),
break.
unify_args(N, N, _, _) :- !.
unify_args(I, Arity, T1, T2) :-
A is I + 1,
arg(A, T1, A1),
arg(A, T2, A2),
unify_term(A1, A2),
unify_args(A, Arity, T1, T2).
%% read_term_at_line(+File, +Line, +Module,
%% -Clause, -TermPos, -VarNames) is semidet.
%
% Read a term from File at Line.
read_term_at_line(File, Line, Module, Clause, TermPos, VarNames) :-
catch(open(File, read, In), _, fail),
call_cleanup(
read_source_term_at_location(
In, Clause,
[ line(Line),
module(Module),
subterm_positions(TermPos),
variable_names(VarNames)
]),
close(In)).
%% make_varnames(+ReadClause, +DecompiledClause,
%% +Offsets, +Names, -Term) is det.
%
% Create a Term varnames(...) where each argument contains the name
% of the variable at that offset. If the read Clause is a DCG rule,
% name the two last arguments <DCG_list> and <DCG_tail>
%
% This predicate calles the multifile predicate
% make_varnames_hook/5 with the same arguments to allow for user
% extensions. Extending this predicate is needed if a compiler
% adds additional arguments to the clause head that must be made
% visible in the GUI tracer.
%
% @param Offsets List of Offset=Var
% @param Names List of Name=Var
make_varnames(ReadClause, DecompiledClause, Offsets, Names, Term) :-
make_varnames_hook(ReadClause, DecompiledClause, Offsets, Names, Term), !.
make_varnames((Head --> _Body), _, Offsets, Names, Bindings) :- !,
functor(Head, _, Arity),
In is Arity,
memberchk(In=IVar, Offsets),
Names1 = ['<DCG_list>'=IVar|Names],
Out is Arity + 1,
memberchk(Out=OVar, Offsets),
Names2 = ['<DCG_tail>'=OVar|Names1],
make_varnames(xx, xx, Offsets, Names2, Bindings).
make_varnames(_, _, Offsets, Names, Bindings) :-
length(Offsets, L),
functor(Bindings, varnames, L),
do_make_varnames(Offsets, Names, Bindings).
do_make_varnames([], _, _).
do_make_varnames([N=Var|TO], Names, Bindings) :-
( find_varname(Var, Names, Name)
-> true
; Name = '_'
),
AN is N + 1,
arg(AN, Bindings, Name),
do_make_varnames(TO, Names, Bindings).
find_varname(Var, [Name = TheVar|_], Name) :-
Var == TheVar, !.
find_varname(Var, [_|T], Name) :-
find_varname(Var, T, Name).
%% unify_clause(+Read, +Decompiled, +Module, +ReadTermPos,
%% -RecompiledTermPos).
%
% What you read isn't always what goes into the database. The task
% of this predicate is to establish the relation between the term
% read from the file and the result from decompiling the clause.
%
% This predicate calls the multifile predicate unify_clause_hook/5
% with the same arguments to support user extensions.
%
% @tbd This really must be more flexible, dealing with much
% more complex source-translations, falling back to a
% heuristic method locating as much as possible.
:- multifile
unify_clause_hook/5.
unify_clause(Read, Read, _, TermPos, TermPos) :- !.
% XPCE send-methods
unify_clause(Read, Decompiled, Module, TermPoso, TermPos) :-
unify_clause_hook(Read, Decompiled, Module, TermPoso, TermPos), !.
unify_clause(:->(Head, Body), (PlHead :- PlBody), _, TermPos0, TermPos) :- !,
pce_method_clause(Head, Body, PlHead, PlBody, TermPos0, TermPos).
% XPCE get-methods
unify_clause(:<-(Head, Body), (PlHead :- PlBody), _, TermPos0, TermPos) :- !,
pce_method_clause(Head, Body, PlHead, PlBody, TermPos0, TermPos).
% Unit test clauses
unify_clause((TH :- Body),
(_:'unit body'(_, _) :- !, Body), _,
TP0, TP) :-
( TH = test(_,_)
; TH = test(_)
), !,
TP0 = term_position(F,T,FF,FT,[HP,BP]),
TP = term_position(F,T,FF,FT,[HP,term_position(0,0,0,0,[FF-FT,BP])]).
% module:head :- body
unify_clause((Head :- Read),
(Head :- _M:Compiled), Module, TermPos0, TermPos) :-
unify_clause((Head :- Read), (Head :- Compiled), Module, TermPos0, TermPos1),
TermPos1 = term_position(TA,TZ,FA,FZ,[PH,PB]),
TermPos = term_position(TA,TZ,FA,FZ,
[ PH,
term_position(0,0,0,0,[0-0,PB])
]).
unify_clause(Read, Compiled1, Module, TermPos0, TermPos) :-
Read = (_ --> List, _),
is_list(List),
ci_expand(Read, Compiled2, Module),
Compiled2 = (DH :- _),
functor(DH, _, Arity),
DArg is Arity - 1,
arg(DArg, DH, List),
nonvar(List),
TermPos0 = term_position(F,T,FF,FT,[ HP,
term_position(_,_,_,_,[_,BP])
]), !,
TermPos1 = term_position(F,T,FF,FT,[ HP, BP ]),
match_module(Compiled2, Compiled1, TermPos1, TermPos).
% general term-expansion
unify_clause(Read, Compiled1, Module, TermPos0, TermPos) :-
ci_expand(Read, Compiled2, Module),
match_module(Compiled2, Compiled1, TermPos0, TermPos).
% I don't know ...
unify_clause(_, _, _, _, _) :-
debug(clause_info, 'Could not unify clause', []),
fail.
unify_clause_head(H1, H2) :-
strip_module(H1, _, H),
strip_module(H2, _, H).
ci_expand(Read, Compiled, Module) :-
catch(setup_call_cleanup('$set_source_module'(Old, Module),
expand_term(Read, Compiled),
'$set_source_module'(_, Old)),
E,
expand_failed(E, Read)).
match_module((H1 :- B1), (H2 :- B2), Pos0, Pos) :- !,
unify_clause_head(H1, H2),
unify_body(B1, B2, Pos0, Pos).
match_module(H1, H2, Pos, Pos) :- % deal with facts
unify_clause_head(H1, H2).
%% expand_failed(+Exception, +Term)
%
% When debugging, indicate that expansion of the term failed.
expand_failed(E, Read) :-
debugging(clause_info),
message_to_string(E, Msg),
debug(clause_info, 'Term-expand ~p failed: ~w', [Read, Msg]),
fail.
%% unify_body(+Read, +Decompiled, +Pos0, -Pos)
%
% Deal with translations implied by the compiler. For example,
% compiling (a,b),c yields the same code as compiling a,b,c.
%
% Pos0 and Pos still include the term-position of the head.
unify_body(B, B, Pos, Pos) :-
does_not_dcg_after_binding(B, Pos), !.
unify_body(R, D,
term_position(F,T,FF,FT,[HP,BP0]),
term_position(F,T,FF,FT,[HP,BP])) :-
ubody(R, D, BP0, BP).
%% does_not_dcg_after_binding(+ReadBody, +ReadPos) is semidet.
%
% True if ReadPos/ReadPos does not contain DCG delayed
% unifications.
%
% @tbd We should pass that we are in a DCG; if we are not there
% is no reason for this test.
does_not_dcg_after_binding(B, Pos) :-
acyclic_term(B), % X = call(X)
\+ sub_term(brace_term_position(_,_,_), Pos),
\+ (sub_term((Cut,_=_), B), Cut == !), !.
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Some remarks.
a --> { x, y, z }.
This is translated into "(x,y),z), X=Y" by the DCG translator, after
which the compiler creates "a(X,Y) :- x, y, z, X=Y".
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
%% ubody(+Read, +Decompiled, +TermPosRead, -TermPosForDecompiled)
%
% @param Read Clause read _after_ expand_term/2
% @param Decompiled Decompiled clause
% @param TermPosRead Sub-term positions of source
ubody(B, B, P, P) :-
does_not_dcg_after_binding(B, P), !.
ubody(X, call(X), % X = call(X)
From-To,
term_position(From, To, From, To, [From-To])) :- !.
ubody(B0, B,
brace_term_position(F,T,A0),
Pos) :-
B0 = (_,_=_), !,
T1 is T - 1,
ubody(B0, B,
term_position(F,T,
F,T,
[A0,T1-T]),
Pos).
ubody(B0, B,
brace_term_position(F,T,A0),
term_position(F,T,F,T,[A])) :- !,
ubody(B0, B, A0, A).
ubody(C0, C, P0, P) :-
nonvar(C0), nonvar(C),
C0 = (_,_), C = (_,_), !,
conj(C0, P0, GL, PL),
mkconj(C, P, GL, PL).
ubody(X0, X,
term_position(F,T,FF,TT,PA0),
term_position(F,T,FF,TT,PA)) :-
meta(X0), !,
X0 =.. [_|A0],
X =.. [_|A],
ubody_list(A0, A, PA0, PA).
% 5.7.X optimizations
ubody(_=_, true, % singleton = Any
term_position(F,T,_FF,_TT,_PA),
F-T) :- !.
ubody(_==_, fail, % singleton/firstvar == Any
term_position(F,T,_FF,_TT,_PA),
F-T) :- !.
ubody(A1=B1, B2=A2, % Term = Var --> Var = Term
term_position(F,T,FF,TT,[PA1,PA2]),
term_position(F,T,FF,TT,[PA2,PA1])) :-
(A1==B1) =@= (B2==A2), !,
A1 = A2, B1=B2.
ubody(A1==B1, B2==A2, % const == Var --> Var == const
term_position(F,T,FF,TT,[PA1,PA2]),
term_position(F,T,FF,TT,[PA2,PA1])) :-
(A1==B1) =@= (B2==A2), !,
A1 = A2, B1=B2.
ubody(A is B - C, A is B + C2, Pos, Pos) :-
integer(C),
C2 =:= -C, !.
ubody_list([], [], [], []).
ubody_list([G0|T0], [G|T], [PA0|PAT0], [PA|PAT]) :-
ubody(G0, G, PA0, PA),
ubody_list(T0, T, PAT0, PAT).
conj(Goal, Pos, GoalList, PosList) :-
conj(Goal, Pos, GoalList, [], PosList, []).
conj((A,B), term_position(_,_,_,_,[PA,PB]), GL, TG, PL, TP) :- !,
conj(A, PA, GL, TGA, PL, TPA),
conj(B, PB, TGA, TG, TPA, TP).
conj((A,B), brace_term_position(_,T,PA), GL, TG, PL, TP) :-
B = (_=_), !,
conj(A, PA, GL, TGA, PL, TPA),
T1 is T - 1,
conj(B, T1-T, TGA, TG, TPA, TP).
conj((!,(S=SR)), F-T, [!,S=SR|TG], TG, [F-T,F1-T1|TP], TP) :-
F1 is F+1,
T1 is T+1.
conj(A, P, [A|TG], TG, [P|TP], TP).
mkconj(Goal, Pos, GoalList, PosList) :-
mkconj(Goal, Pos, GoalList, [], PosList, []).
mkconj(Conj, term_position(0,0,0,0,[PA,PB]), GL, TG, PL, TP) :-
nonvar(Conj),
Conj = (A,B), !,
mkconj(A, PA, GL, TGA, PL, TPA),
mkconj(B, PB, TGA, TG, TPA, TP).
mkconj(A0, P0, [A|TG], TG, [P|TP], TP) :-
ubody(A, A0, P, P0).
/*******************************
* PCE STUFF (SHOULD MOVE) *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
<method>(Receiver, ... Arg ...) :->
Body
mapped to:
send_implementation(Id, <method>(...Arg...), Receiver)
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
pce_method_clause(Head, Body, _:PlHead, PlBody, TermPos0, TermPos) :- !,
pce_method_clause(Head, Body, PlBody, PlHead, TermPos0, TermPos).
pce_method_clause(Head, Body,
send_implementation(_Id, Msg, Receiver), PlBody,
TermPos0, TermPos) :- !,
debug(clause_info, 'send method ...', []),
arg(1, Head, Receiver),
functor(Head, _, Arity),
pce_method_head_arguments(2, Arity, Head, Msg),
debug(clause_info, 'head ...', []),
pce_method_body(Body, PlBody, TermPos0, TermPos).
pce_method_clause(Head, Body,
get_implementation(_Id, Msg, Receiver, Result), PlBody,
TermPos0, TermPos) :- !,
debug(clause_info, 'get method ...', []),
arg(1, Head, Receiver),
debug(clause_info, 'receiver ...', []),
functor(Head, _, Arity),
arg(Arity, Head, PceResult),
debug(clause_info, '~w?~n', [PceResult = Result]),
pce_unify_head_arg(PceResult, Result),
Ar is Arity - 1,
pce_method_head_arguments(2, Ar, Head, Msg),
debug(clause_info, 'head ...', []),
pce_method_body(Body, PlBody, TermPos0, TermPos).
pce_method_head_arguments(N, Arity, Head, Msg) :-
N =< Arity, !,
arg(N, Head, PceArg),
PLN is N - 1,
arg(PLN, Msg, PlArg),
pce_unify_head_arg(PceArg, PlArg),
debug(clause_info, '~w~n', [PceArg = PlArg]),
NextArg is N+1,
pce_method_head_arguments(NextArg, Arity, Head, Msg).
pce_method_head_arguments(_, _, _, _).
pce_unify_head_arg(V, A) :-
var(V), !,
V = A.
pce_unify_head_arg(A:_=_, A) :- !.
pce_unify_head_arg(A:_, A).
% pce_method_body(+SrcBody, +DbBody, +TermPos0, -TermPos
%
% Unify the body of an XPCE method. Goal-expansion makes this
% rather tricky, especially as we cannot call XPCE's expansion
% on an isolated method.
%
% TermPos0 is the term-position term of the whole clause!
%
% Further, please note that the body of the method-clauses reside
% in another module than pce_principal, and therefore the body
% starts with an I_CONTEXT call. This implies we need a
% hypothetical term-position for the module-qualifier.
pce_method_body(A0, A, TermPos0, TermPos) :-
TermPos0 = term_position(F, T, FF, FT,
[ HeadPos,
BodyPos0
]),
TermPos = term_position(F, T, FF, FT,
[ HeadPos,
term_position(0,0,0,0, [0-0,BodyPos])
]),
pce_method_body2(A0, A, BodyPos0, BodyPos).
pce_method_body2(::(_,A0), A, TermPos0, TermPos) :- !,
TermPos0 = term_position(_, _, _, _, [_Cmt,BodyPos0]),
TermPos = BodyPos,
expand_goal(A0, A, BodyPos0, BodyPos).
pce_method_body2(A0, A, TermPos0, TermPos) :-
A0 =.. [Func,B0,C0],
control_op(Func), !,
A =.. [Func,B,C],
TermPos0 = term_position(F, T, FF, FT,
[ BP0,
CP0
]),
TermPos = term_position(F, T, FF, FT,
[ BP,
CP
]),
pce_method_body2(B0, B, BP0, BP),
expand_goal(C0, C, CP0, CP).
pce_method_body2(A0, A, TermPos0, TermPos) :-
expand_goal(A0, A, TermPos0, TermPos).
control_op(',').
control_op((;)).
control_op((->)).
control_op((*->)).
/*******************************
* EXPAND_GOAL SUPPORT *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
With the introduction of expand_goal, it is increasingly hard to relate
the clause from the database to the actual source. For one thing, we do
not know the compilation module of the clause (unless we want to
decompile it).
Goal expansion can translate goals into control-constructs, multiple
clauses, or delete a subgoal.
To keep track of the source-locations, we have to redo the analysis of
the clause as defined in init.pl
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
expand_goal(G, call(G), P, term_position(0,0,0,0,[P])) :-
var(G), !.
expand_goal(G, G, P, P) :-
var(G), !.
expand_goal(M0, M, P0, P) :-
meta(M0), !,
P0 = term_position(F,T,FF,FT,PL0),
P = term_position(F,T,FF,FT,PL),
functor(M0, Functor, Arity),
functor(M, Functor, Arity),
expand_meta_args(PL0, PL, 1, M0, M).
expand_goal(A, B, P0, P) :-
goal_expansion(A, B0, P0, P1), !,
expand_goal(B0, B, P1, P).
expand_goal(A, A, P, P).
expand_meta_args([], [], _, _, _).
expand_meta_args([P0|T0], [P|T], I, M0, M) :-
arg(I, M0, A0),
arg(I, M, A),
expand_goal(A0, A, P0, P),
NI is I + 1,
expand_meta_args(T0, T, NI, M0, M).
meta((_ , _)).
meta((_ ; _)).
meta((_ -> _)).
meta((_ *-> _)).
meta((\+ _)).
meta((not(_))).
meta((call(_))).
meta((once(_))).
meta((ignore(_))).
meta((forall(_, _))).
goal_expansion(send(R, Msg), send_class(R, _, SuperMsg), P, P) :-
compound(Msg),
Msg =.. [send_super, Selector | Args], !,
SuperMsg =.. [Selector|Args].
goal_expansion(get(R, Msg, A), get_class(R, _, SuperMsg, A), P, P) :-
compound(Msg),
Msg =.. [get_super, Selector | Args], !,
SuperMsg =.. [Selector|Args].
goal_expansion(send_super(R, Msg), send_class(R, _, Msg), P, P).
goal_expansion(get_super(R, Msg, V), get_class(R, _, Msg, V), P, P).
goal_expansion(SendSuperN, send_class(R, _, Msg), P, P) :-
compound(SendSuperN),
SendSuperN =.. [send_super, R, Sel | Args],
Msg =.. [Sel|Args].
goal_expansion(SendN, send(R, Msg), P, P) :-
compound(SendN),
SendN =.. [send, R, Sel | Args],
atom(Sel), Args \== [],
Msg =.. [Sel|Args].
goal_expansion(GetSuperN, get_class(R, _, Msg, Answer), P, P) :-
compound(GetSuperN),
GetSuperN =.. [get_super, R, Sel | AllArgs],
append(Args, [Answer], AllArgs),
Msg =.. [Sel|Args].
goal_expansion(GetN, get(R, Msg, Answer), P, P) :-
compound(GetN),
GetN =.. [get, R, Sel | AllArgs],
append(Args, [Answer], AllArgs),
atom(Sel), Args \== [],
Msg =.. [Sel|Args].
goal_expansion(G0, G, P, P) :-
user:goal_expansion(G0, G), % TBD: we need the module!
G0 \== G. % \=@=?
/*******************************
* PRINTABLE NAMES *
*******************************/
:- module_transparent
predicate_name/2.
:- multifile
user:prolog_predicate_name/2,
user:prolog_clause_name/2.
hidden_module(user).
hidden_module(system).
hidden_module(pce_principal). % should be config
hidden_module(Module) :- % SWI-Prolog specific
import_module(Module, system).
thaffix(1, st) :- !.
thaffix(2, nd) :- !.
thaffix(_, th).
%% predicate_name(:Head, -PredName:string) is det.
%
% Describe a predicate as [Module:]Name/Arity.
predicate_name(Predicate, PName) :-
strip_module(Predicate, Module, Head),
( user:prolog_predicate_name(Module:Head, PName)
-> true
; functor(Head, Name, Arity),
( hidden_module(Module)
-> format(string(PName), '~q/~d', [Name, Arity])
; format(string(PName), '~q:~q/~d', [Module, Name, Arity])
)
).
%% clause_name(+Ref, -Name)
%
% Provide a suitable description of the indicated clause.
clause_name(Ref, Name) :-
user:prolog_clause_name(Ref, Name), !.
clause_name(Ref, Name) :-
nth_clause(Head, N, Ref), !,
predicate_name(Head, PredName),
thaffix(N, Th),
format(string(Name), '~d-~w clause of ~w', [N, Th, PredName]).
clause_name(_, '<meta-call>').

1508
swi/library/prolog_colour.pl Normal file
View File

File diff suppressed because it is too large Load Diff

238
swi/library/prolog_source.pl Normal file
View File

@@ -0,0 +1,238 @@
/* $Id: prolog_source.pl,v 1.1 2008-02-12 17:03:53 vsc Exp $
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2005, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(prolog_source,
[ prolog_read_source_term/4, % +Stream, -Term, -Expanded, +Options
prolog_open_source/2, % +Source, -Stream
prolog_close_source/1, % +Stream
prolog_canonical_source/2 % +Spec, -Id
]).
:- use_module(operators).
:- use_module(debug).
/** <module> Examine Prolog source-files
The modile prolog_source.pl provides predicates to open, close and read
terms from Prolog source-files. This may seem easy, but there are a
couple of problems that must be taken care of.
* Source files may start with #!, supporting PrologScript
* Embeded operators declarations must be taken into account
* Style-check options must be taken into account
* Operators and style-check options may be implied by directives
* On behalf of the development environment we also wish to
parse PceEmacs buffers
This module concentrates these issues in a single library. Intended
users of the library are:
$ prolog_xref.pl : The Prolog cross-referencer
$ PceEmacs : Emacs syntax-colouring
$ PlDoc : The documentation framework
*/
:- thread_local
open_source/2. % Stream, State
:- multifile
requires_library/2,
prolog:xref_source_identifier/2, % +Source, -Id
prolog:xref_open_source/2. % +SourceId, -Stream
:- if(current_prolog_flag(dialect, yap)).
% yap
'$style_check'([Singleton,Discontiguous,Multiple], StyleF) :-
(
prolog_flag(single_var_warnings,on)
->
Singleton = singleton
;
Singleton = -singleton
),
(
prolog_flag(discontiguous_warnings,on)
->
Discontiguous = discontiguous
;
Discontiguous = -discontiguous
),
(
prolog_flag(redefine_warnings,on)
->
Multiple = multiple
;
Multiple = -multiple
),
style_check(StyleF).
:- endif.
/*******************************
* READING *
*******************************/
%% prolog_read_source_term(+In, -Term, -Expanded, +Options) is det.
%
% Read a term from a Prolog source-file. Options is a option list
% as normally provided to read_term/3.
%
% @param Term Term read
% @param Expanded Result of term-expansion on the term
prolog_read_source_term(In, Term, Expanded, Options) :-
'$set_source_module'(SM, SM),
read_term(In, Term,
[ module(SM)
| Options
]),
expand(Term, Expanded),
update_state(Expanded).
expand(Var, Var) :-
var(Var), !.
expand(Term, _) :-
requires_library(Term, Lib),
ensure_loaded(user:Lib),
fail.
expand('$:-'(X), '$:-'(X)) :- !, % boot module
style_check(+dollar).
expand(Term, Expanded) :-
expand_term(Term, Expanded).
%% requires_library(+Term, -Library)
%
% known expansion hooks. May be expanded as multifile predicate.
requires_library((:- emacs_begin_mode(_,_,_,_,_)), library(emacs_extend)).
requires_library((:- draw_begin_shape(_,_,_,_)), library(pcedraw)).
%% update_state(+Expanded) is det.
%
% Update operators and style-check options from the expanded term.
update_state([]) :- !.
update_state([H|T]) :- !,
update_state(H),
update_state(T).
update_state((:- Directive)) :- !,
update_directive(Directive).
update_state((?- Directive)) :- !,
update_directive(Directive).
update_state(_).
update_directive(module(Module, Public)) :- !,
'$set_source_module'(_, Module),
public_operators(Public).
update_directive(op(P,T,N)) :- !,
'$set_source_module'(SM, SM),
push_op(P,T,SM:N).
update_directive(style_check(Style)) :-
style_check(Style), !.
update_directive(_).
public_operators([]).
public_operators([H|T]) :- !,
( H = op(_,_,_)
-> update_directive(H)
; true
),
public_operators(T).
/*******************************
* SOURCES *
*******************************/
%% prolog_open_source(+CanonicalId:atomic, -Stream:stream) is det.
%
% Open source with given canonical id (see
% prolog_canonical_source/2) and remove the #! line if any.
% Streams opened using this predicate must be closed using
% prolog_close_source/1. Typically using the skeleton below. Using
% this skeleton, operator and style-check options are
% automatically restored to the values before opening the source.
%
% ==
% process_source(Src) :-
% prolog_open_source(Src, In),
% call_cleanup(process(Src), prolog_close_source(In)).
% ==
prolog_open_source(Src, Fd) :-
( prolog:xref_open_source(Src, Fd)
-> true
; open(Src, read, Fd)
),
( peek_char(Fd, #) % Deal with #! script
-> skip(Fd, 10)
; true
),
push_operators([]),
'$set_source_module'(SM, SM),
'$style_check'(Style, Style),
asserta(open_source(Fd, state(Style, SM))).
%% prolog_close_source(+In:stream) is det.
%
% Close a stream opened using prolog_open_source/2. Restores
% operator and style options.
prolog_close_source(In) :-
pop_operators,
( retract(open_source(In, state(Style, SM)))
-> '$style_check'(_, Style),
'$set_source_module'(_, SM)
; assertion(fail)
),
close(In).
%% prolog_canonical_source(+SourceSpec:ground, -Id:atomic) is det.
%
% Given a user-specification of a source, generate a unique and
% indexable identifier for it. For files we use the
% prolog_canonical absolute filename.
prolog_canonical_source(Src, Id) :- % Call hook
prolog:xref_source_identifier(Src, Id), !.
prolog_canonical_source(User, user) :-
User == user, !.
prolog_canonical_source(Source, Src) :-
absolute_file_name(Source,
[ file_type(prolog),
access(read),
file_errors(fail)
],
Src), !.
prolog_canonical_source(Source, Src) :-
var(Source), !,
Src = Source.

1455
swi/library/prolog_xref.pl Normal file
View File

File diff suppressed because it is too large Load Diff

401
swi/library/quintus.pl Normal file
View File

@@ -0,0 +1,401 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2008, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(quintus,
[ % unix/1,
% file_exists/1,
abs/2,
sin/2,
cos/2,
tan/2,
log/2,
log10/2,
pow/3,
ceiling/2,
floor/2,
round/2,
acos/2,
asin/2,
atan/2,
atan2/3,
sign/2,
sqrt/2,
genarg/3,
(mode)/1,
(public)/1,
no_style_check/1,
otherwise/0,
simple/1,
% statistics/2, % Please access as quintus:statistics/2
prolog_flag/2,
date/1, % -date(Year, Month, Day)
current_stream/3, % ?File, ?Mode, ?Stream
stream_position/3, % +Stream, -Old, +New
skip_line/0,
skip_line/1, % +Stream
compile/1, % +File(s)
atom_char/2,
midstring/3, % ABC, B, AC
midstring/4, % ABC, B, AC, LenA
midstring/5, % ABC, B, AC, LenA, LenB
midstring/6, % ABC, B, AC, LenA, LenB, LenC
raise_exception/1, % +Exception
on_exception/3 % +Ball, :Goal, :Recover
]).
:- use_module(library(lists), [member/2]).
/** <module> Quintus compatibility
This module defines several predicates from the Quintus Prolog
libraries. Note that our library structure is totally different. If this
library were complete, Prolog code could be ported by removing the
use_module/1 declarations, relying on the SWI-Prolog autoloader.
Bluffers guide to porting:
* Remove =|use_module(library(...))|=
* Run =|?- list_undefined.|=
* Fix problems
Of course, this library is incomplete ...
*/
/********************************
* SYSTEM INTERACTION *
*********************************/
% %% unix(+Action)
% % interface to Unix.
% unix(system(Command)) :-
% shell(Command).
% unix(shell(Command)) :-
% shell(Command).
% unix(shell) :-
% shell.
% unix(access(File, 0)) :-
% access_file(File, read).
% unix(cd) :-
% expand_file_name(~, [Home]),
% working_directory(_, Home).
% unix(cd(Dir)) :-
% working_directory(_, Dir).
% unix(args(L)) :-
% current_prolog_flag(argv, L).
% unix(argv(L)) :-
% current_prolog_flag(argv, S),
% maplist(to_prolog, S, L).
% to_prolog(S, A) :-
% name(S, L),
% name(A, L).
/********************************
* META PREDICATES *
*********************************/
%% otherwise
%
% For (A -> B ; otherwise -> C)
% otherwise.
/********************************
* ARITHMETIC *
*********************************/
%% abs(+Number, -Absolute)
% Unify `Absolute' with the absolute value of `Number'.
abs(Number, Absolute) :-
Absolute is abs(Number).
%% sin(+Angle, -Sine) is det.
%% cos(+Angle, -Cosine) is det.
%% tan(+Angle, -Tangent) is det.
%% log(+X, -NatLog) is det.
%% log10(+X, -Log) is det.
%
% Math library predicates. SWI-Prolog (and ISO) support these as
% functions under is/2, etc.
sin(A, V) :- V is sin(A).
cos(A, V) :- V is cos(A).
tan(A, V) :- V is tan(A).
log(A, V) :- V is log(A).
log10(X, V) :- V is log10(X).
pow(X,Y,V) :- V is X**Y.
ceiling(X, V) :- V is ceil(X).
floor(X, V) :- V is floor(X).
round(X, V) :- V is round(X).
sqrt(X, V) :- V is sqrt(X).
acos(X, V) :- V is acos(X).
asin(X, V) :- V is asin(X).
atan(X, V) :- V is atan(X).
atan2(Y, X, V) :- V is atan(Y, X).
sign(X, V) :- V is sign(X).
/*******************************
* TERM MANIPULATION *
*******************************/
%% genarg(?Index, +Term, ?Arg) is nondet.
%
% Generalised version of ISO arg/3. SWI-Prolog's arg/3 is already
% genarg/3.
genarg(N, T, A) :- % SWI-Prolog arg/3 is generic
arg(N, T, A).
/*******************************
* FLAGS *
*******************************/
%% prolog_flag(?Flag, ?Value) is nondet.
%
% Same as ISO current_prolog_flag/2. Maps =version=.
%
% @bug Should map relevant Quintus flag identifiers.
% prolog_flag(version, Version) :- !,
% current_prolog_flag(version_data, swi(Major, Minor, Patch, _)),
% current_prolog_flag(arch, Arch),
% current_prolog_flag(compiled_at, Compiled),
% atomic_list_concat(['SWI-Prolog ',
% Major, '.', Minor, '.', Patch,
% ' (', Arch, '): ', Compiled], Version).
% prolog_flag(Flag, Value) :-
% current_prolog_flag(Flag, Value).
/*******************************
* STATISTICS *
*******************************/
% Here used to be a definition of Quintus statistics/2 in traditional
% SWI-Prolog statistics/2. The current built-in emulates Quintus
% almost completely.
/*******************************
* DATE/TIME *
*******************************/
%% date(-Date) is det.
%
% Get current date as date(Y,M,D)
date(Date) :-
get_time(T),
stamp_date_time(T, DaTime, local),
date_time_value(date, DaTime, Date).
/********************************
* STYLE CHECK *
*********************************/
%% no_style_check(Style) is det.
%
% Same as SWI-Prolog =|style_check(-Style)|=. The Quintus option
% =single_var= is mapped to =singleton=.
%
% @see style_check/1.
q_style_option(single_var, singleton) :- !.
q_style_option(Option, Option).
% no_style_check(QOption) :-
% q_style_option(QOption, SWIOption),
% style_check(-SWIOption).
/********************************
* DIRECTIVES *
*********************************/
% :- op(1150, fx, [(mode), (public)]).
% mode(_).
% public(_).
/*******************************
* TYPES *
*******************************/
%% simple(@Term) is semidet.
%
% Term is atomic or a variable.
% simple(X) :-
% ( atomic(X)
% -> true
% ; var(X)
% ).
/*******************************
* STREAMS *
*******************************/
%% current_stream(?Object, ?Mode, ?Stream)
%
% SICStus/Quintus and backward compatible predicate. New code should
% be using the ISO compatible stream_property/2.
% current_stream(Object, Mode, Stream) :-
% stream_property(Stream, mode(FullMode)),
% stream_mode(FullMode, Mode),
% ( stream_property(Stream, file_name(Object0))
% -> true
% ; stream_property(Stream, file_no(Object0))
% -> true
% ; Object0 = []
% ),
% Object = Object0.
% stream_mode(read, read).
% stream_mode(write, write).
% stream_mode(append, write).
% stream_mode(update, write).
% %% stream_position(+Stream, -Old, +New)
% stream_position(Stream, Old, New) :-
% stream_property(Stream, position(Old)),
% set_stream_position(Stream, New).
%% skip_line is det.
%% skip_line(Stream) is det.
%
% Skip the rest of the current line (on Stream). Same as
% =|skip(0'\n)|=.
skip_line :-
skip(10).
skip_line(Stream) :-
skip(Stream, 10).
/*******************************
* COMPILATION *
*******************************/
%% compile(+Files) is det.
%
% Compile files. SWI-Prolog doesn't distinguish between
% compilation and consult.
%
% @see load_files/2.
% :- meta_predicate
% compile(:).
% compile(Files) :-
% consult(Files).
/*******************************
* ATOM-HANDLING *
*******************************/
%% atom_char(+Char, -Code) is det.
%% atom_char(-Char, +Code) is det.
%
% Same as ISO char_code/2.
atom_char(Char, Code) :-
char_code(Char, Code).
%% midstring(?ABC, ?B, ?AC) is nondet.
%% midstring(?ABC, ?B, ?AC, LenA) is nondet.
%% midstring(?ABC, ?B, ?AC, LenA, LenB) is nondet.
%% midstring(?ABC, ?B, ?AC, LenA, LenB, LenC) is nondet.
%
% Too difficult to explain. See the Quintus docs. As far as I
% understand them the code below emulates this function just fine.
midstring(ABC, B, AC) :-
midstring(ABC, B, AC, _, _, _).
midstring(ABC, B, AC, LenA) :-
midstring(ABC, B, AC, LenA, _, _).
midstring(ABC, B, AC, LenA, LenB) :-
midstring(ABC, B, AC, LenA, LenB, _).
midstring(ABC, B, AC, LenA, LenB, LenC) :- % -ABC, +B, +AC
var(ABC), !,
atom_length(AC, LenAC),
( nonvar(LenA) ; nonvar(LenC)
-> plus(LenA, LenC, LenAC)
; true
),
sub_atom(AC, 0, LenA, _, A),
LenC is LenAC - LenA,
sub_atom(AC, _, LenC, 0, C),
atom_length(B, LenB),
atomic_list_concat([A,B,C], ABC).
midstring(ABC, B, AC, LenA, LenB, LenC) :-
sub_atom(ABC, LenA, LenB, LenC, B),
sub_atom(ABC, 0, LenA, _, A),
sub_atom(ABC, _, LenC, 0, C),
atom_concat(A, C, AC).
/*******************************
* EXCEPTIONS *
*******************************/
%% raise_exception(+Term)
%
% Quintus compatible exception handling
% raise_exception(Term) :-
% throw(Term).
%% on_exception(+Template, :Goal, :Recover)
:- meta_predicate
on_exception(+, 0, 0).
% on_exception(Except, Goal, Recover) :-
% catch(Goal, Except, Recover).

242
swi/library/readutil.pl Normal file
View File

@@ -0,0 +1,242 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(read_util,
[ read_line_to_codes/2, % +Fd, -Codes (without trailing \n)
read_line_to_codes/3, % +Fd, -Codes, ?Tail
read_stream_to_codes/2, % +Fd, -Codes
read_stream_to_codes/3, % +Fd, -Codes, ?Tail
read_file_to_codes/3, % +File, -Codes, +Options
read_file_to_terms/3 % +File, -Terms, +Options
]).
:- use_module(library(shlib)).
:- use_module(library(lists), [select/3]).
:- use_module(library(error)).
/** <module> Read utilities
This library provides some commonly used reading predicates. As these
predicates have proven to be time-critical in some applications we moved
them to C. For compatibility as well as to reduce system dependency, we
link the foreign code at runtime and fallback to the Prolog
implementation if the shared object cannot be found.
*/
:- volatile
read_line_to_codes/2,
read_line_to_codes/3,
read_stream_to_codes/2,
read_stream_to_codes/3.
link_foreign :-
catch(load_foreign_library(foreign(readutil)), _, fail), !.
link_foreign :-
assertz((read_line_to_codes(Stream, Line) :-
pl_read_line_to_codes(Stream, Line))),
assertz((read_line_to_codes(Stream, Line, Tail) :-
pl_read_line_to_codes(Stream, Line, Tail))),
assertz((read_stream_to_codes(Stream, Content) :-
pl_read_stream_to_codes(Stream, Content))),
assertz((read_stream_to_codes(Stream, Content, Tail) :-
pl_read_stream_to_codes(Stream, Content, Tail))),
compile_predicates([ read_line_to_codes/2,
read_line_to_codes/3,
read_stream_to_codes/2,
read_stream_to_codes/3
]).
:- initialization(link_foreign, now).
/*******************************
* LINES *
*******************************/
%% read_line_to_codes(+In:stream, -Line:codes) is det.
%
% Read a line of input from In into a list of character codes.
% Trailing newline and or return are deleted. Upon reaching
% end-of-file Line is unified to the atom =end_of_file=.
pl_read_line_to_codes(Fd, Codes) :-
get_code(Fd, C0),
( C0 == -1
-> Codes = end_of_file
; read_1line_to_codes(C0, Fd, Codes0)
),
Codes = Codes0.
read_1line_to_codes(-1, _, []) :- !.
read_1line_to_codes(10, _, []) :- !.
read_1line_to_codes(13, Fd, L) :- !,
get_code(Fd, C2),
read_1line_to_codes(C2, Fd, L).
read_1line_to_codes(C, Fd, [C|T]) :-
get_code(Fd, C2),
read_1line_to_codes(C2, Fd, T).
%% read_line_to_codes(+Fd, -Line, ?Tail) is det.
%
% Read a line of input as a difference list. This should be used
% to read multiple lines efficiently. On reaching end-of-file,
% Tail is bound to the empty list.
pl_read_line_to_codes(Fd, Codes, Tail) :-
get_code(Fd, C0),
read_line_to_codes(C0, Fd, Codes0, Tail),
Codes = Codes0.
read_line_to_codes(-1, _, Tail, Tail) :- !,
Tail = [].
read_line_to_codes(10, _, [10|Tail], Tail) :- !.
read_line_to_codes(C, Fd, [C|T], Tail) :-
get_code(Fd, C2),
read_line_to_codes(C2, Fd, T, Tail).
/*******************************
* STREAM (ENTIRE INPUT) *
*******************************/
%% read_stream_to_codes(+Stream, -Codes) is det.
%% read_stream_to_codes(+Stream, -Codes, ?Tail) is det.
%
% Read input from Stream to a list of character codes. The version
% read_stream_to_codes/3 creates a difference-list.
pl_read_stream_to_codes(Fd, Codes) :-
pl_read_stream_to_codes(Fd, Codes, []).
pl_read_stream_to_codes(Fd, Codes, Tail) :-
get_code(Fd, C0),
read_stream_to_codes(C0, Fd, Codes0, Tail),
Codes = Codes0.
read_stream_to_codes(-1, _, Tail, Tail) :- !.
read_stream_to_codes(C, Fd, [C|T], Tail) :-
get_code(Fd, C2),
read_stream_to_codes(C2, Fd, T, Tail).
%% read_stream_to_terms(+Stream, -Terms, ?Tail, +Options) is det.
read_stream_to_terms(Fd, Terms, Tail, Options) :-
read_term(Fd, C0, Options),
read_stream_to_terms(C0, Fd, Terms0, Tail, Options),
Terms = Terms0.
read_stream_to_terms(end_of_file, _, Tail, Tail, _) :- !.
read_stream_to_terms(C, Fd, [C|T], Tail, Options) :-
read_term(Fd, C2, Options),
read_stream_to_terms(C2, Fd, T, Tail, Options).
/*******************************
* FILE (ENTIRE INPUT) *
*******************************/
%% read_file_to_codes(+Spec, -Codes, +Options) is det.
%
% Read the file Spec into a list of Codes. Options is split into
% options for absolute_file_name/3 and open/4.
read_file_to_codes(Spec, Codes, Options) :-
must_be(proper_list, Options),
( select(tail(Tail), Options, Options1)
-> true
; Tail = [],
Options1 = Options
),
split_options(Options1, file_option, FileOptions, OpenOptions),
absolute_file_name(Spec,
[ access(read)
| FileOptions
],
Path),
open(Path, read, Fd, OpenOptions),
call_cleanup(read_stream_to_codes(Fd, Codes0, Tail),
close(Fd)),
Codes = Codes0.
%% read_file_to_terms(+Spec, -Terms, +Options) is det.
%
% Read the file Spec into a list of terms. Options is split over
% absolute_file_name/3, open/4 and read_term/3.
read_file_to_terms(Spec, Terms, Options) :-
must_be(proper_list, Options),
( select(tail(Tail), Options, Options1)
-> true
; Tail = [],
Options1 = Options
),
split_options(Options1, file_option, FileOptions, Options2),
split_options(Options2, read_option, ReadOptions, OpenOptions),
absolute_file_name(Spec,
[ access(read)
| FileOptions
],
Path),
open(Path, read, Fd, OpenOptions),
call_cleanup(read_stream_to_terms(Fd, Terms0, Tail, ReadOptions),
close(Fd)),
Terms = Terms0.
split_options([], _, [], []).
split_options([H|T], G, File, Open) :-
( call(G, H)
-> File = [H|FT],
OT = Open
; Open = [H|OT],
FT = File
),
split_options(T, G, FT, OT).
read_option(module(_)).
read_option(syntax_errors(_)).
read_option(character_escapes(_)).
read_option(double_quotes(_)).
read_option(backquoted_string(_)).
file_option(extensions(_)).
file_option(file_type(_)).
file_option(file_errors(_)).
file_option(relative_to(_)).
file_option(expand(_)).
/*******************************
* XREF *
*******************************/
:- multifile prolog:meta_goal/2.
:- dynamic prolog:meta_goal/2.
prolog:meta_goal(split_options(_,G,_,_), [G+1]).

477
swi/library/record.pl Normal file
View File

@@ -0,0 +1,477 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2007, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module((record),
[ (record)/1, % +Record
current_record/2, % ?Name, ?Term
current_record_predicate/2, % ?Record, :PI
op(1150, fx, record)
]).
:- use_module(library(error)).
/** <module> Access compound arguments by name
This module creates a set of predicates to create a default instance,
access and modify records represented as a compound term.
The full documentation is with record/1, which must be used as a
_directive_. Here is a simple example declaration and some calls.
==
:- record point(x:integer=0, y:integer=0).
default_point(Point),
point_x(Point, X),
set_x_of_point(10, Point, Point1),
make_point([y(20)], YPoint),
==
@author Jan Wielemaker
@author Richard O'Keefe
*/
:- multifile
error:has_type/2,
prolog:generated_predicate/1.
error:has_type(record(M:Name), X) :-
current_record(Name, M, _, X, IsX), !,
call(M:IsX).
%% record(+RecordDef)
%
% Define access predicates for a compound-term. RecordDef is of
% the form <constructor>(<argument>, ...), where each argument
% is of the form:
%
% * <name>[:<type>][=<default>]
%
% Used a directive, =|:- record Constructor(Arg, ...)|= is expanded
% info the following predicates:
%
% * <constructor>_<name>(Record, Value)
% * <constructor>_data(?Name, ?Record, ?Value)
% * default_<constructor>(-Record)
% * is_<constructor>(@Term)
% * make_<constructor>(+Fields, -Record)
% * make_<constructor>(+Fields, -Record, -RestFields)
% * set_<name>_of_<constructor>(+Value, +OldRecord, -New)
% * set_<name>_of_<constructor>(+Value, !Record)
% * nb_set_<name>_of_<constructor>(+Value, !Record)
% * set_<constructor>_fields(+Fields, +Record0, -Record).
% * set_<constructor>_fields(+Fields, +Record0, -Record, -RestFields).
% * set_<constructor>_field(+Field, +Record0, -Record).
% * user:current_record(:<constructor>)
record(Record) :-
throw(error(context_error(nodirective, record(Record)), _)).
%% compile_records(+RecordsDefs, -Clauses) is det.
%
% Compile a record specification into a list of clauses.
compile_records(Spec, Clauses) :-
phrase(compile_records(Spec), Clauses).
% maplist(portray_clause, Clauses).
compile_records(Var) -->
{ var(Var), !,
instantiation_error(Var)
}.
compile_records((A,B)) -->
compile_record(A),
compile_records(B).
compile_records(A) -->
compile_record(A).
%% compile_record(+Record)// is det.
%
% Create clauses for Record.
compile_record(RecordDef) -->
{ RecordDef =.. [Constructor|Args],
defaults(Args, Defs, TypedArgs),
types(TypedArgs, Names, Types),
atom_concat(default_, Constructor, DefName),
atom_concat(Constructor, '_data', DataName),
DefRecord =.. [Constructor|Defs],
DefClause =.. [DefName,DefRecord],
length(Names, Arity)
},
[ DefClause ],
access_predicates(Names, 1, Arity, Constructor),
data_predicate(Names, 1, Arity, Constructor, DataName),
set_predicates(Names, 1, Arity, Types, Constructor),
set_field_predicates(Names, 1, Arity, Types, Constructor),
make_predicate(Constructor),
is_predicate(Constructor, Types),
current_clause(RecordDef).
:- meta_predicate
current_record(?, :),
current_record_predicate(?, :).
:- multifile
current_record/5. % Name, Module, Term, X, IsX
%% current_record(?Name, :Term)
%
% True if Name is the name of a record defined in the module
% associated with Term and Term is the user-provided record
% declaration.
current_record(Name, M:Term) :-
current_record(Name, M, Term, _, _).
current_clause(RecordDef) -->
{ prolog_load_context(module, M),
functor(RecordDef, Name, _),
atom_concat(is_, Name, IsName),
IsX =.. [IsName, X]
},
[ (record):current_record(Name, M, RecordDef, X, IsX)
].
%% current_record_predicate(?Record, ?PI) is nondet.
%
% True if PI is the predicate indicator for an access predicate to
% Record. This predicate is intended to support cross-referencer
% tools.
current_record_predicate(Record, M:PI) :-
( ground(PI)
-> Det = true
; true
),
current_record(Record, M:RecordDef),
( general_record_pred(Record, M:PI)
; RecordDef =.. [_|Args],
defaults(Args, _Defs, TypedArgs),
types(TypedArgs, Names, _Types),
member(Field, Names),
field_record_pred(Record, Field, M:PI)
),
( Det == true
-> !
; true
).
general_record_pred(Record, _:Name/1) :-
atom_concat(is_, Record, Name).
general_record_pred(Record, _:Name/1) :-
atom_concat(default_, Record, Name).
general_record_pred(Record, _:Name/A) :-
member(A, [2,3]),
atom_concat(make_, Record, Name).
general_record_pred(Record, _:Name/3) :-
atom_concat(Record, '_data', Name).
general_record_pred(Record, _:Name/A) :-
member(A, [3,4]),
atomic_list_concat([set_, Record, '_fields'], Name).
general_record_pred(Record, _:Name/3) :-
atomic_list_concat([set_, Record, '_field'], Name).
field_record_pred(Record, Field, _:Name/2) :-
atomic_list_concat([Record, '_', Field], Name).
field_record_pred(Record, Field, _:Name/A) :-
member(A, [2,3]),
atomic_list_concat([set_, Field, '_of_', Record], Name).
field_record_pred(Record, Field, _:Name/2) :-
atomic_list_concat([nb_set_, Field, '_of_', Record], Name).
prolog:generated_predicate(P) :-
current_record_predicate(_, P).
%% make_predicate(+Constructor)// is det.
%
% Creates the make_<constructor>(+Fields, -Record) predicate. This
% looks like this:
%
% ==
% make_<constructor>(Fields, Record) :-
% make_<constructor>(Fields, Record, [])
%
% make_<constructor>(Fields, Record, RestFields) :-
% default_<constructor>(Record0),
% set_<constructor>_fields(Fields, Record0, Record, RestFields).
%
% set_<constructor>_fields(Fields, Record0, Record) :-
% set_<constructor>_fields(Fields, Record0, Record, []).
%
% set_<constructor>_fields([], Record, Record, []).
% set_<constructor>_fields([H|T], Record0, Record, RestFields) :-
% ( set_<constructor>_field(H, Record0, Record1)
% -> set_<constructor>_fields(T, Record1, Record, RestFields)
% ; RestFields = [H|RF],
% set_<constructor>_fields(T, Record0, Record, RF)
% ).
%
% set_<constructor>_field(<name1>(Value), Record0, Record).
% ...
% ==
make_predicate(Constructor) -->
{ atomic_list_concat([make_, Constructor], MakePredName),
atomic_list_concat([default_, Constructor], DefPredName),
atomic_list_concat([set_, Constructor, '_fields'], SetFieldsName),
atomic_list_concat([set_, Constructor, '_field'], SetFieldName),
MakeHead3 =.. [MakePredName, Fields, Record],
MakeHead4 =.. [MakePredName, Fields, Record, []],
MakeClause3 = (MakeHead3 :- MakeHead4),
MakeHead =.. [MakePredName, Fields, Record, RestFields],
DefGoal =.. [DefPredName, Record0],
SetGoal =.. [SetFieldsName, Fields, Record0, Record, RestFields],
MakeClause = (MakeHead :- DefGoal, SetGoal),
SetHead3 =.. [SetFieldsName, Fields, R0, R],
SetHead4 =.. [SetFieldsName, Fields, R0, R, []],
SetClause0 = (SetHead3 :- SetHead4),
SetClause1 =.. [SetFieldsName, [], R, R, []],
SetHead2 =.. [SetFieldsName, [H|T], R0, R, RF],
SetGoal2a =.. [SetFieldName, H, R0, R1],
SetGoal2b =.. [SetFieldsName, T, R1, R, RF],
SetGoal2c =.. [SetFieldsName, T, R0, R, RF1],
SetClause2 = (SetHead2 :- (SetGoal2a -> SetGoal2b ; RF=[H|RF1], SetGoal2c))
},
[ MakeClause3, MakeClause, SetClause0, SetClause1, SetClause2 ].
%% is_predicate(+Constructor, +Types)// is det.
%
% Create a clause that tests for a given record type.
is_predicate(Constructor, Types) -->
{ type_checks(Types, Vars, Body0),
clean_body(Body0, Body),
Term =.. [Constructor|Vars],
atom_concat(is_, Constructor, Name),
Head1 =.. [Name,Var],
Head2 =.. [Name,Term]
},
[ (Head1 :- var(Var), !, fail) ],
( { Body == true }
-> [ Head2 ]
; [ (Head2 :- Body) ]
).
type_checks([], [], true).
type_checks([any|T], [_|Vars], Body) :-
type_checks(T, Vars, Body).
type_checks([Type|T], [V|Vars], (Goal, Body)) :-
type_goal(Type, V, Goal),
type_checks(T, Vars, Body).
%% type_goal(+Type, +Var, -BodyTerm) is det.
%
% Inline type checking calls.
type_goal(Type, Var, Body) :-
defined_type(Type, Var, Body), !.
type_goal(record(Record), Var, Body) :- !,
atom_concat(is_, Record, Pred),
Body =.. [Pred,Var].
type_goal(Record, Var, Body) :-
atom(Record), !,
atom_concat(is_, Record, Pred),
Body =.. [Pred,Var].
type_goal(Type, _, _) :-
domain_error(type, Type).
defined_type(Type, Var, error:Body) :-
clause(error:has_type(Type, Var), Body).
clean_body(M:(A0,B0), G) :- !,
clean_body(M:A0, A),
clean_body(M:B0, B),
clean_body((A,B), G).
clean_body((A0,true), A) :- !,
clean_body(A0, A).
clean_body((true,A0), A) :- !,
clean_body(A0, A).
clean_body((A0,B0), (A,B)) :-
clean_body(A0, A),
clean_body(B0, B).
clean_body(_:A, A) :-
predicate_property(A, built_in), !.
clean_body(A, A).
%% access_predicates(+Names, +Idx0, +Arity, +Constructor)// is det.
%
% Create the <constructor>_<name>(Record, Value) predicates.
access_predicates([], _, _, _) -->
[].
access_predicates([Name|NT], I, Arity, Constructor) -->
{ atomic_list_concat([Constructor, '_', Name], PredName),
functor(Record, Constructor, Arity),
arg(I, Record, Value),
Clause =.. [PredName, Record, Value],
I2 is I + 1
},
[Clause],
access_predicates(NT, I2, Arity, Constructor).
%% data_predicate(+Names, +Idx0, +Arity, +Constructor, +DataName)// is det.
%
% Create the <constructor>_data(Name, Record, Value) predicate.
data_predicate([], _, _, _, _) -->
[].
data_predicate([Name|NT], I, Arity, Constructor, DataName) -->
{ functor(Record, Constructor, Arity),
arg(I, Record, Value),
Clause =.. [DataName, Name, Record, Value],
I2 is I + 1
},
[Clause],
data_predicate(NT, I2, Arity, Constructor, DataName).
%% set_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det.
%
% Create the clauses
%
% * set_<name>_of_<constructor>(Value, Old, New)
% * set_<name>_of_<constructor>(Value, Record)
set_predicates([], _, _, _, _) -->
[].
set_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
{ atomic_list_concat(['set_', Name, '_of_', Constructor], PredName),
atomic_list_concat(['nb_set_', Name, '_of_', Constructor], NBPredName),
length(Args, Arity),
replace_nth(I, Args, Value, NewArgs),
Old =.. [Constructor|Args],
New =.. [Constructor|NewArgs],
Head =.. [PredName, Value, Old, New],
SetHead =.. [PredName, Value, Term],
NBSetHead =.. [NBPredName, Value, Term],
( Type == any
-> Clause = Head,
SetClause = (SetHead :- setarg(I, Term, Value)),
NBSetClause = (NBSetHead :- nb_setarg(I, Term, Value))
; type_check(Type, Value, MustBe),
Clause = (Head :- MustBe),
SetClause = (SetHead :- MustBe,
setarg(I, Term, Value)),
NBSetClause = (NBSetHead :- MustBe,
nb_setarg(I, Term, Value))
),
I2 is I + 1
},
[ Clause, SetClause, NBSetClause ],
set_predicates(NT, I2, Arity, TT, Constructor).
type_check(Type, Value, must_be(Type, Value)) :-
defined_type(Type, Value, _), !.
type_check(record(Spec), Value, must_be(record(M:Name), Value)) :- !,
prolog_load_context(module, C),
strip_module(C:Spec, M, Name).
type_check(Atom, Value, Check) :-
atom(Atom), !,
type_check(record(Atom), Value, Check).
%% set_field_predicates(+Names, +Idx0, +Arity, +Types, +Constructor)// is det.
%
% Create the clauses
%
% * set_<constructor>_field(<name>(Value), Old, New)
set_field_predicates([], _, _, _, _) -->
[].
set_field_predicates([Name|NT], I, Arity, [Type|TT], Constructor) -->
{ atomic_list_concat(['set_', Constructor, '_field'], FieldPredName),
length(Args, Arity),
replace_nth(I, Args, Value, NewArgs),
Old =.. [Constructor|Args],
New =.. [Constructor|NewArgs],
NameTerm =.. [Name, Value],
SetFieldHead =.. [FieldPredName, NameTerm, Old, New],
( Type == any
-> SetField = SetFieldHead
; type_check(Type, Value, MustBe),
SetField = (SetFieldHead :- MustBe)
),
I2 is I + 1
},
[ SetField ],
set_field_predicates(NT, I2, Arity, TT, Constructor).
%% replace_nth(+Index, +List, +Element, -NewList) is det.
%
% Replace the Nth (1-based) element of a list.
replace_nth(1, [_|T], V, [V|T]) :- !.
replace_nth(I, [H|T0], V, [H|T]) :-
I2 is I - 1,
replace_nth(I2, T0, V, T).
%% defaults(+ArgsSpecs, -Defaults, -Args)
%
% Strip the default specification from the argument specification.
defaults([], [], []).
defaults([Arg=Default|T0], [Default|TD], [Arg|TA]) :- !,
defaults(T0, TD, TA).
defaults([Arg|T0], [_|TD], [Arg|TA]) :-
defaults(T0, TD, TA).
%% types(+ArgsSpecs, -Defaults, -Args)
%
% Strip the default specification from the argument specification.
types([], [], []).
types([Name:Type|T0], [Name|TN], [Type|TT]) :- !,
must_be(atom, Name),
types(T0, TN, TT).
types([Name|T0], [Name|TN], [any|TT]) :-
must_be(atom, Name),
types(T0, TN, TT).
/*******************************
* EXPANSION *
*******************************/
:- multifile
system:term_expansion/2.
:- dynamic
system:term_expansion/2.
system:term_expansion((:- record(Record)), Clauses) :-
compile_records(Record, Clauses).

632
swi/library/settings.pl Normal file
View File

@@ -0,0 +1,632 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2007, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(settings,
[ setting/4, % :Name, +Type, +Default, +Comment
setting/2, % :Name, ?Value
set_setting/2, % :Name, +Value
set_setting_default/2, % :Name, +Value
restore_setting/1, % :Name
load_settings/1, % +File
load_settings/2, % +File, +Options
save_settings/0,
save_settings/1, % +File
current_setting/1, % Module:Name
setting_property/2, % ?Setting, ?Property
list_settings/0,
convert_setting_text/3 % +Type, +Text, -Value
]).
:- use_module(library(error)).
:- use_module(library(broadcast)).
:- use_module(library(debug)).
:- use_module(library(option)).
/** <module> Setting management
This library allows management of configuration settings for Prolog
applications. Applications define settings in one or multiple files
using the directive setting/4 as illustrated below:
==
:- use_module(library(setting)).
:- setting(version, atom, '1.0', 'Current version').
:- setting(timeout, number, 20, 'Timeout in seconds').
==
The directive is subject to term_expansion/2, which guarantees proper
synchronisation of the database if source-files are reloaded. This
implies it is *not* possible to call setting/4 as a predicate.
Settings are local to a module. This implies they are defined in a
two-level namespace. Managing settings per module greatly simplifies
assembling large applications from multiple modules that configuration
through settings. This settings management library ensures proper
access, loading and saving of settings.
@see library(config) distributed with XPCE provides an alternative
aimed at graphical applications.
@author Jan Wielemaker
*/
:- dynamic
st_value/3, % Name, Module, Value
st_default/3, % Name, Module, Value
local_file/1. % Path
:- multifile
current_setting/6. % Name, Module, Type, Default, Comment, Source
:- meta_predicate
setting(:, +, +, +),
setting(:, ?),
set_setting(:, +),
set_setting_default(:, +),
current_setting(:),
restore_setting(:).
curr_setting(Name, Module, Type, Default, Comment) :-
current_setting(Name, Module, Type, Default0, Comment, _Src),
( st_default(Name, Module, Default1)
-> Default = Default1
; Default = Default0
).
%% setting(Name, Type, Default, Comment) is det.
%
% Define a setting. Name denotes the name of the setting, Type its
% type. Default is the value before it is modified. Default refer
% to environment variables and use arithmetic expressions as
% defined by eval_default/4.
%
% @param Name Name of the setting (an atom)
% @param Type Type for setting. One of =any= or a type defined
% by must_be/2.
% @param Default Default value for the setting.
% @param Comment Atom containing a (short) descriptive note.
setting(Name, Type, Default, Comment) :-
throw(error(context_error(nodirective,
setting(Name, Type, Default, Comment)),
_)).
:- multifile
system:term_expansion/2.
system:term_expansion((:- setting(QName, Type, Default, Comment)),
Expanded) :-
prolog_load_context(module, M0),
strip_module(M0:QName, Module, Name),
must_be(atom, Name),
to_atom(Comment, CommentAtom),
eval_default(Default, Module, Type, Value),
check_type(Type, Value),
( current_setting(Name, Module, _, _, _, OldLoc)
-> format(string(Message),
'Already defined at: ~w', [OldLoc]),
throw(error(permission_error(redefine, setting, Module:Name),
context(Message, _)))
; source_location(File, Line)
-> Expanded = settings:current_setting(Name, Module, Type, Default,
CommentAtom, File:Line)
).
to_atom(Atom, Atom) :-
atom(Atom), !.
to_atom(String, Atom) :-
format(atom(Atom), '~s', String).
%% setting(:Name, ?Value) is nondet.
%
% True if Name is a currently defined setting with Value.
%
% @error existence_error(setting, Name)
setting(QName, Value) :-
strip_module(QName, Module, Name),
( ground(Name)
-> ( st_value(Name, Module, Value0)
-> Value = Value0
; curr_setting(Name, Module, Type, Default, _)
-> eval_default(Default, Module, Type, Value)
; existence_error(setting, Module:Name)
)
; current_setting(Name, Module, _, _, _, _),
setting(Module:Name, Value)
).
:- dynamic
setting_cache/3.
:- volatile
setting_cache/3.
%% clear_setting_cache is det.
%
% Clear the cache for evaluation of default values.
clear_setting_cache :-
retractall(setting_cache(_,_,_)).
%% eval_default(+Default, +Module, +Type, -Value) is det.
%
% Convert the settings default value. The notation allows for some
% `function-style' notations to make the library more generic:
%
% * env(Name)
% Get value from the given environment variable. The value
% is handed to convert_setting_text/3 to convert the
% textual representation into a Prolog term. Raises an
% existence_error of the variable is not defined.
%
% * env(Name, Default)
% As env(Name), but uses the value Default if the variable
% is not defined.
%
% * setting(Name)
% Ask the value of another setting.
%
% * Expression
% If Type is numeric, evaluate the expression. env(Var)
% evaluates to the value of an environment variable.
% If Type is =atom=, concatenate A+B+.... Elements of the
% expression can be env(Name).
:- multifile
eval_default/3. % +Default, +Type, -Value
eval_default(Default, _, Type, Value) :-
eval_default(Default, Type, Val), !,
Value = Val.
eval_default(Default, _, _, Value) :-
atomic(Default), !,
Value = Default.
eval_default(Default, _, Type, Value) :-
setting_cache(Default, Type, Val), !,
Value = Val.
eval_default(env(Name), _, Type, Value) :- !,
( getenv(Name, TextValue)
-> convert_setting_text(Type, TextValue, Val),
assert(setting_cache(env(Name), Type, Val)),
Value = Val
; existence_error(environment_variable, Name)
).
eval_default(env(Name, Default), _, Type, Value) :- !,
( getenv(Name, TextValue)
-> convert_setting_text(Type, TextValue, Val)
; Value = Default
),
assert(setting_cache(env(Name), Type, Val)),
Value = Val.
eval_default(setting(Name), Module, Type, Value) :- !,
strip_module(Module:Name, M, N),
setting(M:N, Value),
must_be(Type, Value).
eval_default(Expr, _, Type, Value) :-
numeric_type(Type, Basic), !,
Val0 is Expr,
( Basic == float
-> Val is float(Val0)
; Basic = integer
-> Val is round(Val0)
; Val = Val0
),
assert(setting_cache(Expr, Type, Val)),
Value = Val.
eval_default(A+B, Module, atom, Value) :- !,
phrase(expr_to_list(A+B, Module), L),
atomic_list_concat(L, Val),
assert(setting_cache(A+B, atom, Val)),
Value = Val.
eval_default(List, Module, list(Type), Value) :- !,
eval_list_default(List, Module, Type, Val),
assert(setting_cache(List, list(Type), Val)),
Value = Val.
eval_default(Default, _, _, Default).
%% eval_list_default(+List, +Module, +ElementType, -DefaultList)
%
% Evaluate the default for a list of values.
eval_list_default([], _, _, []).
eval_list_default([H0|T0], Module, Type, [H|T]) :-
eval_default(H0, Module, Type, H),
eval_list_default(T0, Module, Type, T).
%% expr_to_list(+Expression, +Module)// is det.
%
% Process the components to create an atom. Atom concatenation is
% expressed as A+B. Components may refer to envrionment variables.
expr_to_list(A+B, Module) --> !,
expr_to_list(A, Module),
expr_to_list(B, Module).
expr_to_list(env(Name), _) --> !,
( { getenv(Name, Text) }
-> [Text]
; { existence_error(environment_variable, Name) }
).
expr_to_list(env(Name, Default), _) --> !,
( { getenv(Name, Text) }
-> [Text]
; [Default]
).
expr_to_list(setting(Name), Module) --> !,
{ strip_module(Module:Name, M, N),
setting(M:N, Value)
},
[ Value ].
expr_to_list(A, _) -->
[A].
:- if((\+ current_prolog_flag(version_data,yap(_,_,_,_)))).
%% env(+Name:atom, -Value:number) is det.
%% env(+Name:atom, +Default:number, -Value:number) is det
%
% Evaluate environment variables on behalf of arithmetic
% expressions.
:- arithmetic_function(env/1).
:- arithmetic_function(env/2).
env(Name, Value) :-
( getenv(Name, Text)
-> convert_setting_text(number, Text, Value)
; existence_error(environment_variable, Name)
).
env(Name, Default, Value) :-
( getenv(Name, Text)
-> convert_setting_text(number, Text, Value)
; Value = Default
).
:- endif.
%% numeric_type(+Type, -BaseType)
%
% True if Type is a numeric type and BaseType is the associated
% basic Prolog type. BaseType is one of =integer=, =float= or
% =number=.
numeric_type(integer, integer).
numeric_type(nonneg, integer).
numeric_type(float, float).
numeric_type(between(L,_), Type) :-
( integer(L) -> Type = integer ; Type = float ).
%% set_setting(:Name, +Value) is det.
%
% Change a setting. Performs existence and type-checking for the
% setting. If the effective value of the setting is changed it
% broadcasts the event below.
%
% settings(changed(Module:Name, Old, New))
%
% @error existence_error(setting, Name)
% @error type_error(Type, Value)
set_setting(QName, Value) :-
strip_module(QName, Module, Name),
must_be(atom, Name),
( curr_setting(Name, Module, Type, Default0, _Comment),
eval_default(Default0, Module, Type, Default)
-> ( Value == Default
-> retract_setting(Module:Name)
; st_value(Name, Module, Value)
-> true
; check_type(Type, Value)
-> setting(Module:Name, Old),
retract_setting(Module:Name),
assert_setting(Module:Name, Value),
broadcast(settings(changed(Module:Name, Old, Value))),
clear_setting_cache % might influence dependent settings.
)
; existence_error(setting, Name)
).
retract_setting(Module:Name) :-
retractall(st_value(Name, Module, _)).
assert_setting(Module:Name, Value) :-
assert(st_value(Name, Module, Value)).
%% restore_setting(:Name) is det.
%
% Restore the value of setting Name to its default. Broadcast a
% change like set_setting/2 if the current value is not the
% default.
restore_setting(QName) :-
strip_module(QName, Module, Name),
must_be(atom, Name),
( st_value(Name, Module, Old)
-> retract_setting(Module:Name),
setting(Module:Name, Value),
( Old \== Value
-> broadcast(settings(changed(Module:Name, Old, Value)))
; true
)
; true
).
%% set_setting_default(:Name, +Default) is det.
%
% Change the default for a setting. The effect is the same as
% set_setting/2, but the new value is considered the default when
% saving and restoring a setting. It is intended to change
% application defaults in a particular context.
set_setting_default(QName, Default) :-
strip_module(QName, Module, Name),
must_be(atom, Name),
( current_setting(Name, Module, Type, Default0, _Comment, _Src)
-> retractall(settings:st_default(Name, Module, _)),
retract_setting(Module:Name),
( Default == Default0
-> true
; assert(settings:st_default(Name, Module, Default))
),
eval_default(Default, Module, Type, Value),
set_setting(Module:Name, Value)
; existence_error(setting, Module:Name)
).
/*******************************
* TYPES *
*******************************/
%% check_type(+Type, +Term)
%
% Type checking for settings. Currently simply forwarded to
% must_be/2.
check_type(Type, Term) :-
must_be(Type, Term).
/*******************************
* FILE *
*******************************/
%% load_settings(File) is det.
%% load_settings(File, +Options) is det.
%
% Load local settings from File. Succeeds if File does not exist,
% setting the default save-file to File. Options are:
%
% * undefined(+Action)
% Define how to handle settings that are not defined. When
% =error=, an error is printed and the setting is ignored.
% when =load=, the setting is loaded anyway, waiting for a
% definition.
load_settings(File) :-
load_settings(File, []).
load_settings(File, Options) :-
absolute_file_name(File, Path,
[ access(read),
file_errors(fail)
]), !,
assert(local_file(Path)),
open(Path, read, In, [encoding(utf8)]),
read_setting(In, T0),
call_cleanup(load_settings(T0, In, Options), close(In)),
clear_setting_cache.
load_settings(File, _) :-
absolute_file_name(File, Path,
[ access(write),
file_errors(fail)
]), !,
assert(local_file(Path)).
load_settings(_, _).
load_settings(end_of_file, _, _) :- !.
load_settings(Setting, In, Options) :-
catch(store_setting(Setting, Options), E,
print_message(warning, E)),
read_setting(In, Next),
load_settings(Next, In, Options).
read_setting(In, Term) :-
read_term(In, Term,
[ errors(dec10)
]).
%% store_setting(Term, +Options)
%
% Store setting loaded from file in the Prolog database.
store_setting(setting(Module:Name, Value), _) :-
curr_setting(Name, Module, Type, Default0, _Commentm), !,
eval_default(Default0, Module, Type, Default),
( Value == Default
-> true
; check_type(Type, Value)
-> retractall(st_value(Name, Module, _)),
assert(st_value(Name, Module, Value)),
broadcast(settings(changed(Module:Name, Default, Value)))
).
store_setting(setting(Module:Name, Value), Options) :- !,
( option(undefined(load), Options, load)
-> retractall(st_value(Name, Module, _)),
assert(st_value(Name, Module, Value))
; existence_error(setting, Module:Name)
).
store_setting(Term, _) :-
type_error(setting, Term).
%% save_settings is det.
%% save_settings(+File) is det.
%
% Save modified settings to File.
save_settings :-
local_file(File), !,
save_settings(File).
save_settings(File) :-
absolute_file_name(File, Path,
[ access(write)
]), !,
open(Path, write, Out,
[ encoding(utf8),
bom(true)
]),
write_setting_header(Out),
forall(current_setting(Name, Module, _, _, _, _),
save_setting(Out, Module:Name)),
close(Out).
write_setting_header(Out) :-
get_time(Now),
format_time(string(Date), '%+', Now),
format(Out, '/* Saved settings~n', []),
format(Out, ' Date: ~w~n', [Date]),
format(Out, '*/~n~n', []).
save_setting(Out, Module:Name) :-
curr_setting(Name, Module, Type, Default, Comment),
( st_value(Name, Module, Value),
\+ ( eval_default(Default, Module, Type, DefValue),
debug(setting, '~w <-> ~w~n', [DefValue, Value]),
DefValue =@= Value
)
-> format(Out, '~n% ~w~n', [Comment]),
format(Out, 'setting(~q:~q, ~q).~n', [Module, Name, Value])
; true
).
%% current_setting(?Setting) is nondet.
%
% True if Setting is a currently defined setting
current_setting(Setting) :-
ground(Setting), !,
strip_module(Setting, Module, Name),
current_setting(Name, Module, _, _, _, _).
current_setting(Module:Name) :-
current_setting(Name, Module, _, _, _, _).
%% setting_property(+Setting, +Property) is det.
%% setting_property(?Setting, ?Property) is nondet.
%
% Query currently defined settings. Property is one of
%
% * comment(-Atom)
% * type(-Type)
% Type of the setting.
% * default(-Default)
% Default value. If this is an expression, it is
% evaluated.
setting_property(Setting, Property) :-
ground(Setting), !,
Setting = Module:Name,
curr_setting(Name, Module, Type, Default, Comment), !,
setting_property(Property, Module, Type, Default, Comment).
setting_property(Setting, Property) :-
Setting = Module:Name,
curr_setting(Name, Module, Type, Default, Comment),
setting_property(Property, Module, Type, Default, Comment).
setting_property(type(Type), _, Type, _, _).
setting_property(default(Default), M, Type, Default0, _) :-
eval_default(Default0, M, Type, Default).
setting_property(comment(Comment), _, _, _, Comment).
%% list_settings
%
% List settings to =current_output=.
list_settings :-
format('~`=t~72|~n'),
format('~w~t~20| ~w~w~t~40| ~w~n', ['Name', 'Value (*=modified)', '', 'Comment']),
format('~`=t~72|~n'),
forall(current_setting(Module:Setting),
list_setting(Module:Setting)).
list_setting(Module:Name) :-
curr_setting(Name, Module, Type, Default0, Comment),
eval_default(Default0, Module, Type, Default),
setting(Module:Name, Value),
( Value \== Default
-> Modified = (*)
; Modified = ''
),
format('~w~t~20| ~q~w~t~40| ~w~n', [Module:Name, Value, Modified, Comment]).
/*******************************
* TYPES *
*******************************/
%% convert_setting_text(+Type, +Text, -Value)
%
% Converts from textual form to Prolog Value. Used to convert
% values obtained from the environment. Public to provide support
% in user-interfaces to this library.
%
% @error type_error(Type, Value)
:- multifile
convert_text/3. % +Type, +Text, -Value
convert_setting_text(Type, Text, Value) :-
convert_text(Type, Text, Value), !.
convert_setting_text(atom, Value, Value) :- !,
must_be(atom, Value).
convert_setting_text(boolean, Value, Value) :- !,
must_be(boolean, Value).
convert_setting_text(integer, Atom, Number) :- !,
term_to_atom(Term, Atom),
Number is round(Term).
convert_setting_text(float, Atom, Number) :- !,
term_to_atom(Term, Atom),
Number is float(Term).
convert_setting_text(between(L,U), Atom, Number) :- !,
( integer(L)
-> convert_setting_text(integer, Atom, Number)
; convert_setting_text(float, Atom, Number)
),
must_be(between(L,U), Number).
convert_setting_text(Type, Atom, Term) :-
term_to_atom(Term, Atom),
must_be(Type, Term).

409
swi/library/shlib.pl Normal file
View File

@@ -0,0 +1,409 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2009, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(shlib,
[ load_foreign_library/1, % :LibFile
load_foreign_library/2, % :LibFile, +InstallFunc
unload_foreign_library/1, % +LibFile
unload_foreign_library/2, % +LibFile, +UninstallFunc
current_foreign_library/2, % ?LibFile, ?Public
reload_foreign_libraries/0,
% Directives
use_foreign_library/1, % :LibFile
use_foreign_library/2 % :LibFile, +InstallFunc
]).
:- use_module(library(lists), [reverse/2]).
:- set_prolog_flag(generate_debug_info, false).
/** <module> Utility library for loading foreign objects (DLLs, shared objects)
This section discusses the functionality of the (autoload)
library(shlib), providing an interface to manage shared libraries. We
describe the procedure for using a foreign resource (DLL in Windows and
shared object in Unix) called =mylib=.
First, one must assemble the resource and make it compatible to
SWI-Prolog. The details for this vary between platforms. The plld(1)
utility can be used to deal with this in a portable manner. The typical
commandline is:
==
plld -o mylib file.{c,o,cc,C} ...
==
Make sure that one of the files provides a global function
=|install_mylib()|= that initialises the module using calls to
PL_register_foreign(). Here is a simple example file mylib.c, which
creates a Windows MessageBox:
==
#include <windows.h>
#include <SWI-Prolog.h>
static foreign_t
pl_say_hello(term_t to)
{ char *a;
if ( PL_get_atom_chars(to, &a) )
{ MessageBox(NULL, a, "DLL test", MB_OK|MB_TASKMODAL);
PL_succeed;
}
PL_fail;
}
install_t
install_mylib()
{ PL_register_foreign("say_hello", 1, pl_say_hello, 0);
}
==
Now write a file mylib.pl:
==
:- module(mylib, [ say_hello/1 ]).
:- use_foreign_library(foreign(mylib)).
==
The file mylib.pl can be loaded as a normal Prolog file and provides the
predicate defined in C.
*/
:- meta_predicate
load_foreign_library(:),
load_foreign_library(:, +),
use_foreign_library(:),
use_foreign_library(:, +).
:- dynamic
loading/1, % Lib
error/2, % File, Error
foreign_predicate/2, % Lib, Pred
current_library/5. % Lib, Entry, Path, Module, Handle
:- volatile % Do not store in state
loading/1,
error/2,
foreign_predicate/2,
current_library/5.
:- ( current_prolog_flag(open_shared_object, true)
-> true
; print_message(warning, shlib(not_supported)) % error?
).
/*******************************
* DISPATCHING *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Windows: If libpl.dll is compiled for debugging, prefer loading <lib>D.dll
to allow for debugging.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
find_library(Spec, Lib) :-
current_prolog_flag(windows, true),
false,
current_prolog_flag(kernel_compile_mode, debug),
libd_spec(Spec, SpecD),
catch(find_library2(SpecD, Lib), _, fail).
find_library(Spec, Lib) :-
find_library2(Spec, Lib).
find_library2(Spec, Lib) :-
absolute_file_name(Spec,
[ file_type(executable),
access(read),
file_errors(fail)
], Lib), !.
find_library2(Spec, Spec) :-
atom(Spec), !. % use machines finding schema
find_library2(foreign(Spec), Spec) :-
atom(Spec), !. % use machines finding schema
find_library2(Spec, _) :-
throw(error(existence_error(source_sink, Spec), _)).
libd_spec(Name, NameD) :-
atomic(Name),
file_name_extension(Base, Ext, Name),
atom_concat(Base, 'D', BaseD),
file_name_extension(BaseD, Ext, NameD).
libd_spec(Spec, SpecD) :-
compound(Spec),
Spec =.. [Alias,Name],
libd_spec(Name, NameD),
SpecD =.. [Alias,NameD].
libd_spec(Spec, Spec). % delay errors
base(Path, Base) :-
atomic(Path), !,
file_base_name(Path, File),
file_name_extension(Base, _Ext, File).
base(Path, Base) :-
Path =.. [_,Arg],
base(Arg, Base).
entry(_, Function, Function) :-
Function \= default(_), !.
entry(Spec, default(FuncBase), Function) :-
base(Spec, Base),
atomic_list_concat([FuncBase, Base], '_', Function).
entry(_, default(Function), Function).
/*******************************
* (UN)LOADING *
*******************************/
%% load_foreign_library(:FileSpec) is det.
%% load_foreign_library(:FileSpec, +Entry:atom) is det.
%
% Load a _|shared object|_ or _DLL_. After loading the Entry
% function is called without arguments. The default entry function
% is composed from =install_=, followed by the file base-name.
% E.g., the load-call below calls the function
% =|install_mylib()|=. If the platform prefixes extern functions
% with =_=, this prefix is added before calling.
%
% ==
% ...
% load_foreign_library(foreign(mylib)),
% ...
% ==
%
% @param FileSpec is a specification for absolute_file_name/3. If searching
% the file fails, the plain name is passed to the OS to try the default
% method of the OS for locating foreign objects. The default definition
% of file_search_path/2 searches <prolog home>/lib/<arch> on Unix and
% <prolog home>/bin on Windows.
%
% @see use_foreign_library/1,2 are intended for use in directives.
load_foreign_library(Library) :-
load_foreign_library(Library, default(install)).
load_foreign_library(Module:LibFile, Entry) :-
with_mutex('$foreign',
load_foreign_library(LibFile, Module, Entry)).
load_foreign_library(LibFile, _Module, _) :-
current_library(LibFile, _, _, _, _), !.
load_foreign_library(LibFile, Module, DefEntry) :-
retractall(error(_, _)),
find_library(LibFile, Path),
asserta(loading(LibFile)),
catch(Module:open_shared_object(Path, Handle), E, true),
( nonvar(E)
-> assert(error(Path, E)),
fail
; true
), !,
( ( entry(LibFile, DefEntry, Entry),
Module:call_shared_object_function(Handle, Entry)
-> true
; DefEntry == default(install)
)
-> retractall(loading(LibFile)),
assert_shlib(LibFile, Entry, Path, Module, Handle)
; retractall(loading(LibFile)),
close_shared_object(Handle),
print_message(error, shlib(LibFile, call_entry(DefEntry))),
fail
).
load_foreign_library(LibFile, _, _) :-
retractall(loading(LibFile)),
( error(_Path, E)
-> retractall(error(_, _)),
throw(E)
; throw(error(existence_error(foreign_library, LibFile), _))
).
%% use_foreign_library(+FileSpec) is det.
%% use_foreign_library(+FileSpec, +Entry:atom) is det.
%
% Load and install a foreign library as load_foreign_library/1,2
% and register the installation using initialization/2 with the
% option =now=. This is similar to using:
%
% ==
% :- initialization(load_foreign_library(foreign(mylib))).
% ==
%
% but using the initialization/1 wrapper causes the library to be
% loaded _after_ loading of the file in which it appears is
% completed, while use_foreign_library/1 loads the library
% _immediately_. I.e. the difference is only relevant if the
% remainder of the file uses functionality of the C-library.
use_foreign_library(FileSpec) :-
initialization(load_foreign_library(FileSpec), now).
use_foreign_library(FileSpec, Entry) :-
initialization(load_foreign_library(FileSpec, Entry), now).
%% unload_foreign_library(+FileSpec) is det.
%% unload_foreign_library(+FileSpec, +Exit:atom) is det.
%
% Unload a _|shared object|_ or _DLL_. After calling the Exit
% function, the shared object is removed from the process. The
% default exit function is composed from =uninstall_=, followed by
% the file base-name.
unload_foreign_library(LibFile) :-
unload_foreign_library(LibFile, default(uninstall)).
unload_foreign_library(LibFile, DefUninstall) :-
with_mutex('$foreign', do_unload(LibFile, DefUninstall)).
do_unload(LibFile, DefUninstall) :-
current_library(LibFile, _, _, Module, Handle),
retractall(current_library(LibFile, _, _, _, _)),
( entry(LibFile, DefUninstall, Uninstall),
Module:call_shared_object_function(Handle, Uninstall)
-> true
; true
),
abolish_foreign(LibFile),
close_shared_object(Handle).
abolish_foreign(LibFile) :-
( retract(foreign_predicate(LibFile, Module:Head)),
functor(Head, Name, Arity),
abolish(Module:Name, Arity),
fail
; true
).
system:'$foreign_registered'(M, H) :-
( loading(Lib)
-> true
; Lib = '<spontaneous>'
),
assert(foreign_predicate(Lib, M:H)).
assert_shlib(File, Entry, Path, Module, Handle) :-
retractall(current_library(File, _, _, _, _)),
asserta(current_library(File, Entry, Path, Module, Handle)).
/*******************************
* ADMINISTRATION *
*******************************/
%% current_foreign_library(?File, ?Public)
%
% Query currently loaded shared libraries.
current_foreign_library(File, Public) :-
current_library(File, _Entry, _Path, _Module, _Handle),
findall(Pred, foreign_predicate(File, Pred), Public).
/*******************************
* RELOAD *
*******************************/
%% reload_foreign_libraries
%
% Reload all foreign libraries loaded (after restore of a state
% created using qsave_program/2.
reload_foreign_libraries :-
findall(lib(File, Entry, Module),
( retract(current_library(File, Entry, _, Module, _)),
File \== -
),
Libs),
reverse(Libs, Reversed),
reload_libraries(Reversed).
reload_libraries([]).
reload_libraries([lib(File, Entry, Module)|T]) :-
( load_foreign_library(File, Module, Entry)
-> true
; print_message(error, shlib(File, load_failed))
),
reload_libraries(T).
/*******************************
* CLEANUP (WINDOWS ...) *
*******************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Called from Halt() in pl-os.c (if it is defined), *after* all at_halt/1
hooks have been executed, and after dieIO(), closing and flushing all
files has been called.
On Unix, this is not very useful, and can only lead to conflicts.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
unload_all_foreign_libraries :-
current_prolog_flag(unix, true), !.
unload_all_foreign_libraries :-
forall(current_library(File, _, _, _, _),
unload_foreign(File)).
%% unload_foreign(+File)
%
% Unload the given foreign file and all `spontaneous' foreign
% predicates created afterwards. Handling these spontaneous
% predicates is a bit hard, as we do not know who created them and
% on which library they depend.
unload_foreign(File) :-
unload_foreign_library(File),
( clause(foreign_predicate(Lib, M:H), true, Ref),
( Lib == '<spontaneous>'
-> functor(H, Name, Arity),
abolish(M:Name, Arity),
erase(Ref),
fail
; !
)
-> true
; true
).
/*******************************
* MESSAGES *
*******************************/
:- multifile
prolog:message/3.
prolog:message(shlib(LibFile, call_entry(DefEntry))) -->
[ '~w: Failed to call entry-point ~w'-[LibFile, DefEntry] ].
prolog:message(shlib(LibFile, load_failed)) -->
[ '~w: Failed to load file'-[LibFile] ].
prolog:message(shlib(not_supported)) -->
[ 'Emulator does not support foreign libraries' ].

418
swi/library/thread_pool.pl Normal file
View File

@@ -0,0 +1,418 @@
/* Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 2008, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(thread_pool,
[ thread_pool_create/3, % +Pool, +Size, +Options
thread_pool_destroy/1, % +Pool
thread_create_in_pool/4, % +Pool, :Goal, -Id, +Options
current_thread_pool/1, % ?Pool
thread_pool_property/2 % ?Pool, ?Property
]).
:- use_module(library(error)).
:- use_module(library(lists)).
:- use_module(library(option)).
:- use_module(library(rbtrees)).
:- use_module(library(debug)).
/** <module> Resource bounded thread management
The module library(thread_pool) manages threads in pools. A pool defines
properties of its member threads and the maximum number of threads that
can coexist in the pool. The call thread_create_in_pool/4 allocates a
thread in the pool, just like thread_create/3. If the pool is fully
allocated it can be asked to wait or raise an error.
The library has been designed to deal with server application that
recieve a variety of requests, such as HTTP servers. Simply starting a
thread for each request is a bit too simple minded for such servers:
* Creating many CPU intensive threads often leads to a slow-down
rather than a speedup.
* Creating many memory intensive threads may exhaust resources
* Tasks that require little CPU and memory but take long waiting
for external resources can run many threads.
Using this library, one can define a pool for each set of tasks with
comparable characteristics and create threads in this pool. Unlike the
worker-pool model, threads are not started immediately. Depending on the
design, both approaches can be attractive.
The library is implemented by means of a manager thread with the fixed
thread id =|__thread_pool_manager|=. All state is maintained in this
manager thread, which receives and processes requests to create and
destroy pools, create threads in a pool and handle messages from
terminated threads. Thread pools are _not_ saved in a saved state and
must therefore be recreated using the initialization/1 directive or
otherwise during startup of the application.
@see http_handler/3 and http_spawn/2.
*/
:- meta_predicate
thread_create_in_pool(+, 0, -, +).
%% thread_pool_create(+Pool, +Size, +Options) is det.
%
% Create a pool of threads. A pool of threads is a declaration for
% creating threads with shared properties (stack sizes) and a
% limited number of threads. Threads are created using
% thread_create_in_pool/4. If all threads in the pool are in use,
% the behaviour depends on the =wait= option of
% thread_create_in_pool/4 and the =backlog= option described
% below. Options are passed to thread_create/3, except for
%
% * backlog(+MaxBackLog)
% Maximum number of requests that can be suspended. Default
% is =infinite=. Otherwise it must be a non-negative integer.
% Using backlog(0) will never delay thread creation for this
% pool.
%
% The pooling mechanism does _not_ interact with the =detached=
% state of a thread. Threads can be created both =detached= and
% normal and must be joined using thread_join/2 if they are not
% detached.
%
% @bug The thread creation option =at_exit= is reserved for
% internal use by this library.
thread_pool_create(Name, Size, Options) :-
pool_manager(Manager),
thread_self(Me),
thread_send_message(Manager, create_pool(Name, Size, Options, Me)),
wait_reply.
%% thread_pool_destroy(+Name) is det.
%
% Destroy the thread pool named Name.
%
% @error existence_error(thread_pool, Name).
thread_pool_destroy(Name) :-
pool_manager(Manager),
thread_self(Me),
thread_send_message(Manager, destroy_pool(Name, Me)),
wait_reply.
%% current_thread_pool(?Name) is nondet.
%
% True if Name refers to a defined thread pool.
current_thread_pool(Name) :-
pool_manager(Manager),
thread_self(Me),
thread_send_message(Manager, current_pools(Me)),
wait_reply(Pools),
( atom(Name)
-> memberchk(Name, Pools)
; member(Name, Pools)
).
%% thread_pool_property(?Name, ?Property) is nondet.
%
% True if Property is a property of thread pool Name. Defined
% properties are:
%
% * options(Options)
% Thread creation options for this pool
% * free(Size)
% Number of free slots on this pool
% * size(Size)
% Total number of slots on this pool
% * members(ListOfIDs)
% ListOfIDs is the list or threads running in this pool
% * running(Running)
% Number of running threads in this pool
% * backlog(Size)
% Number of delayed thread creations on this pool
thread_pool_property(Name, Property) :-
current_thread_pool(Name),
pool_manager(Manager),
thread_self(Me),
thread_send_message(Manager, pool_properties(Me, Name, Property)),
wait_reply(Props),
( nonvar(Property)
-> memberchk(Property, Props)
; member(Property, Props)
).
%% thread_create_in_pool(+Pool, :Goal, -Id, +Options) is det.
%
% Create a thread in Pool. Options overrule default thread
% creation options associated to the pool. In addition, the
% following option is defined:
%
% * wait(+Boolean)
% If =true= (default) and the pool is full, wait until a
% member of the pool completes. If =false=, throw a
% resource_error.
%
% @error resource_error(threads_in_pool(Pool)) is raised if wait
% is =false= or the backlog limit has been reached.
% @error existence_error(thread_pool, Pool) if Pool does not
% exist.
thread_create_in_pool(Pool, Goal, Id, Options) :-
select_option(wait(Wait), Options, ThreadOptions, true),
pool_manager(Manager),
thread_self(Me),
thread_send_message(Manager,
create(Pool, Goal, Me, Wait, ThreadOptions)),
wait_reply(Id).
/*******************************
* START MANAGER *
*******************************/
%% pool_manager(-ThreadID) is det.
%
% ThreadID is the thread (alias) identifier of the manager. Starts
% the manager if it is not running.
pool_manager(TID) :-
TID = '__thread_pool_manager',
( thread_running(TID)
-> true
; with_mutex('__thread_pool', create_pool_manager(TID))
).
thread_running(Thread) :-
catch(thread_property(Thread, status(Status)),
E, true),
( var(E)
-> ( Status == running
-> true
; thread_join(Thread, _),
print_message(warning, thread_pool(manager_died(Status))),
fail
)
; E = error(existence_error(thread, Thread), _)
-> fail
; throw(E)
).
create_pool_manager(Thread) :-
thread_running(Thread), !.
create_pool_manager(Thread) :-
rb_new(State0),
thread_create(manage_thread_pool(State0), _,
[ alias(Thread)
]).
/*******************************
* MANAGER LOGIC *
*******************************/
%% manage_thread_pool(+State)
manage_thread_pool(State0) :-
thread_get_message(Message),
( update_thread_pool(Message, State0, State)
-> debug(thread_pool(state), 'Message ~p --> ~p', [Message, State]),
manage_thread_pool(State)
; format(user_error, 'Update failed: ~p~n', [Message])
).
update_thread_pool(create_pool(Name, Size, Options, For), State0, State) :- !,
( rb_insert_new(State0,
Name, tpool(Options, Size, Size, WP, WP, []),
State)
-> thread_send_message(For, thread_pool(true))
; reply_error(For, permission_error(create, thread_pool, Name)),
State = State0
).
update_thread_pool(destroy_pool(Name, For), State0, State) :- !,
( rb_delete(State0, Name, State)
-> thread_send_message(For, thread_pool(true))
; reply_error(For, existence_error(thread_pool, Name)),
State = State0
).
update_thread_pool(current_pools(For), State, State) :- !,
rb_keys(State, Keys),
debug(thread_pool(current), 'Reply to ~w: ~p', [For, Keys]),
reply(For, Keys).
update_thread_pool(pool_properties(For, Name, P), State, State) :- !,
( rb_lookup(Name, Pool, State)
-> findall(P, pool_property(P, Pool), List),
reply(For, List)
; reply_error(For, existence_error(thread_pool, Name))
).
update_thread_pool(Message, State0, State) :-
arg(1, Message, Name),
( rb_lookup(Name, Pool0, State0)
-> update_pool(Message, Pool0, Pool),
rb_update(State0, Name, Pool, State)
; State = State0,
( Message = create(Name, _, For, _, _)
-> reply_error(For, existence_error(thread_pool, Name))
; true
)
).
pool_property(options(Options),
tpool(Options, _Free, _Size, _WP, _WPT, _Members)).
pool_property(backlog(Size),
tpool(_, _Free, _Size, WP, WPT, _Members)) :-
diff_list_length(WP, WPT, Size).
pool_property(free(Free),
tpool(_, Free, _Size, _, _, _)).
pool_property(size(Size),
tpool(_, _Free, Size, _, _, _)).
pool_property(running(Count),
tpool(_, Free, Size, _, _, _)) :-
Count is Size - Free.
pool_property(members(IDList),
tpool(_, _, _, _, _, IDList)).
diff_list_length(List, Tail, Size) :-
'$skip_list'(Length, List, Rest),
( Rest == Tail
-> Size = Length
; type_error(difference_list, List/Tail)
).
%% update_pool(+Message, +Pool0, -Pool) is det.
%
% Deal with create requests and completion messages on a given
% pool. There are two messages:
%
% * create(PoolName, Goal, ForThread, Wait, Options)
% Create a new thread on behalve of ForThread. There are
% two cases:
% * Free slots: create the thread
% * No free slots: error or add to waiting
% * exitted(PoolName, Thread)
% A thread completed. If there is a request waiting,
% create a new one.
update_pool(create(Name, Goal, For, _, MyOptions),
tpool(Options, Free0, Size, WP, WPT, Members0),
tpool(Options, Free, Size, WP, WPT, Members)) :-
succ(Free, Free0), !,
thread_self(Me),
merge_options(MyOptions, Options, ThreadOptions),
( option(at_exit(_), ThreadOptions)
-> reply_error(For, permission_error(specify, option, at_axit)),
Members = Members0
; Exit = thread_send_message(Me, exitted(Name, Id)),
catch(thread_create(Goal, Id,
[ at_exit(Exit)
| ThreadOptions
]),
E, true),
( var(E)
-> Members = [Id|Members0],
reply(For, Id)
; reply_error(For, E),
Members = Members0
)
).
update_pool(Create,
tpool(Options, 0, Size, WP, WPT0, Members),
tpool(Options, 0, Size, WP, WPT, Members)) :-
Create = create(Name, _Goal, For, Wait, _Options), !,
option(backlog(BackLog), Options, infinite),
( can_delay(Wait, BackLog, WP, WPT0)
-> WPT0 = [Create|WPT],
debug(thread_pool, 'Delaying ~p', [Create])
; WPT = WPT0,
reply_error(For, resource_error(threads_in_pool(Name)))
).
update_pool(exitted(_Name, Id),
tpool(Options, Free0, Size, WP0, WPT, Members0),
Pool) :-
succ(Free0, Free),
delete(Members0, Id, Members1),
Pool1 = tpool(Options, Free, Size, WP, WPT, Members1),
( WP0 == WPT
-> WP = WP0,
Pool = Pool1
; WP0 = [Waiting|WP],
debug(thread_pool, 'Start delayed ~p', [Waiting]),
update_pool(Waiting, Pool1, Pool)
).
can_delay(true, infinite, _, _) :- !.
can_delay(true, BackLog, WP, WPT) :-
diff_list_length(WP, WPT, Size),
BackLog > Size.
/*******************************
* UTIL *
*******************************/
reply(To, Term) :-
thread_send_message(To, thread_pool(true(Term))).
reply_error(To, Error) :-
thread_send_message(To, thread_pool(error(Error, _))).
wait_reply :-
thread_get_message(thread_pool(Result)),
( Result == true
-> true
; Result == fail
-> fail
; throw(Result)
).
wait_reply(Value) :-
thread_get_message(thread_pool(Reply)),
( Reply = true(Value0)
-> Value = Value0
; Reply == fail
-> fail
; throw(Reply)
).
/*******************************
* MESSAGES *
*******************************/
:- multifile
prolog:message/3.
% Print messages
prolog:message(thread_pool(Message)) -->
message(Message).
prolog:message(manager_died(Status)) -->
[ 'Thread-pool: manager died on status ~p; restarting'-[Status] ].

1048
swi/library/url.pl Normal file
View File

File diff suppressed because it is too large Load Diff

134
swi/library/utf8.pl Normal file
View File

@@ -0,0 +1,134 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: wielemak@science.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2005, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(utf8,
[ utf8_codes//1 % ?String
]).
%% utf8_codes(?Codes)// is det.
%
% DCG translating between a Unicode code-list and its UTF-8
% encoded byte-string. The DCG works two ways. Encoding a
% code-list to a UTF-8 byte string is achieved using
%
% phrase(utf8_codes(Codes), UTF8)
%
% The algorithm is a close copy of the C-algorithm used
% internally and defined in src/pl-utf8.c
%
% NOTE: in many cases you can avoid this library and leave
% encoding and decoding to I/O streams. If only part of the data
% is to be encoded the encoding of a stream can be switched
% temporary using set_stream(Stream, encoding(utf8))
utf8_codes([H|T]) -->
utf8_code(H), !,
utf8_codes(T).
utf8_codes([]) -->
[].
utf8_code(C) -->
[C0],
{ nonvar(C0) }, !, % decoding version
( {C0 < 0x80}
-> {C = C0}
; {C0/\0xe0 =:= 0xc0}
-> utf8_cont(C1, 0),
{C is (C0/\0x1f)<<6\/C1}
; {C0/\0xf0 =:= 0xe0}
-> utf8_cont(C1, 6),
utf8_cont(C2, 0),
{C is ((C0/\0xf)<<12)\/C1\/C2}
; {C0/\0xf8 =:= 0xf0}
-> utf8_cont(C1, 12),
utf8_cont(C2, 6),
utf8_cont(C3, 0),
{C is ((C0/\0x7)<<18)\/C1\/C2\/C3}
; {C0/\0xfc =:= 0xf8}
-> utf8_cont(C1, 18),
utf8_cont(C2, 12),
utf8_cont(C3, 6),
utf8_cont(C4, 0),
{C is ((C0/\0x3)<<24)\/C1\/C2\/C3\/C4}
; {C0/\0xfe =:= 0xfc}
-> utf8_cont(C1, 24),
utf8_cont(C2, 18),
utf8_cont(C3, 12),
utf8_cont(C4, 6),
utf8_cont(C5, 0),
{C is ((C0/\0x1)<<30)\/C1\/C2\/C3\/C4\/C5}
).
utf8_code(C) -->
{ nonvar(C) }, !, % encoding version
( { C < 0x80 }
-> [C]
; { C < 0x800 }
-> { C0 is 0xc0\/((C>>6)/\0x1f),
C1 is 0x80\/(C/\0x3f)
},
[C0,C1]
; { C < 0x10000 }
-> { C0 is 0xe0\/((C>>12)/\0x0f),
C1 is 0x80\/((C>>6)/\0x3f),
C2 is 0x80\/(C/\0x3f)
},
[C0,C1,C2]
; { C < 0x200000 }
-> { C0 is 0xf0\/((C>>18)/\0x07),
C1 is 0x80\/((C>>12)/\0x3f),
C2 is 0x80\/((C>>6)/\0x3f),
C3 is 0x80\/(C/\0x3f)
},
[C0,C1,C2,C3]
; { C < 0x4000000 }
-> { C0 is 0xf8\/((C>>24)/\0x03),
C1 is 0x80\/((C>>18)/\0x3f),
C2 is 0x80\/((C>>12)/\0x3f),
C3 is 0x80\/((C>>6)/\0x3f),
C4 is 0x80\/(C/\0x3f)
},
[C0,C1,C2,C3,C4]
; { C < 0x80000000 }
-> { C0 is 0xfc\/((C>>30)/\0x01),
C1 is 0x80\/((C>>24)/\0x3f),
C2 is 0x80\/((C>>18)/\0x3f),
C3 is 0x80\/((C>>12)/\0x3f),
C4 is 0x80\/((C>>6)/\0x3f),
C5 is 0x80\/(C/\0x3f)
},
[C0,C1,C2,C3,C4,C5]
).
utf8_cont(Val, Shift) -->
[C],
{ C/\0xc0 =:= 0x80,
Val is (C/\0x3f)<<Shift
}.

252
swi/library/win_menu.pl Executable file
View File

@@ -0,0 +1,252 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: jan@swi.psy.uva.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2002, University of Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(win_menu,
[ init_win_menus/0
]).
:- use_module(library(lists)).
:- use_module(library(www_browser)).
:- set_prolog_flag(generate_debug_info, false).
:- op(200, fy, @).
:- op(990, xfx, :=).
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This library sets up the menu of PLWIN.EXE. It is called from the system
initialisation file plwin.rc, predicate gui_setup_/0.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
menu('&File',
[ '&Consult ...' = win_menu:action(user:compile(+file(open,
'Load file into Prolog'))),
% '&Edit ...' = win_menu:action(user:edit(+file(open,
% 'Edit existing file'))),
% '&New ...' = win_menu:action(edit_new(+file(save,
% 'Create new Prolog source'))),
--,
'&Reload modified files' = user:make,
% --,
% '&Navigator ...' = prolog_ide(open_navigator),
--
],
[ before_item('&Exit')
]).
/*
menu('&Settings',
[ --,
'&User init file ...' = prolog_edit_preferences(prolog)
% '&GUI preferences ...' = prolog_edit_preferences(xpce)
],
[]).
menu('&Debug',
[ %'&Trace' = trace,
%'&Debug mode' = debug,
%'&No debug mode' = nodebug,
'&Edit spy points ...' = user:prolog_ide(open_debug_status),
'&Edit exceptions ...' = user:prolog_ide(open_exceptions(@on)),
'&Threads monitor ...' = user:prolog_ide(thread_monitor),
'Debug &messages ...' = user:prolog_ide(debug_monitor),
'Cross &referencer ...'= user:prolog_ide(xref),
--,
'&Graphical debugger' = user:guitracer
],
[ before_menu(-)
]).
*/
menu('&Help',
[ '&About ...' = about,
'&Help ...' = help,
'YAP &Manual (on www) ...' = win_menu:www_open(yap_man),
--,
'YAP &WWW home (on www) ...' = win_menu:www_open(yap),
'YAP &GIT (on www) ...' = win_menu:www_open(yap_git),
% 'YAP Mailing &List (on www) ...' = win_menu:www_open(swipl_mail),
'YAP &Download (on www) ...' = win_menu:www_open(yap_download),
--,
% '&XPCE (GUI) Manual ...' = manpce,
% --,
'Submit &Bug report (on www) ...' = win_menu:www_open(yap_bugs)
],
[ before_menu(-)
]).
init_win_menus :-
( menu(Menu, Items, Options),
( memberchk(before_item(Before), Options)
-> true
; Before = (-)
),
( memberchk(before_menu(BM), Options)
-> system:win_insert_menu(Menu, BM)
; true
),
( member(Item, Items),
( Item = (Label = Action)
-> true
; Item == --
-> Label = --
),
win_insert_menu_item(Menu, Label, Before, Action),
fail
; true
),
fail
; insert_associated_file
).
insert_associated_file :-
current_prolog_flag(associated_file, File),
file_base_name(File, Base),
atom_concat('Edit &', Base, Label),
win_insert_menu_item('&File', Label, '&New ...', edit(file(File))).
insert_associated_file.
:- initialization
( win_has_menu
-> init_win_menus
; true
).
/*******************************
* ACTIONS *
*******************************/
edit_new(File) :-
call(edit(file(File))). % avoid autoloading
www_open(Id) :-
Spec =.. [Id, '.'],
call(expand_url_path(Spec, URL)),
print_message(informational, opening_url(URL)),
call(www_open_url(URL)), % avoid autoloading
print_message(informational, opened_url(URL)).
html_open(Spec) :-
absolute_file_name(Spec, [access(read)], Path),
call(win_shell(open, Path)).
about :-
print_message(informational, about).
/*******************************
* HANDLE CALLBACK *
*******************************/
action(Action) :-
strip_module(Action, Module, Plain),
Plain =.. [Name|Args],
gather_args(Args, Values),
Goal =.. [Name|Values],
Module:Goal.
gather_args([], []).
gather_args([+H0|T0], [H|T]) :- !,
gather_arg(H0, H),
gather_args(T0, T).
gather_args([H|T0], [H|T]) :-
gather_args(T0, T).
gather_arg(file(Mode, Title), File) :-
findall(tuple('Prolog Source', Pattern),
prolog_file_pattern(Pattern),
Tuples),
append(Tuples, [tuple('All files', '*.*')], AllTuples),
Filter =.. [chain|AllTuples],
current_prolog_flag(hwnd, HWND),
working_directory(CWD, CWD),
% filter(AllTuples, Filter),
win_open_file_name(HWND, CWD, File).
%% call(get(@display, win_file_name, % avoid autoloading
%% Mode, Filter, Title,
%% directory := CWD,
%% owner := HWND,
%% File)).
prolog_file_pattern(Pattern) :-
user:prolog_file_type(Ext, prolog),
atom_concat('*.', Ext, Pattern).
/*******************************
* APPLICATION *
*******************************/
%% init_win_app
%
% If Prolog is started using --win_app, try to change directory
% to <My Documents>\Prolog.
init_win_app :-
current_prolog_flag(associated_file, _), !.
init_win_app :-
current_prolog_flag(argv, Argv),
append(Pre, ['--win_app'|_Post], Argv),
\+ member(--, Pre), !,
catch(my_prolog, E, print_message(warning, E)).
init_win_app.
my_prolog :-
win_folder(personal, MyDocs),
atom_concat(MyDocs, '/Prolog', PrologDir),
( ensure_dir(PrologDir)
-> working_directory(_, PrologDir)
; working_directory(_, MyDocs)
).
ensure_dir(Dir) :-
exists_directory(Dir), !.
ensure_dir(Dir) :-
catch(make_directory(Dir), E, (print_message(warning, E), fail)).
:- initialization
init_win_app.
/*******************************
* MESSAGES *
*******************************/
:- multifile
prolog:message/3.
prolog:message(opening_url(Url)) -->
[ 'Opening ~w ... '-[Url], flush ].
prolog:message(opened_url(_Url)) -->
[ at_same_line, 'ok' ].

225
swi/library/www_browser.pl Executable file
View File

@@ -0,0 +1,225 @@
/* $Id$
Part of SWI-Prolog
Author: Jan Wielemaker
E-mail: J.Wielemaker@cs.vu.nl
WWW: http://www.swi-prolog.org
Copyright (C): 1985-2011, University of Amsterdam
VU University Amsterdam
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
As a special exception, if you link this library with other files,
compiled with a Free Software compiler, to produce an executable, this
library does not by itself cause the resulting executable to be covered
by the GNU General Public License. This exception does not however
invalidate any other reasons why the executable file might be covered by
the GNU General Public License.
*/
:- module(www_browser,
[ www_open_url/1, % +UrlOrSpec
expand_url_path/2 % +Spec, -URL
]).
:- use_module(library(lists)).
:- use_module(library(readutil)).
:- multifile
known_browser/2.
%% www_open_url(+Url)
%
% Open URL in running version of the users' browser or start a new
% browser. This predicate tries the following steps:
%
% 1. If a prolog flag (see set_prolog_flag/2) =browser= is set
% or the environment =BROWSER= and this is the name of a known
% executable, use this. This uses www_open_url/2.
%
% 2. On Windows, use win_shell(open, URL)
%
% 3. Find a generic `open' comment. Candidates are =open=,
% =|gnome-open|=, =kfmclient=.
%
% 4. Try to find a known browser.
%
% @tbd Figure out the right tool in step 3 as it is not
% uncommon that multiple are installed.
www_open_url(Spec) :- % user configured
( current_prolog_flag(browser, Browser)
; getenv('BROWSER', Browser)
),
has_command(Browser), !,
expand_url_path(Spec, URL),
www_open_url(Browser, URL).
:- if(current_predicate(win_shell/2)).
www_open_url(Spec) :- % Windows shell
expand_url_path(Spec, URL),
win_shell(open, URL).
:- endif.
www_open_url(Spec) :- % Unix `open document'
open_command(Open),
has_command(Open), !,
expand_url_path(Spec, URL),
format(string(Cmd), '~w "~w"', [Open, URL]),
shell(Cmd).
www_open_url(Spec) :- % KDE client
has_command(kfmclient), !,
expand_url_path(Spec, URL),
format(string(Cmd), 'kfmclient openURL "~w"', [URL]),
shell(Cmd).
www_open_url(Spec) :- % something we know
known_browser(Browser, _),
has_command(Browser), !,
expand_url_path(Spec, URL),
www_open_url(Browser, URL).
open_command('gnome-open').
open_command(open).
%% www_open_url(+Browser, +URL) is det.
%
% Open a page using a browser. Preferably we use an existing
% browser to to the job. Currently only supports browsers with a
% netscape compatible remote interface.
%
% @see http://www.mozilla.org/unix/remote.html
www_open_url(Browser, URL) :-
compatible(Browser, netscape),
netscape_remote(Browser, 'ping()', []), !,
netscape_remote(Browser, 'openURL(~w,new-window)', [URL]).
www_open_url(Browser, URL) :-
format(string(Cmd), '"~w" "~w" &', [Browser, URL]),
shell(Cmd).
%% netscape_remote(+Browser, +Format, +Args) is semidet.
%
% Execute netscape remote command using =|-remote|=. Create the
% remote command using format/3 from Format and Args.
%
% @bug At least firefox gives always 0 exit code on -remote,
% so we must check the error message. Grrrr.
netscape_remote(Browser, Fmt, Args) :-
format(string(RCmd), Fmt, Args),
format(string(Cmd), '"~w" -remote "~w" 2>&1', [Browser, RCmd]),
open(pipe(Cmd), read, In),
call_cleanup(read_stream_to_codes(In, Codes),
close(In)),
( append("Error:", _, Codes)
-> !, fail
; true
).
compatible(Browser, With) :-
file_base_name(Browser, Base),
known_browser(Base, With).
%% known_browser(+FileBaseName, -Compatible)
%
% True if browser FileBaseName has a remote protocol compatible to
% Compatible.
known_browser(firefox, netscape).
known_browser(mozilla, netscape).
known_browser(netscape, netscape).
known_browser(konqueror, -).
known_browser(opera, -).
%% has_command(+Command)
%
% Succeeds if Command is in $PATH. Works for Unix systems. For
% Windows we have to test for executable extensions.
:- dynamic
command_cache/2.
:- volatile
command_cache/2.
has_command(Command) :-
command_cache(Command, Path), !,
Path \== (-).
has_command(Command) :-
( getenv('PATH', Path),
( current_prolog_flag(windows, true)
-> Sep = (;)
; Sep = (:)
),
atomic_list_concat(Parts, Sep, Path),
member(Part, Parts),
prolog_to_os_filename(PlPart, Part),
atomic_list_concat([PlPart, Command], /, Exe),
access_file(Exe, execute)
-> assert(command_cache(Command, Exe))
; assert(command_cache(Command, -)),
fail
).
/*******************************
* NET PATHS *
*******************************/
%% url_path(+Alias, -Expansion) is nondet.
%
% Define URL path aliases. This multifile predicate is defined in
% module =user=. Expansion is either a URL, or a term Alias(Sub).
:- multifile
user:url_path/2.
user:url_path(swipl, 'http://www.swi-prolog.org').
user:url_path(swipl_faq, swipl('FAQ')).
user:url_path(swipl_man, swipl('pldoc/index.html')).
user:url_path(swipl_mail, swipl('Mailinglist.html')).
user:url_path(swipl_download, swipl('Download.html')).
user:url_path(swipl_bugs, swipl('bugzilla')).
user:url_path(swipl_quick, swipl('man/quickstart.html')).
user:url_path(yap, 'http://www.dcc.fc.up.pt/~vsc/Yap').
user:url_path(yap_download, 'http://www.dcc.fc.up.pt/~vsc/Yap/downloads.html').
user:url_path(yap_man, yap('documentation.html')).
user:url_path(yap_bugs, 'http://sourceforge.net/tracker/?group_id=24437&atid=381483').
user:url_path(yap_git, 'http://yap.git.sourceforge.net/git/gitweb-index.cgi').
%% expand_url_path(+Spec, -URL)
%
% Expand URL specifications similar to absolute_file_name/3. The
% predicate url_path/2 plays the role of file_search_path/2.
expand_url_path(URL, URL) :-
atomic(URL), !. % Allow atom and string
expand_url_path(Spec, URL) :-
Spec =.. [Path, Local],
( user:url_path(Path, Spec2)
-> expand_url_path(Spec2, URL0),
( Local == '.'
-> URL = URL0
; sub_atom(Local, 0, _, _, #)
-> atom_concat(URL0, Local, URL)
; atomic_list_concat([URL0, Local], /, URL)
)
; throw(error(existence_error(url_path, Path), expand_url_path/2))
).