Mercurial > emacs
changeset 112321:dc74e58f6b0b
Merge from mainline.
| author | Paul Eggert <eggert@cs.ucla.edu> |
|---|---|
| date | Tue, 11 Jan 2011 21:57:19 -0800 |
| parents | a4a6f5f8f078 (current diff) 978fe18f0882 (diff) |
| children | ecce7818cd6f |
| files | src/ChangeLog src/fns.c src/image.c |
| diffstat | 44 files changed, 4932 insertions(+), 759 deletions(-) [+] |
line wrap: on
line diff
--- a/admin/bzrmerge.el Sun Jan 09 00:42:24 2011 -0800 +++ b/admin/bzrmerge.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,22 +1,22 @@ ;;; bzrmerge.el --- -;; Copyright (C) 2010 Stefan Monnier +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; Author: Stefan Monnier <monnier@iro.umontreal.ca> ;; Keywords: -;; This program is free software; you can redistribute it and/or modify +;; GNU Emacs 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 3 of the License, or ;; (at your option) any later version. -;; This program is distributed in the hope that it will be useful, +;; GNU Emacs 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, see <http://www.gnu.org/licenses/>. +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. ;;; Commentary: @@ -202,7 +202,7 @@ "merge" "-r" (format "%s" endrevno) from) (call-process "bzr" nil t nil "revert" ".") (call-process "bzr" nil t nil "unshelve"))) - + (defvar bzrmerge-already-done nil) (defun bzrmerge-apply (missing from)
--- a/doc/lispref/ChangeLog Sun Jan 09 00:42:24 2011 -0800 +++ b/doc/lispref/ChangeLog Tue Jan 11 21:57:19 2011 -0800 @@ -1,3 +1,7 @@ +2011-01-11 Stefan Monnier <monnier@iro.umontreal.ca> + + * loading.texi (Hooks for Loading): Adjust doc of eval-after-load. + 2011-01-02 Eli Zaretskii <eliz@gnu.org> * modes.texi (Emulating Mode Line): Fix last change. @@ -8884,7 +8888,7 @@ ;; End: Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, - 2007, 2008, 2009, 2010 Free Software Foundation, Inc. + 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. This file is part of GNU Emacs.
--- a/doc/lispref/files.texi Sun Jan 09 00:42:24 2011 -0800 +++ b/doc/lispref/files.texi Tue Jan 11 21:57:19 2011 -0800 @@ -1919,7 +1919,7 @@ abbreviations to use for file directories. Each element has the form @code{(@var{from} . @var{to})}, and says to replace @var{from} with @var{to} when it appears in a directory name. The @var{from} string is -actually a regular expression; it should always start with @samp{\`}. +actually a regular expression; it ought to always start with @samp{\`}. The @var{to} string should be an ordinary absolute directory name. Do not use @samp{~} to stand for a home directory in that string. The function @code{abbreviate-file-name} performs these substitutions.
--- a/doc/lispref/loading.texi Sun Jan 09 00:42:24 2011 -0800 +++ b/doc/lispref/loading.texi Tue Jan 11 21:57:19 2011 -0800 @@ -962,7 +962,8 @@ @end example @var{library} can also be a feature (i.e.@: a symbol), in which case -@var{form} is evaluated when @code{(provide @var{library})} is called. +@var{form} is evaluated at the end of any file where +@code{(provide @var{library})} is called. An error in @var{form} does not undo the load, but does prevent execution of the rest of @var{form}.
--- a/doc/misc/ChangeLog Sun Jan 09 00:42:24 2011 -0800 +++ b/doc/misc/ChangeLog Tue Jan 11 21:57:19 2011 -0800 @@ -1,3 +1,8 @@ +2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de> + + * dbus.texi (Receiving Method Calls): New function + dbus-register-service. Rearrange node. + 2011-01-07 Paul Eggert <eggert@cs.ucla.edu> * texinfo.tex: Update to version 2010-12-23.17 from gnulib,
--- a/doc/misc/dbus.texi Sun Jan 09 00:42:24 2011 -0800 +++ b/doc/misc/dbus.texi Tue Jan 11 21:57:19 2011 -0800 @@ -1244,9 +1244,73 @@ @cindex method calls, returning @cindex returning method calls -Emacs can also offer own methods, which can be called by other -applications. These methods could be an implementation of an -interface of a well known service, like @samp{org.freedesktop.TextEditor}. +In order to register methods on the D-Bus, Emacs has to request a well +known name on the D-Bus under which it will be available for other +clients. Names on the D-Bus can be registered and unregistered using +the following functions: + +@defun dbus-register-service bus service &rest flags +Register the known name @var{service} on D-Bus @var{bus}. + +@var{bus} is either the symbol @code{:system} or the symbol +@code{:session}. + +@var{service} is the service name to be registered on the D-Bus. It +must be a known name. + +@var{flags} is a subset of the following keywords: + +@itemize +@item @code{:allow-replacement}: Allow another service to become the primary +owner if requested. + +@item @code{:replace-existing}: Request to replace the current primary owner. + +@item @code{:do-not-queue}: If we can not become the primary owner do not +place us in the queue. +@end itemize + +One of the following keywords is returned: + +@itemize + +@item @code{:primary-owner}: We have become the primary owner of the name +@var{service}. + +@item @code{:in-queue}: We could not become the primary owner and +have been placed in the queue. + +@item @code{:exists}: We already are in the queue. + +@item @code{:already-owner}: We already are the primary +owner. +@end itemize +@end defun + +@defun dbus-unregister-service bus service +Unregister all objects from D-Bus @var{bus}, registered by Emacs for +@var{service}. + +@var{bus} is either the symbol @code{:system} or the symbol +@code{:session}. + +@var{service} is the D-Bus service name of the D-Bus. It must be a +known name. Emacs releases its association to @var{service} from +D-Bus. + +One of the following keywords is returned: + +@itemize +@item @code{:released}: We successfully released the name @var{service}. +@item @code{:non-existent}: The name @var{service} does not exist on the bus. +@item @code{:not-owner}: We are not an owner of the name @var{service}. +@end itemize +@end defun + +When a name has been chosen, Emacs can offer own methods, which can be +called by other applications. These methods could be an +implementation of an interface of a well known service, like +@samp{org.freedesktop.TextEditor}. It could be also an implementation of an own interface. In this case, the service name must be @samp{org.gnu.Emacs}. The object path shall @@ -1300,7 +1364,7 @@ @var{service} is not registered. This means that other D-Bus clients have no way of noticing the newly registered method. When interfaces are constructed incrementally by adding single methods or properties -at a time, @var{dont-register-service} can be use to prevent other +at a time, @var{dont-register-service} can be used to prevent other clients from discovering the still incomplete interface. The default D-Bus timeout when waiting for a message reply is 25 @@ -1414,7 +1478,7 @@ @var{service} is not registered. This means that other D-Bus clients have no way of noticing the newly registered method. When interfaces are constructed incrementally by adding single methods or properties -at a time, @var{dont-register-service} can be use to prevent other +at a time, @var{dont-register-service} can be used to prevent other clients from discovering the still incomplete interface. @noindent Example: @@ -1491,18 +1555,6 @@ to the service from D-Bus. @end defun -@defun dbus-unregister-service bus service -Unregister all objects from D-Bus @var{bus}, registered by Emacs for -@var{service}. - -@var{bus} is either the symbol @code{:system} or the symbol -@code{:session}. - -@var{service} is the D-Bus service name of the D-Bus. It must be a -known name. Emacs releases its association to @var{service} from -D-Bus. -@end defun - @node Signals @chapter Sending and receiving signals.
--- a/etc/ChangeLog Sun Jan 09 00:42:24 2011 -0800 +++ b/etc/ChangeLog Tue Jan 11 21:57:19 2011 -0800 @@ -1,3 +1,14 @@ +2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de> + + * NEWS: Add new function dbus-register-service. + +2011-01-09 Chong Yidong <cyd@stupidchicken.com> + + * themes/tango-theme.el, themes/tango-dark-theme.el: Let-bind + tango palette colors. Only define faces for color displays. + Customize the ansi-color-names-vector variable. Add Ediff, + Flyspell, and Semantic faces as suggested by Jan Moringen. + 2011-01-08 Andreas Schwab <schwab@linux-m68k.org> * compilation.txt: Add column to gcc-include sample.
--- a/etc/NEWS Sun Jan 09 00:42:24 2011 -0800 +++ b/etc/NEWS Tue Jan 11 21:57:19 2011 -0800 @@ -219,9 +219,10 @@ is to search in `custom-theme-directory', followed by a built-in theme directory named "themes/" in `data-directory'. -*** New option `custom-safe-theme-files' lists known-safe theme files. -If a theme is not in this list, Emacs queries before loading it. -The default value treats all themes included in Emacs as safe. +*** New option `custom-safe-themes' records known-safe theme files. +If a theme is not in this list, Emacs queries before loading it, and +offers to save the theme to `custom-safe-themes' automatically. By +default, all themes included in Emacs are treated as safe. ** The user option `remote-file-name-inhibit-cache' controls whether the remote file-name cache is used for read access. @@ -322,6 +323,10 @@ * Changes in Specialized Modes and Packages in Emacs 24.1 +** Prolog mode has been completely revamped, with lots of additional +functionality such as more intelligent indentation, electricty, support for +more variants, including Mercury, and a lot more. + ** shell-mode can track your cwd by reading it from your prompt. Just set shell-dir-cookie-re to an appropriate regexp. @@ -564,7 +569,12 @@ *** It is possible now, to access alternative buses than the default system or session bus. -*** dbus-register-{method,property} do not necessarily register names anymore. +*** dbus-register-{service,method,property} +The -method and -property functions do not automatically register +names anymore. + +The new function dbus-register-service registers a service known name +on a D-Bus without simultaneously registering a property or a method. ** Tramp
--- a/etc/themes/tango-dark-theme.el Sun Jan 09 00:42:24 2011 -0800 +++ b/etc/themes/tango-dark-theme.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,6 +1,9 @@ ;;; tango-dark-theme.el --- Tango-based custom theme for faces -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. + +;; Authors: Chong Yidong <cyd@stupidchicken> +;; Jan Moringen <jan.moringen@uni-bielefeld.de> ;; This file is part of GNU Emacs. @@ -25,63 +28,124 @@ ;;; Code: (deftheme tango-dark - "Theme for faces, based on the Tango palette on a dark background. -Basic, Font Lock, Isearch, Gnus, and Message faces are included.") + "Theme for faces, based on the Tango palette with a dark background. +Basic, Font Lock, Isearch, Gnus, Message, Ediff, Flyspell, +Semantic, and Ansi-Color faces are included.") + +(let ((class '((class color) (min-colors 89))) + ;; Tango palette colors. + (butter-1 "#fce94f") (butter-2 "#edd400") (butter-3 "#c4a000") + (orange-1 "#fcaf3e") (orange-2 "#f57900") (orange-3 "#ce5c00") + (choc-1 "#e9b96e") (choc-2 "#c17d11") (choc-3 "#8f5902") + (cham-1 "#8ae234") (cham-2 "#73d216") (cham-3 "#4e9a06") + (blue-1 "#729fcf") (blue-2 "#3465a4") (blue-3 "#204a87") + (plum-1 "#ad7fa8") (plum-2 "#75507b") (plum-3 "#5c3566") + (red-1 "#ef2929") (red-2 "#cc0000") (red-3 "#a40000") + (alum-1 "#eeeeec") (alum-2 "#d3d7cf") (alum-3 "#babdb6") + (alum-4 "#888a85") (alum-5 "#555753") (alum-6 "#2e3436") + ;; Not in Tango palette; used for better contrast. + (cham-0 "#b4fa70") (blue-0 "#8cc4ff") (plum-0 "#e6a8df") + (red-0 "#ff4b4b") (alum-5.5 "#41423f") (alum-7 "#212526")) -(custom-theme-set-faces - 'tango-dark - '(default ((t (:foreground "#eeeeec" :background "#2e3436")))) - '(cursor ((t (:foreground "#2e3436" :background "#fce94f")))) - '(highlight ((t (:foreground "#2e3436" :background "#edd400")))) - '(region ((t (:background "#555753")))) - '(font-lock-builtin-face ((t (:foreground "#ad7fa8")))) - '(font-lock-comment-face ((t (:foreground "#73d216")))) - '(font-lock-constant-face ((t (:foreground "#e6a8df")))) - '(font-lock-function-name-face ((t (:foreground "#fce94f")))) - '(font-lock-keyword-face ((t (:foreground "#8cc4ff")))) - '(font-lock-string-face ((t (:foreground "#e9b96e")))) - '(font-lock-type-face ((t (:foreground "#a5ff4d")))) - '(font-lock-variable-name-face ((t (:foreground "#fcaf3e")))) - '(font-lock-warning-face ((t (:foreground "#ef2929")))) - '(button ((t (:underline t :foreground "#729fcf")))) - '(link ((t (:underline t :foreground "#729fcf")))) - '(link-visited ((t (:underline t :foreground "#3465a4")))) - '(mode-line ((t (:box (:line-width -1 :style released-button) - :background "#d3d7cf" :foreground "black")))) - '(mode-line-inactive ((t (:box (:line-width -1 :style released-button) - :background "#555753" :foreground "white")))) - '(isearch ((t (:foreground "#ffffff" :background "#ce5c00")))) - '(lazy-highlight ((t (:background "#8f5902")))) - '(gnus-group-news-1 ((t (:foreground "#ad7fa8")))) - '(gnus-group-news-1-low ((t (:foreground "#75507b")))) - '(gnus-group-news-2 ((t (:foreground "#729fcf")))) - '(gnus-group-news-2-low ((t (:foreground "#3465a4")))) - '(gnus-group-news-3 ((t (:foreground "#8ae234")))) - '(gnus-group-news-3-low ((t (:foreground "#73d216")))) - '(gnus-group-news-4 ((t (:foreground "#e9b9e6")))) - '(gnus-group-news-4-low ((t (:foreground "#c17d11")))) - '(gnus-group-news-5 ((t (:foreground "#fcaf3e")))) - '(gnus-group-news-5-low ((t (:foreground "#f57900")))) - '(gnus-group-news-low ((t (:foreground "#edd400")))) - '(gnus-group-mail-1 ((t (:foreground "#ad7fa8")))) - '(gnus-group-mail-1-low ((t (:foreground "#75507b")))) - '(gnus-group-mail-2 ((t (:foreground "#729fcf")))) - '(gnus-group-mail-2-low ((t (:foreground "#3465a4")))) - '(gnus-group-mail-3 ((t (:foreground "#8ae234")))) - '(gnus-group-mail-3-low ((t (:foreground "#73d216")))) - '(gnus-group-mail-low ((t (:foreground "#edd400")))) - '(gnus-header-content ((t (:weight normal :foreground "#c4a000")))) - '(gnus-header-from ((t (:foreground "#edd400")))) - '(gnus-header-subject ((t (:foreground "#8ae234")))) - '(gnus-header-name ((t (:foreground "#729fcf")))) - '(gnus-header-newsgroups ((t (:foreground "#c17d11")))) - '(message-header-name ((t (:foreground "#729fcf")))) - '(message-header-cc ((t (:foreground "#c4a000")))) - '(message-header-other ((t (:foreground "#c17d11")))) - '(message-header-subject ((t (:foreground "#8ae234")))) - '(message-header-to ((t (:foreground "#edd400")))) - '(message-cited-text ((t (:foreground "#8ae234")))) - '(message-separator ((t (:foreground "#ad7fa8"))))) + (custom-theme-set-faces + 'tango-dark + `(default ((,class (:foreground ,alum-1 :background ,alum-6)))) + `(cursor ((,class (:foreground ,alum-6 :background ,butter-1)))) + ;; Highlighting faces + `(fringe ((,class (:background ,alum-7)))) + `(highlight ((,class (:foreground ,alum-6 :background ,butter-2)))) + `(region ((,class (:background ,alum-5)))) + `(secondary-selection ((,class (:background ,blue-3)))) + `(isearch ((,class (:foreground ,alum-1 :background ,orange-3)))) + `(lazy-highlight ((,class (:background ,choc-3)))) + `(trailing-whitespace ((,class (:background ,red-3)))) + ;; Mode line faces + `(mode-line ((,class + (:box (:line-width -1 :style released-button) + :background ,alum-2 :foreground ,alum-6)))) + `(mode-line-inactive ((,class + (:box (:line-width -1 :style released-button) + :background ,alum-5 :foreground ,alum-1)))) + ;; Escape and prompt faces + `(minibuffer-prompt ((,class (:foreground ,cham-0)))) + `(escape-glyph ((,class (:foreground ,butter-3)))) + ;; Font lock faces + `(font-lock-builtin-face ((,class (:foreground ,plum-1)))) + `(font-lock-comment-face ((,class (:foreground ,cham-2)))) + `(font-lock-constant-face ((,class (:foreground ,plum-0)))) + `(font-lock-function-name-face ((,class (:foreground ,butter-1)))) + `(font-lock-keyword-face ((,class (:foreground ,cham-0)))) + `(font-lock-string-face ((,class (:foreground ,choc-1)))) + `(font-lock-type-face ((,class (:foreground ,blue-0)))) + `(font-lock-variable-name-face ((,class (:foreground ,orange-1)))) + `(font-lock-warning-face ((,class (:foreground ,red-0)))) + ;; Button and link faces + `(button ((,class (:underline t :foreground ,blue-1)))) + `(link ((,class (:underline t :foreground ,blue-1)))) + `(link-visited ((,class (:underline t :foreground ,blue-2)))) + ;; Gnus faces + `(gnus-group-news-1 ((,class (:foreground ,plum-1)))) + `(gnus-group-news-1-low ((,class (:foreground ,plum-2)))) + `(gnus-group-news-2 ((,class (:foreground ,blue-1)))) + `(gnus-group-news-2-low ((,class (:foreground ,blue-2)))) + `(gnus-group-news-3 ((,class (:foreground ,cham-1)))) + `(gnus-group-news-3-low ((,class (:foreground ,cham-2)))) + `(gnus-group-news-4 ((,class (:foreground ,plum-0)))) + `(gnus-group-news-4-low ((,class (:foreground ,choc-2)))) + `(gnus-group-news-5 ((,class (:foreground ,orange-1)))) + `(gnus-group-news-5-low ((,class (:foreground ,orange-2)))) + `(gnus-group-news-low ((,class (:foreground ,butter-2)))) + `(gnus-group-mail-1 ((,class (:foreground ,plum-1)))) + `(gnus-group-mail-1-low ((,class (:foreground ,plum-2)))) + `(gnus-group-mail-2 ((,class (:foreground ,blue-1)))) + `(gnus-group-mail-2-low ((,class (:foreground ,blue-2)))) + `(gnus-group-mail-3 ((,class (:foreground ,cham-1)))) + `(gnus-group-mail-3-low ((,class (:foreground ,cham-2)))) + `(gnus-group-mail-low ((,class (:foreground ,butter-2)))) + `(gnus-header-content ((,class (:weight normal :foreground ,butter-3)))) + `(gnus-header-from ((,class (:foreground ,butter-2)))) + `(gnus-header-subject ((,class (:foreground ,cham-1)))) + `(gnus-header-name ((,class (:foreground ,blue-1)))) + `(gnus-header-newsgroups ((,class (:foreground ,choc-2)))) + ;; Message faces + `(message-header-name ((,class (:foreground ,blue-1)))) + `(message-header-cc ((,class (:foreground ,butter-3)))) + `(message-header-other ((,class (:foreground ,choc-2)))) + `(message-header-subject ((,class (:foreground ,cham-1)))) + `(message-header-to ((,class (:foreground ,butter-2)))) + `(message-cited-text ((,class (:foreground ,cham-1)))) + `(message-separator ((,class (:foreground ,plum-1)))) + ;; SMerge faces + `(smerge-refined-change ((,class (:background ,blue-3)))) + ;; Ediff faces + `(ediff-current-diff-A ((,class (:background ,alum-5)))) + `(ediff-fine-diff-A ((,class (:background ,blue-3)))) + `(ediff-even-diff-A ((,class (:background ,alum-5.5)))) + `(ediff-odd-diff-A ((,class (:background ,alum-5.5)))) + `(ediff-current-diff-B ((,class (:background ,alum-5)))) + `(ediff-fine-diff-B ((,class (:background ,choc-3)))) + `(ediff-even-diff-B ((,class (:background ,alum-5.5)))) + `(ediff-odd-diff-B ((,class (:background ,alum-5.5)))) + ;; Flyspell faces + `(flyspell-duplicate ((,class (:underline ,orange-1)))) + `(flyspell-incorrect ((,class (:underline ,red-1)))) + ;; Semantic faces + `(semantic-decoration-on-includes ((,class (:underline ,alum-4)))) + `(semantic-decoration-on-private-members-face + ((,class (:background ,plum-3)))) + `(semantic-decoration-on-protected-members-face + ((,class (:background ,choc-3)))) + `(semantic-decoration-on-unknown-includes + ((,class (:background ,red-3)))) + `(semantic-decoration-on-unparsed-includes + ((,class (:background ,alum-5.5)))) + `(semantic-tag-boundary-face ((,class (:overline ,blue-1)))) + `(semantic-unmatched-syntax-face ((,class (:underline ,red-1))))) + + (custom-theme-set-variables + 'tango-dark + `(ansi-color-names-vector [,alum-7 ,red-0 ,cham-0 ,butter-1 + ,blue-1 ,plum-1 ,blue-0 ,alum-1]))) (provide-theme 'tango-dark)
--- a/etc/themes/tango-theme.el Sun Jan 09 00:42:24 2011 -0800 +++ b/etc/themes/tango-theme.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,6 +1,9 @@ ;;; tango-theme.el --- Tango-based custom theme for faces -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. + +;; Authors: Chong Yidong <cyd@stupidchicken> +;; Jan Moringen <jan.moringen@uni-bielefeld.de> ;; This file is part of GNU Emacs. @@ -25,63 +28,117 @@ ;;; Code: (deftheme tango - "Theme for faces, based on the Tango palette on a light background. -Basic, Font Lock, Isearch, Gnus, and Message faces are included.") + "Theme for faces, based on the Tango palette with a light background. +Basic, Font Lock, Isearch, Gnus, Message, Ediff, Flyspell, +Semantic, and Ansi-Color faces are included.") + +(let ((class '((class color) (min-colors 89))) + ;; Tango palette colors. + (butter-1 "#fce94f") (butter-2 "#edd400") (butter-3 "#c4a000") + (orange-1 "#fcaf3e") (orange-2 "#f57900") (orange-3 "#ce5c00") + (choc-1 "#e9b96e") (choc-2 "#c17d11") (choc-3 "#8f5902") + (cham-1 "#8ae234") (cham-2 "#73d216") (cham-3 "#4e9a06") + (blue-1 "#729fcf") (blue-2 "#3465a4") (blue-3 "#204a87") + (plum-1 "#ad7fa8") (plum-2 "#75507b") (plum-3 "#5c3566") + (red-1 "#ef2929") (red-2 "#cc0000") (red-3 "#a40000") + (alum-1 "#eeeeec") (alum-2 "#d3d7cf") (alum-3 "#babdb6") + (alum-4 "#888a85") (alum-5 "#555753") (alum-6 "#2e3436") + ;; Not in Tango palette; used for better contrast. + (cham-4 "#346604") (blue-0 "#8cc4ff")) -(custom-theme-set-faces - 'tango - '(default ((t (:foreground "#16191a" :background "#eeeeec")))) - '(cursor ((t (:foreground "#eeeeec" :background "#204a87")))) - '(highlight ((t (:background "#babdb6")))) - '(region ((t (:background "#babdb6")))) - '(font-lock-builtin-face ((t (:weight bold :foreground "#204a87")))) - '(font-lock-comment-face ((t (:foreground "#204a87")))) - '(font-lock-constant-face ((t (:weight bold :foreground "#5c3566")))) - '(font-lock-function-name-face ((t (:weight bold :foreground "#ce5c00")))) - '(font-lock-keyword-face ((t (:foreground "#a40000")))) - '(font-lock-string-face ((t (:foreground "#5c3566")))) - '(font-lock-type-face ((t (:weight bold :foreground "#4e9a06")))) - '(font-lock-variable-name-face ((t (:weight bold :foreground "#c17d11")))) - '(font-lock-warning-face ((t (:foreground "#cc0000")))) - '(button ((t (:underline t :foreground "#204a87")))) - '(link ((t (:underline t :foreground "#204a87")))) - '(link-visited ((t (:underline t :foreground "#3465a4")))) - '(mode-line ((t (:box (:line-width -1 :style released-button) - :background "#d3d7cf" :foreground "black")))) - '(mode-line-inactive ((t (:box (:line-width -1 :style released-button) - :background "#babdb6" :foreground "black")))) - '(isearch ((t (:foreground "#ffffff" :background "#ce5c00")))) - '(lazy-highlight ((t (:background "#e9b96e")))) - '(gnus-group-news-1 ((t (:weight bold :foreground "#5c3566")))) - '(gnus-group-news-1-low ((t (:foreground "#5c3566")))) - '(gnus-group-news-2 ((t (:weight bold :foreground "#204a87")))) - '(gnus-group-news-2-low ((t (:foreground "#204a87")))) - '(gnus-group-news-3 ((t (:weight bold :foreground "#4e0a06")))) - '(gnus-group-news-3-low ((t (:foreground "#4e0a06")))) - '(gnus-group-news-4 ((t (:weight bold :foreground "#7a4c02")))) - '(gnus-group-news-4-low ((t (:foreground "#7a4c02")))) - '(gnus-group-news-5 ((t (:weight bold :foreground "#ce5c00")))) - '(gnus-group-news-5-low ((t (:foreground "#ce5c00")))) - '(gnus-group-news-low ((t (:foreground "#888a85")))) - '(gnus-group-mail-1 ((t (:weight bold :foreground "#5c3566")))) - '(gnus-group-mail-1-low ((t (:foreground "#5c3566")))) - '(gnus-group-mail-2 ((t (:weight bold :foreground "#204a87")))) - '(gnus-group-mail-2-low ((t (:foreground "#204a87")))) - '(gnus-group-mail-3 ((t (:weight bold :foreground "#4e0a06")))) - '(gnus-group-mail-3-low ((t (:foreground "#4e0a06")))) - '(gnus-group-mail-low ((t (:foreground "#888a85")))) - '(gnus-header-content ((t (:foreground "#4e9a06")))) - '(gnus-header-from ((t (:weight bold :foreground "#c4a000")))) - '(gnus-header-subject ((t (:foreground "#4e0a06")))) - '(gnus-header-name ((t (:foreground "#204a87")))) - '(gnus-header-newsgroups ((t (:foreground "#888a85")))) - '(message-header-name ((t (:foreground "#204a87")))) - '(message-header-cc ((t (:foreground "#c4a000")))) - '(message-header-other ((t (:foreground "#c17d11")))) - '(message-header-subject ((t (:foreground "#4e0a06")))) - '(message-header-to ((t (:weight bold :foreground "#c4a000")))) - '(message-cited-text ((t (:foreground "#888a85")))) - '(message-separator ((t (:weight bold :foreground "#4e9a06"))))) + (custom-theme-set-faces + 'tango + `(default ((,class (:foreground ,"#16191a" :background ,alum-1)))) + `(cursor ((,class (:foreground ,alum-1 :background ,blue-3)))) + ;; Highlighting faces + `(fringe ((,class (:background ,alum-2)))) + `(highlight ((,class (:background ,alum-3)))) + `(region ((,class (:background ,alum-3)))) + `(secondary-selection ((,class (:background ,blue-0)))) + `(isearch ((,class (:foreground ,"#ffffff" :background ,orange-3)))) + `(lazy-highlight ((,class (:background ,choc-1)))) + `(trailing-whitespace ((,class (:background ,red-1)))) + ;; Mode line faces + `(mode-line ((,class (:box (:line-width -1 :style released-button) + :background ,alum-2 :foreground ,alum-6)))) + `(mode-line-inactive ((,class (:box (:line-width -1 :style released-button) + :background ,alum-4 :foreground ,alum-6)))) + ;; Escape and prompt faces + `(minibuffer-prompt ((,class (:weight bold :foreground ,blue-3)))) + `(escape-glyph ((,class (:foreground ,red-3)))) + ;; Font lock faces + `(font-lock-builtin-face ((,class (:weight bold :foreground ,plum-3)))) + `(font-lock-comment-face ((,class (:foreground ,cham-4)))) + `(font-lock-constant-face ((,class (:weight bold :foreground ,blue-3)))) + `(font-lock-function-name-face ((,class (:foreground ,red-3)))) + `(font-lock-keyword-face ((,class (:weight bold :foreground ,choc-2)))) + `(font-lock-string-face ((,class (:foreground ,plum-3)))) + `(font-lock-type-face ((,class (:foreground ,blue-3)))) + `(font-lock-variable-name-face ((,class (:weight bold :foreground ,orange-3)))) + `(font-lock-warning-face ((,class (:foreground ,red-2)))) + ;; Button and link faces + `(button ((,class (:underline t :foreground ,blue-3)))) + `(link ((,class (:underline t :foreground ,blue-3)))) + `(link-visited ((,class (:underline t :foreground ,blue-2)))) + ;; Gnus faces + `(gnus-group-news-1 ((,class (:weight bold :foreground ,plum-3)))) + `(gnus-group-news-1-low ((,class (:foreground ,plum-3)))) + `(gnus-group-news-2 ((,class (:weight bold :foreground ,blue-3)))) + `(gnus-group-news-2-low ((,class (:foreground ,blue-3)))) + `(gnus-group-news-3 ((,class (:weight bold :foreground ,"#4e0a06")))) + `(gnus-group-news-3-low ((,class (:foreground ,"#4e0a06")))) + `(gnus-group-news-4 ((,class (:weight bold :foreground ,"#7a4c02")))) + `(gnus-group-news-4-low ((,class (:foreground ,"#7a4c02")))) + `(gnus-group-news-5 ((,class (:weight bold :foreground ,orange-3)))) + `(gnus-group-news-5-low ((,class (:foreground ,orange-3)))) + `(gnus-group-news-low ((,class (:foreground ,"#888a85")))) + `(gnus-group-mail-1 ((,class (:weight bold :foreground ,plum-3)))) + `(gnus-group-mail-1-low ((,class (:foreground ,plum-3)))) + `(gnus-group-mail-2 ((,class (:weight bold :foreground ,blue-3)))) + `(gnus-group-mail-2-low ((,class (:foreground ,blue-3)))) + `(gnus-group-mail-3 ((,class (:weight bold :foreground ,"#4e0a06")))) + `(gnus-group-mail-3-low ((,class (:foreground ,"#4e0a06")))) + `(gnus-group-mail-low ((,class (:foreground ,"#888a85")))) + `(gnus-header-content ((,class (:foreground ,cham-3)))) + `(gnus-header-from ((,class (:weight bold :foreground ,butter-3)))) + `(gnus-header-subject ((,class (:foreground ,"#4e0a06")))) + `(gnus-header-name ((,class (:foreground ,blue-3)))) + `(gnus-header-newsgroups ((,class (:foreground ,"#888a85")))) + ;; Message faces + `(message-header-name ((,class (:foreground ,blue-3)))) + `(message-header-cc ((,class (:foreground ,butter-3)))) + `(message-header-other ((,class (:foreground ,choc-2)))) + `(message-header-subject ((,class (:foreground ,"#4e0a06")))) + `(message-header-to ((,class (:weight bold :foreground ,butter-3)))) + `(message-cited-text ((,class (:foreground ,"#888a85")))) + `(message-separator ((,class (:weight bold :foreground ,cham-3)))) + ;; SMerge + `(smerge-refined-change ((,class (:background ,plum-1)))) + ;; Ediff + `(ediff-current-diff-A ((,class (:background ,blue-1)))) + `(ediff-fine-diff-A ((,class (:background ,plum-1)))) + `(ediff-current-diff-B ((,class (:background ,butter-1)))) + `(ediff-fine-diff-B ((,class (:background ,orange-1)))) + ;; Flyspell + `(flyspell-duplicate ((,class (:underline ,orange-1)))) + `(flyspell-incorrect ((,class (:underline ,red-1)))) + ;; Semantic faces + `(semantic-decoration-on-includes ((,class (:underline ,cham-4)))) + `(semantic-decoration-on-private-members-face + ((,class (:background ,alum-2)))) + `(semantic-decoration-on-protected-members-face + ((,class (:background ,alum-2)))) + `(semantic-decoration-on-unknown-includes + ((,class (:background ,choc-3)))) + `(semantic-decoration-on-unparsed-includes + ((,class (:underline ,orange-3)))) + `(semantic-tag-boundary-face ((,class (:overline ,blue-1)))) + `(semantic-unmatched-syntax-face ((,class (:underline ,red-1))))) + + (custom-theme-set-variables + 'tango + `(ansi-color-names-vector [,alum-6 ,red-3 ,cham-3 ,butter-3 + ,blue-3 ,plum-3 ,blue-1 ,alum-1]))) (provide-theme 'tango)
--- a/etc/themes/tsdh-dark-theme.el Sun Jan 09 00:42:24 2011 -0800 +++ b/etc/themes/tsdh-dark-theme.el Tue Jan 11 21:57:19 2011 -0800 @@ -31,6 +31,7 @@ '(diff-indicator-changed ((t (:weight bold)))) '(diff-indicator-removed ((t (:inherit diff-indicator-changed)))) '(diff-removed ((t (:inherit diff-changed :background "sandy brown")))) + '(dired-directory ((t (:inherit font-lock-function-name-face :weight bold)))) '(hl-line ((t (:background "grey28")))) '(message-header-subject ((t (:foreground "SkyBlue")))) '(minibuffer-prompt ((t (:background "yellow" :foreground "medium blue" :box (:line-width -1 :color "red" :style released-button) :weight bold))))
--- a/etc/themes/tsdh-light-theme.el Sun Jan 09 00:42:24 2011 -0800 +++ b/etc/themes/tsdh-light-theme.el Tue Jan 11 21:57:19 2011 -0800 @@ -31,6 +31,7 @@ '(diff-indicator-changed ((t (:weight bold)))) '(diff-indicator-removed ((t (:inherit diff-indicator-changed)))) '(diff-removed ((t (:inherit diff-changed :background "sandy brown")))) + '(dired-directory ((t (:inherit font-lock-function-name-face :weight bold)))) '(hl-line ((t (:background "grey95")))) '(minibuffer-prompt ((t (:background "yellow" :foreground "medium blue" :box (:line-width -1 :color "red" :style released-button) :weight bold)))) '(mode-line ((t (:box (:line-width -1 :color "red" :style released-button) :family "DejaVu Sans"))))
--- a/lisp/ChangeLog Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/ChangeLog Tue Jan 11 21:57:19 2011 -0800 @@ -1,5 +1,128 @@ +2011-01-11 Johan Bockgård <bojohan@gnu.org> + + * emacs-lisp/unsafep.el (unsafep): Handle backquoted forms. + +2011-01-11 Stefan Monnier <monnier@iro.umontreal.ca> + + * progmodes/prolog.el: Fix up coding convention and such. + (prolog-indent-width): Use the same default as in + previous prolog.el rather than tab-width which depends on which buffer + is current when the file is loaded. + (prolog-electric-newline-flag): Only enable if electric-indent-mode + is not available. + (prolog-emacs): Remove. Use (featurep 'xemacs) instead. + (prolog-known-systems): Remove. + (prolog-mode-syntax-table, prolog-inferior-mode-map): + Move initialization into declaration. + (prolog-mode-map): Move initialization into declaration. + Remove system-specific mode-map vars, since they referred to the same + keymap anyway. + (prolog-mode-variables): Obey the user's preference w.r.t + adaptive-fill-mode. Prefer symbol-value to `eval'. + (prolog-mode-keybindings-edit): Add compatibility bindings. + (prolog-mode): Use define-derived-mode. Don't handle mercury here. + (mercury-mode-map): New var. + (mercury-mode, prolog-inferior-mode): Use define-derived-mode. + (prolog-ensure-process, prolog-process-insert-string) + (prolog-consult-compile): Use with-current-buffer. + (prolog-guess-fill-prefix): Simplify data flow. + (prolog-replace-in-string): New function to use instead of + replace-in-string. + (prolog-enable-sicstus-sd): Don't abuse `eval'. + (prolog-uncomment-region): Use `uncomment-region' when available. + (prolog-electric-colon, prolog-electric-dash): Use `eolp'. + (prolog-int-to-char, prolog-char-to-int): New functions to use instead + of int-to-char and char-to-int. + (prolog-mode-hook, prolog-inferior-mode-hook): Don't force font-lock. + +2011-01-11 Stefan Bruda <stefan@bruda.ca> + + * progmodes/prolog.el: Replace by a whole new file. + +2011-01-11 Stefan Monnier <monnier@iro.umontreal.ca> + + * subr.el (eval-after-load): Fix timing for features (bug#7769). + (declare-function, undefined, insert-for-yank) + (replace-regexp-in-string): Follow checkdoc's recommendations. + +2011-01-10 Stefan Monnier <monnier@iro.umontreal.ca> + + * calendar/diary-lib.el (diary-mode): Refresh *Calendar* after + refreshing the diary buffer. + +2011-01-10 Ken Manheimer <ken.manheimer@gmail.com> + + * allout.el: Add 2011 to the file copyright. + (allout-encrypt-string): Prevent encryption from adding an extra + newline at the end of the topic body. + (allout-version): Increment to 2.3. + +2011-01-10 Michael Albinus <michael.albinus@gmx.de> + + * net/dbus.el (dbus-unregister-service): Complete doc. + Fix call of dbus-error signal. + (dbus-register-property): Use `dont-register' keyword. + +2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de> + + * net/dbus.el (dbus-unregister-service): Translate returned + integer into a symbol. + (dbus-register-property): Use `dbus-register-service' to do the + name registration. + +2011-01-09 Chong Yidong <cyd@stupidchicken.com> + + * progmodes/idlw-help.el (idlwave-help-link): Inherit from link face. + Suggested by Joakim Verona. + + * comint.el (comint-highlight-prompt): Inherit minibuffer-prompt. + + * wid-edit.el (visibility): Replace :on-image and :off-image + widget properties with :on-glyph and :off-glyph, for consistency + with the `visibility' widget. + (widget-toggle-value-create, widget-visibility-value-create): + Merge into a single function `widget-toggle-value-create'. + + * cus-edit.el (custom-variable-value-create, custom-visibility) + (custom-face-edit-value-create, custom-face-value-create): + Replace :on-image and :off-image widget properties with :on-glyph and + :off-glyph, for consistency with the `visibility' widget. + +2011-01-09 Andreas Schwab <schwab@linux-m68k.org> + + * net/ldap.el (ldap-search-internal): Don't use eval. + +2011-01-09 Chong Yidong <cyd@stupidchicken.com> + + * subr.el (read-char-choice): Use read-key. + + * custom.el (custom-safe-themes): Rename from + custom-safe-theme-files. Add :risky tag. + (load-theme, custom-theme-load-confirm): Save sha1 hashes to + custom-safe-themes, not filenames. Suggested by Stefan Monnier. + +2011-01-09 Chong Yidong <cyd@stupidchicken.com> + + * tool-bar.el (tool-bar-setup): Remove Help button. Remove label + from Search and add a label to Undo. + + * vc/vc-dir.el (vc-dir-tool-bar-map): Rearrange, removing + inappropriate buttons and adding :vert-only tags. + + * progmodes/compile.el (compilation-mode-tool-bar-map): Adjust to + removal of Help tool-bar button. Remove Undo button for space. + + * info.el (info-tool-bar-map): Add :vert-only tags. + +2011-01-08 Tassilo Horn <tassilo@member.fsf.org> + + * doc-view.el (doc-view-mode-p): Check for png or imagemagick + image backend support. Either of them is fine. + 2011-01-08 Chong Yidong <cyd@stupidchicken.com> + * subr.el (y-or-n-p): Doc fix. + * custom.el (custom-safe-theme-files): New defcustom. (custom-theme-load-confirm): New function. (load-theme): Load theme using `load', confirming with @@ -97,7 +220,7 @@ 2011-01-04 Jan Moringen <jan.moringen@uni-bielefeld.de> - * net/dbus.el (dbus-register-property): Added optional parameter + * net/dbus.el (dbus-register-property): Add optional parameter dont-register-service. Updated docstring accordingly. 2011-01-04 Andreas Schwab <schwab@linux-m68k.org> @@ -266,8 +389,8 @@ 2010-12-30 Tassilo Horn <tassilo@member.fsf.org> - * doc-view.el (doc-view-mode, doc-view-toggle-display): Use - normal-mode without doc-view-mode bindings in auto-mode-alist as + * doc-view.el (doc-view-mode, doc-view-toggle-display): + Use normal-mode without doc-view-mode bindings in auto-mode-alist as fallback instead of hard coding fundamental mode. 2010-12-30 Tassilo Horn <tassilo@member.fsf.org> @@ -462,8 +585,8 @@ 2010-12-16 Leo <sdl.web@gmail.com> - * eshell/eshell.el (eshell-directory-name): Use - locate-user-emacs-file (Bug#7578). + * eshell/eshell.el (eshell-directory-name): + Use locate-user-emacs-file (Bug#7578). 2010-12-15 Glenn Morris <rgm@gnu.org> @@ -488,8 +611,8 @@ (tramp-handle-insert-file-contents): Do not set permanent-local property. - * net/tramp-cache.el (tramp-persistency-file-name): Use - `locate-user-emacs-file' if fboundp. + * net/tramp-cache.el (tramp-persistency-file-name): + Use `locate-user-emacs-file' if fboundp. * net/tramp-sh.el (tramp-methods): Add "ksu". (tramp-default-user-alist): Add "ksu". Use `regexp-opt' for
--- a/lisp/allout.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/allout.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,12 +1,12 @@ ;;; allout.el --- extensive outline mode for use alone and with other modes ;; Copyright (C) 1992, 1993, 1994, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. ;; Author: Ken Manheimer <ken dot manheimer at gmail dot com> ;; Maintainer: Ken Manheimer <ken dot manheimer at gmail dot com> ;; Created: Dec 1991 -- first release to usenet -;; Version: 2.2.2 +;; Version: 2.3 ;; Keywords: outlines wp languages ;; Website: http://myriadicity.net/Sundry/EmacsAllout @@ -569,7 +569,7 @@ `!' - exclamation point/bang -- emphatic `[' - open square bracket -- meta-note, about item instead of item's subject `\"' - double quote -- a quotation or other citation - `=' - equal sign -- an assignement, equating a name with some connotation + `=' - equal sign -- an assignment, some kind of definition `^' - carat -- relates to something above Some are more elusive, but their rationale may be recognizable: @@ -891,7 +891,7 @@ ;;;_ #1 Internal Outline Formatting and Configuration ;;;_ : Version ;;;_ = allout-version -(defvar allout-version "2.2.2" +(defvar allout-version "2.3" "Version of currently loaded outline package. (allout.el)") ;;;_ > allout-version (defun allout-version (&optional here) @@ -6226,10 +6226,11 @@ (epg-decrypt-string epg-context (encode-coding-string massaged-text (or encoding 'utf-8))) - (epg-encrypt-string epg-context - (encode-coding-string massaged-text - (or encoding 'utf-8)) - recipients))) + (replace-regexp-in-string "\n$" "" + (epg-encrypt-string epg-context + (encode-coding-string massaged-text + (or encoding 'utf-8)) + recipients)))) ;; validate result -- non-empty (if (not result-text)
--- a/lisp/calendar/diary-lib.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/calendar/diary-lib.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,7 +1,7 @@ ;;; diary-lib.el --- diary functions ;; Copyright (C) 1989, 1990, 1992, 1993, 1994, 1995, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 ;; Free Software Foundation, Inc. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu> @@ -2346,6 +2346,9 @@ '(diary-font-lock-keywords t)) (add-to-invisibility-spec '(diary . nil)) (add-hook 'after-save-hook 'diary-redraw-calendar nil t) + ;; In case the file was modified externally, refresh the calendar + ;; after refreshing the diary buffer. + (add-hook 'after-revert-hook 'diary-redraw-calendar nil t) (if diary-header-line-flag (setq header-line-format diary-header-line-format)))
--- a/lisp/comint.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/comint.el Tue Jan 11 21:57:19 2011 -0800 @@ -227,9 +227,7 @@ :group 'comint) (defface comint-highlight-prompt - '((((min-colors 88) (background dark)) (:foreground "cyan1")) - (((background dark)) (:foreground "cyan")) - (t (:foreground "dark blue"))) + '((t :inherit minibuffer-prompt)) "Face to use to highlight prompts." :group 'comint)
--- a/lisp/cus-edit.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/cus-edit.el Tue Jan 11 21:57:19 2011 -0800 @@ -2551,9 +2551,9 @@ (push (widget-create-child-and-convert widget 'custom-visibility :help-echo "Show the value of this option." - :on-image "down" + :on-glyph "down" :on "Hide" - :off-image "right" + :off-glyph "right" :off "Show Value" :action 'custom-toggle-hide-variable nil) @@ -2573,8 +2573,8 @@ :help-echo "Hide the value of this option." :on "Hide" :off "Show" - :on-image "down" - :off-image "right" + :on-glyph "down" + :off-glyph "right" :action 'custom-toggle-hide-variable t) buttons) @@ -2603,8 +2603,8 @@ :help-echo "Hide or show this option." :on "Hide" :off "Show" - :on-image "down" - :off-image "right" + :on-glyph "down" + :off-glyph "right" :action 'custom-toggle-hide-variable t) buttons) @@ -3056,8 +3056,8 @@ :pressed-face 'custom-visibility :mouse-face 'highlight :pressed-face 'highlight - :on-image nil - :off-image nil) + :on-glyph nil + :off-glyph nil) (defface custom-visibility '((t :height 0.8 :inherit link)) @@ -3120,7 +3120,7 @@ :pressed-face 'custom-visibility :mouse-face 'highlight :on "Hide Unused Attributes" :off "Show All Attributes" - :on-image nil :off-image nil + :on-glyph nil :off-glyph nil :always-active t :action 'custom-face-edit-value-visibility-action show-all) @@ -3475,7 +3475,7 @@ widget 'custom-visibility :help-echo "Hide or show this face." :on "Hide" :off "Show" - :on-image "down" :off-image "right" + :on-glyph "down" :off-glyph "right" :action 'custom-toggle-hide-face (not hiddenp)) buttons)
--- a/lisp/custom.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/custom.el Tue Jan 11 21:57:19 2011 -0800 @@ -1105,14 +1105,16 @@ (let ((custom-enabling-themes t)) (enable-theme 'user)))) -(defcustom custom-safe-theme-files '(default) - "List of theme files that are considered safe to load. -Each list element should be either an absolute file name, or the -symbol `default', which stands for the built-in Emacs theme -directory (a directory named \"themes\" in `data-directory'." +(defcustom custom-safe-themes '(default) + "List of themes that are considered safe to load. +Each list element should be the `sha1' hash of a theme file, or +the symbol `default', which stands for any theme in the built-in +Emacs theme directory (a directory named \"themes\" in +`data-directory')." :type '(repeat - (choice file (const :tag "Built-in theme directory" default))) + (choice string (const :tag "Built-in themes" default))) :group 'customize + :risky t :version "24.1") (defvar safe-functions) ; From unsafep.el @@ -1140,74 +1142,74 @@ (put theme 'theme-documentation nil)) (let ((fn (locate-file (concat (symbol-name theme) "-theme.el") (custom-theme--load-path) - '("" "c")))) + '("" "c"))) + hash) (unless fn (error "Unable to find theme file for `%s'." theme)) - ;; Check file safety. - (when (or (and (memq 'default custom-safe-theme-files) - (equal (file-name-directory fn) - (expand-file-name "themes/" data-directory))) - (member fn custom-safe-theme-files) - ;; If the file is not in the builtin theme directory or - ;; in `custom-safe-theme-files', check it with unsafep. - (with-temp-buffer - (require 'unsafep) - (insert-file-contents fn) - (let ((safe-functions (append '(provide-theme deftheme - custom-theme-set-variables - custom-theme-set-faces) - safe-functions)) - unsafep form) - (while (and (setq form (condition-case nil - (let ((read-circle nil)) - (read (current-buffer))) - (end-of-file nil))) - (null (setq unsafep (unsafep form))))) - (or (null unsafep) - (custom-theme-load-confirm fn))))) - (let ((custom--inhibit-theme-enable no-enable)) - (load fn))))) + (with-temp-buffer + (insert-file-contents fn) + (setq hash (sha1 (current-buffer))) + ;; Check file safety. + (when (or (and (memq 'default custom-safe-themes) + (equal (file-name-directory fn) + (expand-file-name "themes/" data-directory))) + (member hash custom-safe-themes) + ;; If the theme is not in `custom-safe-themes', check + ;; it with unsafep. + (progn + (require 'unsafep) + (let ((safe-functions + (append '(provide-theme deftheme + custom-theme-set-variables + custom-theme-set-faces) + safe-functions)) + unsafep form) + (while (and (setq form (condition-case nil + (let ((read-circle nil)) + (read (current-buffer))) + (end-of-file nil))) + (null (setq unsafep (unsafep form))))) + (or (null unsafep) + (custom-theme-load-confirm hash))))) + (let ((custom--inhibit-theme-enable no-enable)) + (eval-buffer)))))) -(defun custom-theme-load-confirm (filename) +(defun custom-theme-load-confirm (hash) + "Query the user about loading a Custom theme that may not be safe. +The theme should be in the current buffer. If the user agrees, +query also about adding HASH to `custom-safe-themes'." (if noninteractive nil - (let ((existing-buffer (find-buffer-visiting filename)) - (exit-chars '(?y ?n ?\s ?\C-g)) + (let ((exit-chars '(?y ?n ?\s)) prompt char) (save-window-excursion - (if existing-buffer - (pop-to-buffer existing-buffer) - (find-file filename)) - (unwind-protect - (progn - (setq prompt - (format "This theme is not guaranteed to be safe. Really load? %s" - (if (< (line-number-at-pos (point-max)) - (window-body-height)) - "(y or n) " - (push ?\C-v exit-chars) - "Type y or n, or C-v to scroll: "))) - (goto-char (point-min)) - (while (null char) - (setq char (read-char-choice prompt exit-chars t)) - (when (eq char ?\C-v) - (condition-case nil - (scroll-up) - (error (goto-char (point-min)))) - (setq char nil))) - (when (memq char '(?\s ?y)) - (push filename custom-safe-theme-files) - ;; Offer to save to `custom-safe-theme-files'. - (and (or custom-file user-init-file) - (y-or-n-p "Treat %s as safe for future loads? " - (file-name-nondirectory filename)) - (let ((coding-system-for-read nil)) - (customize-save-variable - 'custom-safe-theme-files - custom-safe-theme-files))) - t)) - ;; Unwind form. - (unless existing-buffer (kill-buffer))))))) + (rename-buffer "*Custom Theme*" t) + (emacs-lisp-mode) + (display-buffer (current-buffer)) + (setq prompt + (format "This theme is not guaranteed to be safe. Really load? %s" + (if (< (line-number-at-pos (point-max)) + (window-body-height)) + "(y or n) " + (push ?\C-v exit-chars) + "Type y or n, or C-v to scroll: "))) + (goto-char (point-min)) + (while (null char) + (setq char (read-char-choice prompt exit-chars)) + (when (eq char ?\C-v) + (condition-case nil + (scroll-up) + (error (goto-char (point-min)))) + (setq char nil))) + (when (memq char '(?\s ?y)) + (push hash custom-safe-themes) + ;; Offer to save to `custom-safe-themes'. + (and (or custom-file user-init-file) + (y-or-n-p "Treat this theme as safe for future loads? ") + (let ((coding-system-for-read nil)) + (customize-save-variable 'custom-safe-themes + custom-safe-themes))) + t))))) (defun custom-theme-name-valid-p (name) "Return t if NAME is a valid name for a Custom theme, nil otherwise.
--- a/lisp/doc-view.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/doc-view.el Tue Jan 11 21:57:19 2011 -0800 @@ -621,7 +621,8 @@ Document types are symbols like `dvi', `ps', `pdf', or `odf' (any OpenDocument format)." (and (display-graphic-p) - (image-type-available-p 'png) + (or (image-type-available-p 'imagemagick) + (image-type-available-p 'png)) (cond ((eq type 'dvi) (and (doc-view-mode-p 'pdf)
--- a/lisp/emacs-lisp/unsafep.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/emacs-lisp/unsafep.el Tue Jan 11 21:57:19 2011 -0800 @@ -202,6 +202,9 @@ (dolist (x (nthcdr 3 form)) (setq reason (unsafep-progn (cdr x))) (if reason (throw 'unsafep reason)))))) + ((eq fun '\`) + ;; Backquoted form - safe if its expansion is. + (unsafep (cdr (backquote-process (cadr form))))) (t ;;First unsafep-function call above wasn't nil, no special case applies reason)))))
--- a/lisp/files.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/files.el Tue Jan 11 21:57:19 2011 -0800 @@ -57,7 +57,7 @@ A list of elements of the form (FROM . TO), each meaning to replace FROM with TO when it appears in a directory name. This replacement is done when setting up the default directory of a newly visited file. -*Every* FROM string should start with \"\\\\`\". +*Every* FROM string ought to start with \"\\\\`\". FROM and TO should be equivalent names, which refer to the same directory. Do not use `~' in the TO strings;
--- a/lisp/gnus/ChangeLog Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/gnus/ChangeLog Tue Jan 11 21:57:19 2011 -0800 @@ -1,3 +1,22 @@ +2011-01-11 Lars Magne Ingebrigtsen <larsi@gnus.org> + + * nnimap.el (nnimap-convert-partial-article): Protect against + zero-length body parts. + + * mm-decode.el (mm-preferred-alternative-precedence): Discourage + showing empty parts. + + * gnus-int.el (gnus-request-accept-article): Don't try to update marks + and stuff if the backend didn't return the article number. This fixes + an Exchange-related nnimap bug. + + * gnus-sum.el (gnus-summary-next-article): Remove hack to reselect + group window, because it does the wrong thing when a separate frame + displays the group buffer. + + * proto-stream.el (open-protocol-stream): Protect against the low-level + transport functions returning nil. + 2011-01-07 Daiki Ueno <ueno@unixuser.org> * mml2015.el (epg-sub-key-fingerprint): Autoload.
--- a/lisp/gnus/gnus-int.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/gnus/gnus-int.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,7 +1,7 @@ ;;; gnus-int.el --- backend interface functions for Gnus ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004 -;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; 2005, 2006, 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: news @@ -711,7 +711,9 @@ (if (stringp group) (gnus-group-real-name group) group) (cadr gnus-command-method) last))) - (when (and gnus-agent (gnus-agent-method-p gnus-command-method)) + (when (and gnus-agent + (gnus-agent-method-p gnus-command-method) + (cdr result)) (gnus-agent-regenerate-group group (list (cdr result)))) result))
--- a/lisp/gnus/gnus-sum.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/gnus/gnus-sum.el Tue Jan 11 21:57:19 2011 -0800 @@ -7687,9 +7687,6 @@ (if (eq gnus-keep-same-level 'best) (gnus-summary-best-group gnus-newsgroup-name) (gnus-summary-search-group backward gnus-keep-same-level)))) - ;; For some reason, the group window gets selected. We change - ;; it back. - (select-window (get-buffer-window (current-buffer))) ;; Select next unread newsgroup automagically. (cond ((or (not gnus-auto-select-next)
--- a/lisp/gnus/mm-decode.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/gnus/mm-decode.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,7 +1,7 @@ ;;; mm-decode.el --- Functions for decoding MIME things ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; MORIOKA Tomohiko <morioka@jaist.ac.jp> @@ -1367,13 +1367,18 @@ (defun mm-preferred-alternative-precedence (handles) "Return the precedence based on HANDLES and `mm-discouraged-alternatives'." - (let ((seq (nreverse (mapcar #'mm-handle-media-type - handles)))) - (dolist (disc (reverse mm-discouraged-alternatives)) - (dolist (elem (copy-sequence seq)) - (when (string-match disc elem) - (setq seq (nconc (delete elem seq) (list elem)))))) - seq)) + (setq handles (reverse handles)) + (dolist (disc (reverse mm-discouraged-alternatives)) + (dolist (handle (copy-sequence handles)) + (when (string-match disc (mm-handle-media-type handle)) + (setq handles (nconc (delete handle handles) (list handle)))))) + ;; Remove empty parts. + (dolist (handle (copy-sequence handles)) + (unless (with-current-buffer (mm-handle-buffer handle) + (goto-char (point-min)) + (re-search-forward "[^ \t\n]" nil t)) + (setq handles (nconc (delete handle handles) (list handle))))) + (mapcar #'mm-handle-media-type handles)) (defun mm-get-content-id (id) "Return the handle(s) referred to by ID."
--- a/lisp/gnus/nnimap.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/gnus/nnimap.el Tue Jan 11 21:57:19 2011 -0800 @@ -582,7 +582,7 @@ ;; Collect all the body parts. (while (looking-at ".*BODY\\[\\([.0-9]+\\)\\]") (setq id (match-string 1) - bytes (nnimap-get-length)) + bytes (or (nnimap-get-length) 0)) (beginning-of-line) (delete-region (point) (progn (forward-line 1) (point))) (push (list id (buffer-substring (point) (+ (point) bytes)))
--- a/lisp/gnus/proto-stream.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/gnus/proto-stream.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,6 +1,6 @@ ;;; proto-stream.el --- negotiating TLS, STARTTLS and other connections -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org> ;; Keywords: network @@ -101,14 +101,17 @@ (setq type 'network)) ((eq type 'ssl) (setq type 'tls))) - (destructuring-bind (stream greeting capabilities) - (funcall (intern (format "proto-stream-open-%s" type) obarray) - name buffer host service parameters) - (list (and stream - (memq (process-status stream) - '(open run)) - stream) - greeting capabilities)))) + (let ((open-result + (funcall (intern (format "proto-stream-open-%s" type) obarray) + name buffer host service parameters))) + (if (null open-result) + (list nil nil nil) + (destructuring-bind (stream greeting capabilities) open-result + (list (and stream + (memq (process-status stream) + '(open run)) + stream) + greeting capabilities)))))) (defun proto-stream-open-network-only (name buffer host service parameters) (let ((start (with-current-buffer buffer (point)))
--- a/lisp/info.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/info.el Tue Jan 11 21:57:19 2011 -0800 @@ -3777,13 +3777,16 @@ (tool-bar-local-item-from-menu 'Info-up "up-node" map Info-mode-map :vert-only t) (define-key-after map [separator-2] menu-bar-separator) - (tool-bar-local-item-from-menu 'Info-top-node "home" map Info-mode-map) + (tool-bar-local-item-from-menu 'Info-top-node "home" map Info-mode-map + :vert-only t) (tool-bar-local-item-from-menu 'Info-goto-node "jump-to" map Info-mode-map) (define-key-after map [separator-3] menu-bar-separator) (tool-bar-local-item-from-menu 'Info-index "index" map Info-mode-map - :label "Index Search") - (tool-bar-local-item-from-menu 'Info-search "search" map Info-mode-map) - (tool-bar-local-item-from-menu 'Info-exit "exit" map Info-mode-map) + :label "Index") + (tool-bar-local-item-from-menu 'Info-search "search" map Info-mode-map + :vert-only t) + (tool-bar-local-item-from-menu 'Info-exit "exit" map Info-mode-map + :vert-only t) map)) (defvar Info-menu-last-node nil)
--- a/lisp/net/dbus.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/net/dbus.el Tue Jan 11 21:57:19 2011 -0800 @@ -183,7 +183,18 @@ (defun dbus-unregister-service (bus service) "Unregister all objects related to SERVICE from D-Bus BUS. BUS is either a Lisp symbol, `:system' or `:session', or a string -denoting the bus address. SERVICE must be a known service name." +denoting the bus address. SERVICE must be a known service name. + +The function returns a keyword, indicating the result of the +operation. One of the following keywords is returned: + +`:released': Service has become the primary owner of the name. + +`:non-existent': Service name does not exist on this bus. + +`:not-owner': We are neither the primary owner nor waiting in the +queue of this service." + (maphash (lambda (key value) (dolist (elt value) @@ -193,9 +204,14 @@ (puthash key (delete elt value) dbus-registered-objects-table) (remhash key dbus-registered-objects-table)))))) dbus-registered-objects-table) - (dbus-call-method - bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus - "ReleaseName" service)) + (let ((reply (dbus-call-method + bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus + "ReleaseName" service))) + (case reply + (1 :released) + (2 :non-existent) + (3 :not-owner) + (t (signal 'dbus-error (list "Could not unregister service" service)))))) (defun dbus-call-method-non-blocking-handler (&rest args) "Handler for reply messages of asynchronous D-Bus message calls. @@ -914,17 +930,20 @@ bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "RequestName" service 0)) - ;; Add the handler. We use `dbus-service-emacs' as service name, in - ;; order to let unregister SERVICE despite of this default handler. + ;; Add handlers for the three property-related methods. (dbus-register-method - bus service path dbus-interface-properties "Get" 'dbus-property-handler - dont-register-service) + bus service path dbus-interface-properties "Get" + 'dbus-property-handler 'dont-register) (dbus-register-method - bus service path dbus-interface-properties "GetAll" 'dbus-property-handler - dont-register-service) + bus service path dbus-interface-properties "GetAll" + 'dbus-property-handler 'dont-register) (dbus-register-method - bus service path dbus-interface-properties "Set" 'dbus-property-handler - dont-register-service) + bus service path dbus-interface-properties "Set" + 'dbus-property-handler 'dont-register) + + ;; Register the name SERVICE with BUS. + (unless dont-register-service + (dbus-register-service bus service)) ;; Send the PropertiesChanged signal. (when emits-signal
--- a/lisp/net/ldap.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/net/ldap.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,7 +1,7 @@ ;;; ldap.el --- client interface to LDAP for Emacs ;; Copyright (C) 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -;; 2007, 2008, 2009, 2010 Free Software Foundation, Inc. +;; 2007, 2008, 2009, 2010, 2011 Free Software Foundation, Inc. ;; Author: Oscar Figueiredo <oscar@cpe.fr> ;; Maintainer: FSF @@ -556,13 +556,9 @@ (if (and sizelimit (not (equal "" sizelimit))) (setq arglist (nconc arglist (list (format "-z%s" sizelimit))))) - (eval `(call-process ldap-ldapsearch-prog - nil - buf - nil - ,@arglist - ,@ldap-ldapsearch-args - ,@filter)) + (apply #'call-process ldap-ldapsearch-prog + nil buf nil + (append arglist ldap-ldapsearch-args filter)) (insert "\n") (goto-char (point-min))
--- a/lisp/org/ChangeLog Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/org/ChangeLog Tue Jan 11 21:57:19 2011 -0800 @@ -1,3 +1,8 @@ +2011-01-09 Chong Yidong <cyd@stupidchicken.com> + + * org-faces.el (org-link): Inherit from link face. + Suggested by Joakim Verona. + 2010-12-11 Tassilo Horn <tassilo@member.fsf.org> * org-footnote.el (org-footnote-create-definition): Place
--- a/lisp/org/org-faces.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/org/org-faces.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,6 +1,6 @@ ;;; org-faces.el --- Face definitions for Org-mode. -;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; Copyright (C) 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 ;; Free Software Foundation, Inc. ;; Author: Carsten Dominik <carsten at orgmode dot org> @@ -247,9 +247,7 @@ :group 'org-faces) (defface org-link - '((((class color) (background light)) (:foreground "Purple" :underline t)) - (((class color) (background dark)) (:foreground "Cyan" :underline t)) - (t (:underline t))) + '((t :inherit link)) "Face for links." :group 'org-faces)
--- a/lisp/progmodes/compile.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/progmodes/compile.el Tue Jan 11 21:57:19 2011 -0800 @@ -1569,9 +1569,11 @@ (defvar compilation-mode-tool-bar-map ;; When bootstrapping, tool-bar-map is not properly initialized yet, ;; so don't do anything. - (when (keymapp (butlast tool-bar-map)) - (let ((map (butlast (copy-keymap tool-bar-map))) - (help (last tool-bar-map))) ;; Keep Help last in tool bar + (when (keymapp tool-bar-map) + (let ((map (copy-keymap tool-bar-map))) + (define-key map [undo] nil) + (define-key map [separator-2] nil) + (define-key-after map [separator-compile] menu-bar-separator) (tool-bar-local-item "left-arrow" 'previous-error-no-select 'previous-error-no-select map :rtl "right-arrow" @@ -1588,7 +1590,7 @@ (tool-bar-local-item "refresh" 'recompile 'recompile map :help "Restart compilation") - (append map help)))) + map))) (put 'compilation-mode 'mode-class 'special)
--- a/lisp/progmodes/idlw-help.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/progmodes/idlw-help.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,7 +1,7 @@ ;;; idlw-help.el --- HTML Help code for IDLWAVE ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, -;; 2009, 2010 Free Software Foundation, Inc. +;; 2009, 2010, 2011 Free Software Foundation, Inc. ;; ;; Authors: J.D. Smith <jdsmith@as.arizona.edu> ;; Carsten Dominik <dominik@science.uva.nl> @@ -195,8 +195,7 @@ :type 'string) (defface idlwave-help-link - '((((class color)) (:foreground "Blue")) - (t (:weight bold))) + '((t :inherit link)) "Face for highlighting links into IDLWAVE online help." :group 'idlwave-online-help)
--- a/lisp/progmodes/prolog.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/progmodes/prolog.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,10 +1,15 @@ -;;; prolog.el --- major mode for editing and running Prolog under Emacs - -;; Copyright (C) 1986, 1987, 2001, 2002, 2003, 2004, 2005, 2006, 2007, -;; 2008, 2009, 2010 Free Software Foundation, Inc. - -;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> -;; Keywords: languages +;;; prolog.el --- major mode for editing and running Prolog (and Mercury) code + +;; Copyright (C) 1986, 1987, 1997, 1998, 1999, 2002, 2003, 2011 Free Software Foundation, Inc. + +;; Authors: Emil Åström <emil_astrom(at)hotmail(dot)com> +;; Milan Zamazal <pdm(at)freesoft(dot)cz> +;; Stefan Bruda <stefan(at)bruda(dot)ca> (current maintainer) +;; * See below for more details +;; Keywords: prolog major mode sicstus swi mercury + +(defvar prolog-mode-version "1.22" + "Prolog mode version number.") ;; This file is part of GNU Emacs. @@ -21,409 +26,4020 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. +;; Original author: Masanobu UMEDA <umerin(at)mse(dot)kyutech(dot)ac(dot)jp> +;; Parts of this file was taken from a modified version of the original +;; by Johan Andersson, Peter Olin, Mats Carlsson, Johan Bevemyr, Stefan +;; Andersson, and Per Danielsson (all SICS people), and Henrik Båkman +;; at Uppsala University, Sweden. +;; +;; Some ideas and also a few lines of code have been borrowed (not stolen ;-) +;; from Oz.el, the Emacs major mode for the Oz programming language, +;; Copyright (C) 1993 DFKI GmbH, Germany, with permission. +;; Authors: Ralf Scheidhauer and Michael Mehl ([scheidhr|mehl](at)dfki(dot)uni-sb(dot)de) +;; +;; More ideas and code have been taken from the SICStus debugger mode +;; (http://www.csd.uu.se/~perm/source_debug/index.shtml -- broken link +;; as of Mon May 5 08:23:48 EDT 2003) by Per Mildner. +;; +;; Additions for ECLiPSe and other helpful suggestions: Stephan Heuel +;; <heuel(at)ipb(dot)uni-bonn(dot)de> + ;;; Commentary: - -;; This package provides a major mode for editing Prolog. It knows -;; about Prolog syntax and comments, and can send regions to an inferior -;; Prolog interpreter process. Font locking is tuned towards GNU Prolog. - +;; +;; This package provides a major mode for editing Prolog code, with +;; all the bells and whistles one would expect, including syntax +;; highlighting and auto indentation. It can also send regions to an +;; inferior Prolog process. +;; +;; The code requires the comint, easymenu, info, imenu, and font-lock +;; libraries. These are normally distributed with GNU Emacs and +;; XEmacs. + +;;; Installation: +;; +;; Insert the following lines in your init file--typically ~/.emacs +;; (GNU Emacs and XEmacs <21.4), or ~/.xemacs/init.el (XEmacs +;; 21.4)--to use this mode when editing Prolog files under Emacs: +;; +;; (setq load-path (cons "/usr/lib/xemacs/site-lisp" load-path)) +;; (autoload 'run-prolog "prolog" "Start a Prolog sub-process." t) +;; (autoload 'prolog-mode "prolog" "Major mode for editing Prolog programs." t) +;; (autoload 'mercury-mode "prolog" "Major mode for editing Mercury programs." t) +;; (setq prolog-system 'swi) ; optional, the system you are using; +;; ; see `prolog-system' below for possible values +;; (setq auto-mode-alist (append '(("\\.pl$" . prolog-mode) +;; ("\\.m$" . mercury-mode)) +;; auto-mode-alist)) +;; +;; where the path in the first line is the file system path to this file. +;; MSDOS paths can be written like "d:/programs/emacs-19.34/site-lisp". +;; Note: In XEmacs, either `/usr/lib/xemacs/site-lisp' (RPM default in +;; Red Hat-based distributions) or `/usr/local/lib/xemacs/site-lisp' +;; (default when compiling from sources) are automatically added to +;; `load-path', so the first line is not necessary provided that you +;; put this file in the appropriate place. +;; +;; The last s-expression above makes sure that files ending with .pl +;; are assumed to be Prolog files and not Perl, which is the default +;; Emacs setting. If this is not wanted, remove this line. It is then +;; necessary to either +;; +;; o insert in your Prolog files the following comment as the first line: +;; +;; % -*- Mode: Prolog -*- +;; +;; and then the file will be open in Prolog mode no matter its +;; extension, or +;; +;; o manually switch to prolog mode after opening a Prolog file, by typing +;; M-x prolog-mode. +;; +;; If the command to start the prolog process ('sicstus', 'pl' or +;; 'swipl' for SWI prolog, etc.) is not available in the default path, +;; then it is necessary to set the value of the environment variable +;; EPROLOG to a shell command to invoke the prolog process. In XEmacs +;; and Emacs 20+ you can also customize the variable +;; `prolog-program-name' (in the group `prolog-inferior') and provide +;; a full path for your Prolog system (swi, scitus, etc.). +;; +;; Note: I (Stefan, the current maintainer) work under XEmacs. Future +;; developments will thus be biased towards XEmacs (OK, I admit it, +;; I am biased towards XEmacs in general), though I will do my best +;; to keep the GNU Emacs compatibility. So if you work under Emacs +;; and see something that does not work do drop me a line, as I have +;; a smaller chance to notice this kind of bugs otherwise. + +;; Changelog: + +;; Version 1.22: +;; o Allowed both 'swipl' and 'pl' as names for the SWI Prolog +;; interpreter. +;; o Atoms that start a line are not blindly coloured as +;; predicates. Instead we check that they are followed by ( or +;; :- first. Patch suggested by Guy Wiener. +;; Version 1.21: +;; o Cleaned up the code that defines faces. The missing face +;; warnings on some Emacsen should disappear. +;; Version 1.20: +;; o Improved the handling of clause start detection and multi-line +;; comments: `prolog-clause-start' no longer finds non-predicate +;; (e.g., capitalized strings) beginning of clauses. +;; `prolog-tokenize' recognizes when the end point is within a +;; multi-line comment. +;; Version 1.19: +;; o Minimal changes for Aquamacs inclusion and in general for +;; better coping with finding the Prolog executable. Patch +;; provided by David Reitter +;; Version 1.18: +;; o Fixed syntax highlighting for clause heads that do not begin at +;; the beginning of the line. +;; o Fixed compilation warnings under Emacs. +;; o Updated the email address of the current maintainer. +;; Version 1.17: +;; o Minor indentation fix (patch by Markus Triska) +;; o `prolog-underscore-wordchar-flag' defaults now to nil (more +;; consistent to other Emacs modes) +;; Version 1.16: +;; o Eliminated a possible compilation warning. +;; Version 1.15: +;; o Introduced three new customizable variables: electric colon +;; (`prolog-electric-colon-flag', default nil), electric dash +;; (`prolog-electric-dash-flag', default nil), and a possibility +;; to prevent the predicate template insertion from adding commata +;; (`prolog-electric-dot-full-predicate-template', defaults to t +;; since it seems quicker to me to just type those commata). A +;; trivial adaptation of a patch by Markus Triska. +;; o Improved the behaviour of electric if-then-else to only skip +;; forward if the parenthesis/semicolon is preceded by +;; whitespace. Once more a trivial adaptation of a patch by +;; Markus Triska. +;; Version 1.14: +;; o Cleaned up align code. `prolog-align-flag' is eliminated (since +;; on a second thought it does not do anything useful). Added key +;; binding (C-c C-a) and menu entry for alignment. +;; o Condensed regular expressions for lower and upper case +;; characters (GNU Emacs seems to go over the regexp length limit +;; with the original form). My code on the matter was improved +;; considerably by Markus Triska. +;; o Fixed `prolog-insert-spaces-after-paren' (which used an +;; unitialized variable). +;; o Minor changes to clean up the code and avoid some implicit +;; package requirements. +;; Version 1.13: +;; o Removed the use of `map-char-table' in `prolog-build-case-strings' +;; which appears to cause prblems in (at least) Emacs 23.0.0.1. +;; o Added if-then-else indentation + corresponding electric +;; characters. New customization: `prolog-electric-if-then-else-flag' +;; o Align support (requires `align'). New customization: +;; `prolog-align-flag'. +;; o Temporary consult files have now the same name throughout the +;; session. This prevents issues with reconsulting a buffer +;; (this event is no longer passed to Prolog as a request to +;; consult a new file). +;; o Adaptive fill mode is now turned on. Comment indentation is +;; still worse than it could be though, I am working on it. +;; o Improved filling and auto-filling capabilities. Now block +;; comments should be [auto-]filled correctly most of the time; +;; the following pattern in particular is worth noting as being +;; filled correctly: +;; <some code here> % some comment here that goes beyond the +;; % rightmost column, possibly combined with +;; % subsequent comment lines +;; o `prolog-char-quote-workaround' now defaults to nil. +;; o Note: Many of the above improvements have been suggested by +;; Markus Triska, who also provided useful patches on the matter +;; when he realized that I was slow in responding. Many thanks. +;; Version 1.11 / 1.12 +;; o GNU Emacs compatibility fix for paragraph filling (fixed +;; incorrectly in 1.11, fix fixed in 1.12). +;; Version 1.10 +;; o Added paragraph filling in comment blocks and also correct auto +;; filling for comments. +;; o Fixed the possible "Regular expression too big" error in +;; `prolog-electric-dot'. +;; Version 1.9 +;; o Parenthesis expressions are now indented by default so that +;; components go one underneath the other, just as for compound +;; terms. You can use the old style (the second and subsequent +;; lines being indented to the right in a parenthesis expression) +;; by setting the customizable variable `prolog-paren-indent-p' +;; (group "Prolog Indentation") to t. +;; o (Somehow awkward) handling of the 0' character escape +;; sequence. I am looking into a better way of doing it but +;; prospects look bleak. If this breaks things for you please let +;; me know and also set the `prolog-char-quote-workaround' (group +;; "Prolog Other") to nil. +;; Version 1.8 +;; o Key binding fix. +;; Version 1.7 +;; o Fixed a number of issues with the syntax of single quotes, +;; including Debian bug #324520. +;; Version 1.6 +;; o Fixed mercury mode menu initialization (Debian bug #226121). +;; o Fixed (i.e., eliminated) Delete remapping (Debian bug #229636). +;; o Corrected indentation for clauses defining quoted atoms. +;; Version 1.5: +;; o Keywords fontifying should work in console mode so this is +;; enabled everywhere. +;; Version 1.4: +;; o Now supports GNU Prolog--minor adaptation of a patch by Stefan +;; Moeding. +;; Version 1.3: +;; o Info-follow-nearest-node now called correctly under Emacs too +;; (thanks to Nicolas Pelletier). Should be implemented more +;; elegantly (i.e., without compilation warnings) in the future. +;; Version 1.2: +;; o Another prompt fix, still in SWI mode (people seem to have +;; changed the prompt of SWI Prolog). +;; Version 1.1: +;; o Fixed dots in the end of line comments causing indentation +;; problems. The following code is now correctly indented (note +;; the dot terminating the comment): +;; a(X) :- b(X), +;; c(X). % comment here. +;; a(X). +;; and so is this (and variants): +;; a(X) :- b(X), +;; c(X). /* comment here. */ +;; a(X). +;; Version 1.0: +;; o Revamped the menu system. +;; o Yet another prompt recognition fix (SWI mode). +;; o This is more of a renumbering than a new edition. I promoted +;; the mode to version 1.0 to emphasize the fact that it is now +;; mature and stable enough to be considered production (in my +;; opinion anyway). +;; Version 0.1.41: +;; o GNU Emacs compatibility fixes. +;; Version 0.1.40: +;; o prolog-get-predspec is now suitable to be called as +;; imenu-extract-index-name-function. The predicate index works. +;; o Since imenu works now as advertised, prolog-imenu-flag is t +;; by default. +;; o Eliminated prolog-create-predicate-index since the imenu +;; utilities now work well. Actually, this function is also +;; buggy, and I see no reason to fix it since we do not need it +;; anyway. +;; o Fixed prolog-pred-start, prolog-clause-start, prolog-clause-info. +;; o Fix for prolog-build-case-strings; now prolog-upper-case-string +;; and prolog-lower-case-string are correctly initialized, +;; o Various font-lock changes; most importantly, block comments (/* +;; ... */) are now correctly fontified in XEmacs even when they +;; extend on multiple lines. +;; Version 0.1.36: +;; o The debug prompt of SWI Prolog is now correctly recognized. +;; Version 0.1.35: +;; o Minor font-lock bug fixes. + + ;;; Code: -(defvar comint-prompt-regexp) -(defvar comint-process-echoes) -(require 'smie) +(eval-when-compile + (require 'compile) + (require 'font-lock) + ;; We need imenu everywhere because of the predicate index! + (require 'imenu) + ;) + (require 'info) + (require 'shell) + ) + +(require 'comint) +(require 'easymenu) +(require 'align) + (defgroup prolog nil - "Major mode for editing and running Prolog under Emacs." - :link '(custom-group-link :tag "Font Lock Faces group" font-lock-faces) + "Major modes for editing and running Prolog and Mercury files." :group 'languages) +(defgroup prolog-faces nil + "Prolog mode specific faces." + :group 'font-lock) + +(defgroup prolog-indentation nil + "Prolog mode indentation configuration." + :group 'prolog) + +(defgroup prolog-font-lock nil + "Prolog mode font locking patterns." + :group 'prolog) + +(defgroup prolog-keyboard nil + "Prolog mode keyboard flags." + :group 'prolog) + +(defgroup prolog-inferior nil + "Inferior Prolog mode options." + :group 'prolog) + +(defgroup prolog-other nil + "Other Prolog mode options." + :group 'prolog) + + +;;------------------------------------------------------------------- +;; User configurable variables +;;------------------------------------------------------------------- + +;; General configuration + +(defcustom prolog-system nil + "*Prolog interpreter/compiler used. +The value of this variable is nil or a symbol. +If it is a symbol, it determines default values of other configuration +variables with respect to properties of the specified Prolog +interpreter/compiler. + +Currently recognized symbol values are: +eclipse - Eclipse Prolog +mercury - Mercury +sicstus - SICStus Prolog +swi - SWI Prolog +gnu - GNU Prolog" + :group 'prolog + :type '(choice (const :tag "SICStus" :value sicstus) + (const :tag "SWI Prolog" :value swi) + (const :tag "Default" :value nil))) +(make-variable-buffer-local 'prolog-system) + +;; NB: This alist can not be processed in prolog-mode-variables to +;; create a prolog-system-version-i variable since it is needed +;; prior to the call to prolog-mode-variables. +(defcustom prolog-system-version + '((sicstus (3 . 6)) + (swi (0 . 0)) + (mercury (0 . 0)) + (eclipse (3 . 7)) + (gnu (0 . 0))) + "*Alist of Prolog system versions. +The version numbers are of the format (Major . Minor)." + :group 'prolog) + +;; Indentation + +(defcustom prolog-indent-width 4 + "*The indentation width used by the editing buffer." + :group 'prolog-indentation + :type 'integer) + +(defcustom prolog-align-comments-flag t + "*Non-nil means automatically align comments when indenting." + :group 'prolog-indentation + :type 'boolean) + +(defcustom prolog-indent-mline-comments-flag t + "*Non-nil means indent contents of /* */ comments. +Otherwise leave such lines as they are." + :group 'prolog-indentation + :type 'boolean) + +(defcustom prolog-object-end-to-0-flag t + "*Non-nil means indent closing '}' in SICStus object definitions to level 0. +Otherwise indent to `prolog-indent-width'." + :group 'prolog-indentation + :type 'boolean) + +(defcustom prolog-left-indent-regexp "\\(;\\|\\*?->\\)" + "*Regexp for character sequences after which next line is indented. +Next line after such a regexp is indented to the opening paranthesis level." + :group 'prolog-indentation + :type 'regexp) + +(defcustom prolog-paren-indent-p nil + "*If non-nil, increase indentation for parenthesis expressions. +The second and subsequent line in a parenthesis expression other than +a compound term can either be indented `prolog-paren-indent' to the +right (if this variable is non-nil) or in the same way as for compound +terms (if this variable is nil, default)." + :group 'prolog-indentation + :type 'boolean) + +(defcustom prolog-paren-indent 4 + "*The indentation increase for parenthesis expressions. +Only used in ( If -> Then ; Else) and ( Disj1 ; Disj2 ) style expressions." + :group 'prolog-indentation + :type 'integer) + +(defcustom prolog-parse-mode 'beg-of-clause + "*The parse mode used (decides from which point parsing is done). +Legal values: +'beg-of-line - starts parsing at the beginning of a line, unless the + previous line ends with a backslash. Fast, but has + problems detecting multiline /* */ comments. +'beg-of-clause - starts parsing at the beginning of the current clause. + Slow, but copes better with /* */ comments." + :group 'prolog-indentation + :type '(choice (const :value beg-of-line) + (const :value beg-of-clause))) + +;; Font locking + +(defcustom prolog-keywords + '((eclipse + ("use_module" "begin_module" "module_interface" "dynamic" + "external" "export" "dbgcomp" "nodbgcomp" "compile")) + (mercury + ("all" "else" "end_module" "equality" "external" "fail" "func" "if" + "implementation" "import_module" "include_module" "inst" "instance" + "interface" "mode" "module" "not" "pragma" "pred" "some" "then" "true" + "type" "typeclass" "use_module" "where")) + (sicstus + ("block" "dynamic" "mode" "module" "multifile" "meta_predicate" + "parallel" "public" "sequential" "volatile")) + (swi + ("discontiguous" "dynamic" "ensure_loaded" "export" "export_list" "import" + "meta_predicate" "module" "module_transparent" "multifile" "require" + "use_module" "volatile")) + (gnu + ("built_in" "char_conversion" "discontiguous" "dynamic" "ensure_linked" + "ensure_loaded" "foreign" "include" "initialization" "multifile" "op" + "public" "set_prolog_flag")) + (t + ("dynamic" "module"))) + "*Alist of Prolog keywords which is used for font locking of directives." + :group 'prolog-font-lock + :type 'sexp) + +(defcustom prolog-types + '((mercury + ("char" "float" "int" "io__state" "string" "univ")) + (t nil)) + "*Alist of Prolog types used by font locking." + :group 'prolog-font-lock + :type 'sexp) + +(defcustom prolog-mode-specificators + '((mercury + ("bound" "di" "free" "ground" "in" "mdi" "mui" "muo" "out" "ui" "uo")) + (t nil)) + "*Alist of Prolog mode specificators used by font locking." + :group 'prolog-font-lock + :type 'sexp) + +(defcustom prolog-determinism-specificators + '((mercury + ("cc_multi" "cc_nondet" "det" "erroneous" "failure" "multi" "nondet" + "semidet")) + (t nil)) + "*Alist of Prolog determinism specificators used by font locking." + :group 'prolog-font-lock + :type 'sexp) + +(defcustom prolog-directives + '((mercury + ("^#[0-9]+")) + (t nil)) + "*Alist of Prolog source code directives used by font locking." + :group 'prolog-font-lock + :type 'sexp) + + +;; Keyboard + +(defcustom prolog-electric-newline-flag (not (fboundp 'electric-indent-mode)) + "*Non-nil means automatically indent the next line when the user types RET." + :group 'prolog-keyboard + :type 'boolean) + +(defcustom prolog-hungry-delete-key-flag nil + "*Non-nil means delete key consumes all preceding spaces." + :group 'prolog-keyboard + :type 'boolean) + +(defcustom prolog-electric-dot-flag nil + "*Non-nil means make dot key electric. +Electric dot appends newline or inserts head of a new clause. +If dot is pressed at the end of a line where at least one white space +precedes the point, it inserts a recursive call to the current predicate. +If dot is pressed at the beginning of an empty line, it inserts the head +of a new clause for the current predicate. It does not apply in strings +and comments. +It does not apply in strings and comments." + :group 'prolog-keyboard + :type 'boolean) + +(defcustom prolog-electric-dot-full-predicate-template nil + "*If nil, electric dot inserts only the current predicate's name and `(' +for recursive calls or new clause heads. Non-nil means to also +insert enough commata to cover the predicate's arity and `)', +and dot and newline for recursive calls." + :group 'prolog-keyboard + :type 'boolean) + +(defcustom prolog-electric-underscore-flag nil + "*Non-nil means make underscore key electric. +Electric underscore replaces the current variable with underscore. +If underscore is pressed not on a variable then it behaves as usual." + :group 'prolog-keyboard + :type 'boolean) + +(defcustom prolog-electric-tab-flag nil + "*Non-nil means make TAB key electric. +Electric TAB inserts spaces after parentheses, ->, and ; +in ( If -> Then ; Else) and ( Disj1 ; Disj2 ) style expressions." + :group 'prolog-keyboard + :type 'boolean) + +(defcustom prolog-electric-if-then-else-flag nil + "*Non-nil makes `(', `>' and `;' electric +to automatically indent if-then-else constructs." + :group 'prolog-keyboard + :type 'boolean) + +(defcustom prolog-electric-colon-flag nil + "*Makes `:' electric (inserts `:-' on a new line). +If non-nil, pressing `:' at the end of a line that starts in +the first column (i.e., clause heads) inserts ` :-' and newline." + :group 'prolog-keyboard + :type 'boolean) + +(defcustom prolog-electric-dash-flag nil + "*Makes `-' electric (inserts a `-->' on a new line). +If non-nil, pressing `-' at the end of a line that starts in +the first column (i.e., DCG heads) inserts ` -->' and newline." + :group 'prolog-keyboard + :type 'boolean) + +(defcustom prolog-old-sicstus-keys-flag nil + "*Non-nil means old SICStus Prolog mode keybindings are used." + :group 'prolog-keyboard + :type 'boolean) + +;; Inferior mode (defcustom prolog-program-name - (let ((names '("prolog" "gprolog" "swipl"))) - (while (and names - (not (executable-find (car names)))) - (setq names (cdr names))) - (or (car names) "prolog")) - "Program name for invoking an inferior Prolog with `run-prolog'." - :type 'string - :group 'prolog) - -(defcustom prolog-consult-string "reconsult(user).\n" - "(Re)Consult mode (for C-Prolog and Quintus Prolog). " - :type 'string - :group 'prolog) - -(defcustom prolog-compile-string "compile(user).\n" - "Compile mode (for Quintus Prolog)." - :type 'string - :group 'prolog) + `(((getenv "EPROLOG") (eval (getenv "EPROLOG"))) + (eclipse "eclipse") + (mercury nil) + (sicstus "sicstus") + (swi ,(if (not (executable-find "swipl")) "pl" "swipl")) + (gnu "gprolog") + (t ,(let ((names '("prolog" "gprolog" "swipl" "pl"))) + (while (and names + (not (executable-find (car names)))) + (setq names (cdr names))) + (or (car names) "prolog")))) + "*Alist of program names for invoking an inferior Prolog with `run-prolog'." + :group 'prolog-inferior + :type 'sexp) + +(defcustom prolog-program-switches + '((sicstus ("-i")) + (t nil)) + "*Alist of switches given to inferior Prolog run with `run-prolog'." + :group 'prolog-inferior + :type 'sexp) + +(defcustom prolog-consult-string + '((eclipse "[%f].") + (mercury nil) + (sicstus (eval (if (prolog-atleast-version '(3 . 7)) + "prolog:zap_file(%m,%b,consult,%l)." + "prolog:zap_file(%m,%b,consult)."))) + (swi "[%f].") + (gnu "[%f].") + (t "reconsult(%f).")) + "*Alist of strings defining predicate for reconsulting. + +Some parts of the string are replaced: +`%f' by the name of the consulted file (can be a temporary file) +`%b' by the file name of the buffer to consult +`%m' by the module name and name of the consulted file separated by colon +`%l' by the line offset into the file. This is 0 unless consulting a + region of a buffer, in which case it is the number of lines before + the region." + :group 'prolog-inferior + :type 'sexp) + +(defcustom prolog-compile-string + '((eclipse "[%f].") + (mercury "mmake ") + (sicstus (eval (if (prolog-atleast-version '(3 . 7)) + "prolog:zap_file(%m,%b,compile,%l)." + "prolog:zap_file(%m,%b,compile)."))) + (swi "[%f].") + (t "compile(%f).")) + "*Alist of strings and lists defining predicate for recompilation. + +Some parts of the string are replaced: +`%f' by the name of the compiled file (can be a temporary file) +`%b' by the file name of the buffer to compile +`%m' by the module name and name of the compiled file separated by colon +`%l' by the line offset into the file. This is 0 unless compiling a + region of a buffer, in which case it is the number of lines before + the region. + +If `prolog-program-name' is non-nil, it is a string sent to a Prolog process. +If `prolog-program-name' is nil, it is an argument to the `compile' function." + :group 'prolog-inferior + :type 'sexp) (defcustom prolog-eof-string "end_of_file.\n" - "String that represents end of file for Prolog. -When nil, send actual operating system end of file." - :type 'string - :group 'prolog) - -(defcustom prolog-indent-width 4 - "Level of indentation in Prolog buffers." - :type 'integer - :group 'prolog) - -(defvar prolog-font-lock-keywords - '(("\\(#[<=]=>\\|:-\\)\\|\\(#=\\)\\|\\(#[#<>\\/][=\\/]*\\|!\\)" - 0 font-lock-keyword-face) - ("\\<\\(is\\|write\\|nl\\|read_\\sw+\\)\\>" - 1 font-lock-keyword-face) - ("^\\(\\sw+\\)\\s-*\\((\\(.+\\))\\)*" - (1 font-lock-function-name-face) - (3 font-lock-variable-name-face))) - "Font-lock keywords for Prolog mode.") + "*Alist of strings that represent end of file for prolog. +nil means send actual operating system end of file." + :group 'prolog-inferior + :type 'sexp) + +(defcustom prolog-prompt-regexp + '((eclipse "^[a-zA-Z0-9()]* *\\?- \\|^\\[[a-zA-Z]* [0-9]*\\]:") + (sicstus "| [ ?][- ] *") + (swi "^\\(\\[[a-zA-Z]*\\] \\)?[1-9]?[0-9]*[ ]?\\?- \\|^| +") + (t "^ *\\?-")) + "*Alist of prompts of the prolog system command line." + :group 'prolog-inferior + :type 'sexp) + +(defcustom prolog-continued-prompt-regexp + '((sicstus "^\\(| +\\| +\\)") + (t "^|: +")) + "*Alist of regexps matching the prompt when consulting `user'." + :group 'prolog-inferior + :type 'sexp) + +(defcustom prolog-debug-on-string "debug.\n" + "*Predicate for enabling debug mode." + :group 'prolog-inferior + :type 'string) + +(defcustom prolog-debug-off-string "nodebug.\n" + "*Predicate for disabling debug mode." + :group 'prolog-inferior + :type 'string) + +(defcustom prolog-trace-on-string "trace.\n" + "*Predicate for enabling tracing." + :group 'prolog-inferior + :type 'string) + +(defcustom prolog-trace-off-string "notrace.\n" + "*Predicate for disabling tracing." + :group 'prolog-inferior + :type 'string) + +(defcustom prolog-zip-on-string "zip.\n" + "*Predicate for enabling zip mode for SICStus." + :group 'prolog-inferior + :type 'string) + +(defcustom prolog-zip-off-string "nozip.\n" + "*Predicate for disabling zip mode for SICStus." + :group 'prolog-inferior + :type 'string) + +(defcustom prolog-use-standard-consult-compile-method-flag t + "*Non-nil means use the standard compilation method. +Otherwise the new compilation method will be used. This +utilises a special compilation buffer with the associated +features such as parsing of error messages and automatically +jumping to the source code responsible for the error. + +Warning: the new method is so far only experimental and +does contain bugs. The recommended setting for the novice user +is non-nil for this variable." + :group 'prolog-inferior + :type 'boolean) + + +;; Miscellaneous + +(defcustom prolog-use-prolog-tokenizer-flag t + "*Non-nil means use the internal prolog tokenizer for indentation etc. +Otherwise use `parse-partial-sexp' which is faster but sometimes incorrect." + :group 'prolog-other + :type 'boolean) + +(defcustom prolog-imenu-flag t + "*Non-nil means add a clause index menu for all prolog files." + :group 'prolog-other + :type 'boolean) + +(defcustom prolog-imenu-max-lines 3000 + "*The maximum number of lines of the file for imenu to be enabled. +Relevant only when `prolog-imenu-flag' is non-nil." + :group 'prolog-other + :type 'integer) + +(defcustom prolog-info-predicate-index + "(sicstus)Predicate Index" + "*The info node for the SICStus predicate index." + :group 'prolog-other + :type 'string) + +(defcustom prolog-underscore-wordchar-flag nil + "*Non-nil means underscore (_) is a word-constituent character." + :group 'prolog-other + :type 'boolean) + +(defcustom prolog-use-sicstus-sd nil + "*If non-nil, use the source level debugger of SICStus 3#7 and later." + :group 'prolog-other + :type 'boolean) + +(defcustom prolog-char-quote-workaround nil + ;; FIXME: Use syntax-propertize-function to fix it right. + "*If non-nil, declare 0 as a quote character so that 0'<char> does not break syntax highlighting. +This is really kludgy but I have not found any better way of handling it." + :group 'prolog-other + :type 'boolean) + + +;;------------------------------------------------------------------- +;; Internal variables +;;------------------------------------------------------------------- + +;;(defvar prolog-temp-filename "") ; Later set by `prolog-temporary-file' (defvar prolog-mode-syntax-table (let ((table (make-syntax-table))) - (modify-syntax-entry ?_ "w" table) - (modify-syntax-entry ?\\ "\\" table) - (modify-syntax-entry ?/ ". 14" table) - (modify-syntax-entry ?* ". 23" table) + (if prolog-underscore-wordchar-flag + (modify-syntax-entry ?_ "w" table) + (modify-syntax-entry ?_ "_" table)) + (modify-syntax-entry ?+ "." table) (modify-syntax-entry ?- "." table) (modify-syntax-entry ?= "." table) - (modify-syntax-entry ?% "<" table) - (modify-syntax-entry ?\n ">" table) (modify-syntax-entry ?< "." table) (modify-syntax-entry ?> "." table) + (modify-syntax-entry ?| "." table) (modify-syntax-entry ?\' "\"" table) + + ;; Any better way to handle the 0'<char> construct?!? + (when prolog-char-quote-workaround + (modify-syntax-entry ?0 "\\" table)) + + (modify-syntax-entry ?% "<" table) + (modify-syntax-entry ?\n ">" table) + (if (featurep 'xemacs) + (progn + (modify-syntax-entry ?* ". 67" table) + (modify-syntax-entry ?/ ". 58" table) + ) + ;; Emacs wants to see this it seems: + (modify-syntax-entry ?* ". 23b" table) + (modify-syntax-entry ?/ ". 14" table) + ) table)) - (defvar prolog-mode-abbrev-table nil) +(defvar prolog-upper-case-string "" + "A string containing all upper case characters. +Set by prolog-build-case-strings.") +(defvar prolog-lower-case-string "" + "A string containing all lower case characters. +Set by prolog-build-case-strings.") + +(defvar prolog-atom-char-regexp "" + "Set by prolog-set-atom-regexps.") +;; "Regexp specifying characters which constitute atoms without quoting.") +(defvar prolog-atom-regexp "" + "Set by prolog-set-atom-regexps.") + +(defconst prolog-left-paren "[[({]" + "The characters used as left parentheses for the indentation code.") +(defconst prolog-right-paren "[])}]" + "The characters used as right parentheses for the indentation code.") + +(defconst prolog-quoted-atom-regexp + "\\(^\\|[^0-9]\\)\\('\\([^\n']\\|\\\\'\\)*'\\)" + "Regexp matching a quoted atom.") +(defconst prolog-string-regexp + "\\(\"\\([^\n\"]\\|\\\\\"\\)*\"\\)" + "Regexp matching a string.") +(defconst prolog-head-delimiter "\\(:-\\|\\+:\\|-:\\|\\+\\?\\|-\\?\\|-->\\)" + "A regexp for matching on the end delimiter of a head (e.g. \":-\").") + +(defvar prolog-compilation-buffer "*prolog-compilation*" + "Name of the output buffer for Prolog compilation/consulting.") + +(defvar prolog-temporary-file-name nil) +(defvar prolog-keywords-i nil) +(defvar prolog-types-i nil) +(defvar prolog-mode-specificators-i nil) +(defvar prolog-determinism-specificators-i nil) +(defvar prolog-directives-i nil) +(defvar prolog-program-name-i nil) +(defvar prolog-program-switches-i nil) +(defvar prolog-consult-string-i nil) +(defvar prolog-compile-string-i nil) +(defvar prolog-eof-string-i nil) +(defvar prolog-prompt-regexp-i nil) +(defvar prolog-continued-prompt-regexp-i nil) +(defvar prolog-help-function-i nil) + +(defvar prolog-align-rules + (eval-when-compile + (mapcar + (lambda (x) + (let ((name (car x)) + (sym (cdr x))) + `(,(intern (format "prolog-%s" name)) + (regexp . ,(format "\\(\\s-*\\)%s\\(\\s-*\\)" sym)) + (tab-stop . nil) + (modes . '(prolog-mode)) + (group . (1 2))))) + '(("dcg" . "-->") ("rule" . ":-") ("simplification" . "<=>") + ("propagation" . "==>"))))) + + + +;;------------------------------------------------------------------- +;; Prolog mode +;;------------------------------------------------------------------- + +;; Example: (prolog-atleast-version '(3 . 6)) +(defun prolog-atleast-version (version) + "Return t if the version of the current prolog system is VERSION or later. +VERSION is of the format (Major . Minor)" + ;; Version.major < major or + ;; Version.major = major and Version.minor <= minor + (let* ((thisversion (prolog-find-value-by-system prolog-system-version)) + (thismajor (car thisversion)) + (thisminor (cdr thisversion))) + (or (< (car version) thismajor) + (and (= (car version) thismajor) + (<= (cdr version) thisminor))) + )) + (define-abbrev-table 'prolog-mode-abbrev-table ()) -(defun prolog-smie-forward-token () - (forward-comment (point-max)) - (buffer-substring-no-properties - (point) - (progn (cond - ((looking-at "[!;]") (forward-char 1)) - ((not (zerop (skip-chars-forward "#&*+-./:<=>?@\\^`~")))) - ((not (zerop (skip-syntax-forward "w_'")))) - ;; In case of non-ASCII punctuation. - ((not (zerop (skip-syntax-forward "."))))) - (point)))) - -(defun prolog-smie-backward-token () - (forward-comment (- (point-max))) - (buffer-substring-no-properties - (point) - (progn (cond - ((memq (char-before) '(?! ?\;)) (forward-char -1)) - ((not (zerop (skip-chars-backward "#&*+-./:<=>?@\\^`~")))) - ((not (zerop (skip-syntax-backward "w_'")))) - ;; In case of non-ASCII punctuation. - ((not (zerop (skip-syntax-backward "."))))) - (point)))) - -(defconst prolog-smie-grammar - ;; Rather than construct the operator levels table from the BNF, - ;; we directly provide the operator precedences from GNU Prolog's - ;; manual (7.14.10 op/3). The only problem is that GNU Prolog's - ;; manual uses precedence levels in the opposite sense (higher - ;; numbers bind less tightly) than SMIE, so we use negative numbers. - '(("." -10000 -10000) - (":-" -1200 -1200) - ("-->" -1200 -1200) - (";" -1100 -1100) - ("->" -1050 -1050) - ("," -1000 -1000) - ("\\+" -900 -900) - ("=" -700 -700) - ("\\=" -700 -700) - ("=.." -700 -700) - ("==" -700 -700) - ("\\==" -700 -700) - ("@<" -700 -700) - ("@=<" -700 -700) - ("@>" -700 -700) - ("@>=" -700 -700) - ("is" -700 -700) - ("=:=" -700 -700) - ("=\\=" -700 -700) - ("<" -700 -700) - ("=<" -700 -700) - (">" -700 -700) - (">=" -700 -700) - (":" -600 -600) - ("+" -500 -500) - ("-" -500 -500) - ("/\\" -500 -500) - ("\\/" -500 -500) - ("*" -400 -400) - ("/" -400 -400) - ("//" -400 -400) - ("rem" -400 -400) - ("mod" -400 -400) - ("<<" -400 -400) - (">>" -400 -400) - ("**" -200 -200) - ("^" -200 -200) - ;; Prefix - ;; ("+" 200 200) - ;; ("-" 200 200) - ;; ("\\" 200 200) - ) - "Precedence levels of infix operators.") - -(defun prolog-smie-rules (kind token) - (pcase (cons kind token) - (`(:elem . basic) prolog-indent-width) - (`(:after . ".") 0) ;; To work around smie-closer-alist. - (`(:after . ,(or `":-" `"->")) prolog-indent-width))) +(defun prolog-find-value-by-system (alist) + "Get value from ALIST according to `prolog-system'." + (if (listp alist) + (let (result + id) + (while alist + (setq id (car (car alist))) + (if (or (eq id prolog-system) + (eq id t) + (and (listp id) + (eval id))) + (progn + (setq result (car (cdr (car alist)))) + (if (and (listp result) + (eq (car result) 'eval)) + (setq result (eval (car (cdr result))))) + (setq alist nil)) + (setq alist (cdr alist)))) + result) + alist)) (defun prolog-mode-variables () - (set (make-local-variable 'paragraph-separate) (concat "%%\\|$\\|" page-delimiter)) ;'%%..' - (set (make-local-variable 'paragraph-ignore-fill-prefix) t) - (set (make-local-variable 'imenu-generic-expression) '((nil "^\\sw+" 0))) - - ;; Setup SMIE. - (smie-setup prolog-smie-grammar #'prolog-smie-rules - :forward-token #'prolog-smie-forward-token - :backward-token #'prolog-smie-backward-token) - (set (make-local-variable 'smie-blink-matching-triggers) '(?.)) - (set (make-local-variable 'smie-closer-alist) '((t . "."))) - (add-hook 'post-self-insert-hook #'smie-blink-matching-open 'append 'local) - ;; There's no real closer in Prolog anyway. - (set (make-local-variable 'smie-blink-matching-inners) t) - - (set (make-local-variable 'comment-start) "%") - (set (make-local-variable 'comment-start-skip) "\\(?:%+\\|/\\*+\\)[ \t]*") - (set (make-local-variable 'comment-end-skip) "[ \t]*\\(\n\\|\\*+/\\)") - (set (make-local-variable 'comment-column) 48)) + "Set some common variables to Prolog code specific values." + (setq local-abbrev-table prolog-mode-abbrev-table) + (make-local-variable 'paragraph-start) + (setq paragraph-start (concat "[ \t]*$\\|" page-delimiter)) ;'%%..' + (make-local-variable 'paragraph-separate) + (setq paragraph-separate paragraph-start) + (make-local-variable 'paragraph-ignore-fill-prefix) + (setq paragraph-ignore-fill-prefix t) + (make-local-variable 'normal-auto-fill-function) + (setq normal-auto-fill-function 'prolog-do-auto-fill) + (make-local-variable 'indent-line-function) + (setq indent-line-function 'prolog-indent-line) + (make-local-variable 'comment-start) + (setq comment-start "%") + (make-local-variable 'comment-end) + (setq comment-end "") + (make-local-variable 'comment-start-skip) + ;; This complex regexp makes sure that comments cannot start + ;; inside quoted atoms or strings + (setq comment-start-skip + (format "^\\(\\(%s\\|%s\\|[^\n\'\"%%]\\)*\\)\\(/\\*+ *\\|%%+ *\\)" + prolog-quoted-atom-regexp prolog-string-regexp)) + (make-local-variable 'comment-column) + (make-local-variable 'comment-indent-function) + (setq comment-indent-function 'prolog-comment-indent) + (make-local-variable 'parens-require-spaces) + (setq parens-require-spaces nil) + ;; Initialize Prolog system specific variables + (let ((vars '(prolog-keywords prolog-types prolog-mode-specificators + prolog-determinism-specificators prolog-directives + prolog-program-name prolog-program-switches + prolog-consult-string prolog-compile-string prolog-eof-string + prolog-prompt-regexp prolog-continued-prompt-regexp + prolog-help-function))) + (while vars + (set (intern (concat (symbol-name (car vars)) "-i")) + (prolog-find-value-by-system (symbol-value (car vars)))) + (setq vars (cdr vars)))) + (when (null prolog-program-name-i) + (make-local-variable 'compile-command) + (setq compile-command prolog-compile-string-i)) + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '(prolog-font-lock-keywords nil nil ((?_ . "w")))) +) + +(defun prolog-mode-keybindings-common (map) + "Define keybindings common to both Prolog modes in MAP." + (define-key map "\C-c?" 'prolog-help-on-predicate) + (define-key map "\C-c/" 'prolog-help-apropos) + (define-key map "\C-c\C-d" 'prolog-debug-on) + (define-key map "\C-c\C-t" 'prolog-trace-on) + (if (and (eq prolog-system 'sicstus) + (prolog-atleast-version '(3 . 7))) + (define-key map "\C-c\C-z" 'prolog-zip-on)) + (define-key map "\C-c\r" 'run-prolog)) + +(defun prolog-mode-keybindings-edit (map) + "Define keybindings for Prolog mode in MAP." + (define-key map "\M-a" 'prolog-beginning-of-clause) + (define-key map "\M-e" 'prolog-end-of-clause) + (define-key map "\M-q" 'prolog-fill-paragraph) + (define-key map "\C-c\C-a" 'align) + (define-key map "\C-\M-a" 'prolog-beginning-of-predicate) + (define-key map "\C-\M-e" 'prolog-end-of-predicate) + (define-key map "\M-\C-c" 'prolog-mark-clause) + (define-key map "\M-\C-h" 'prolog-mark-predicate) + (define-key map "\M-\C-n" 'prolog-forward-list) + (define-key map "\M-\C-p" 'prolog-backward-list) + (define-key map "\C-c\C-n" 'prolog-insert-predicate-template) + (define-key map "\C-c\C-s" 'prolog-insert-predspec) + (define-key map "\M-\r" 'prolog-insert-next-clause) + (define-key map "\C-c\C-va" 'prolog-variables-to-anonymous) + (define-key map "\C-c\C-v\C-s" 'prolog-view-predspec) + + (define-key map [Backspace] 'prolog-electric-delete) + (define-key map "." 'prolog-electric-dot) + (define-key map "_" 'prolog-electric-underscore) + (define-key map "(" 'prolog-electric-if-then-else) + (define-key map ";" 'prolog-electric-if-then-else) + (define-key map ">" 'prolog-electric-if-then-else) + (define-key map ":" 'prolog-electric-colon) + (define-key map "-" 'prolog-electric-dash) + (if prolog-electric-newline-flag + (define-key map "\r" 'newline-and-indent)) + + ;; If we're running SICStus, then map C-c C-c e/d to enabling + ;; and disabling of the source-level debugging facilities. + ;(if (and (eq prolog-system 'sicstus) + ; (prolog-atleast-version '(3 . 7))) + ; (progn + ; (define-key map "\C-c\C-ce" 'prolog-enable-sicstus-sd) + ; (define-key map "\C-c\C-cd" 'prolog-disable-sicstus-sd) + ; )) + + (if prolog-old-sicstus-keys-flag + (progn + (define-key map "\C-c\C-c" 'prolog-consult-predicate) + (define-key map "\C-cc" 'prolog-consult-region) + (define-key map "\C-cC" 'prolog-consult-buffer) + (define-key map "\C-c\C-k" 'prolog-compile-predicate) + (define-key map "\C-ck" 'prolog-compile-region) + (define-key map "\C-cK" 'prolog-compile-buffer)) + (define-key map "\C-c\C-p" 'prolog-consult-predicate) + (define-key map "\C-c\C-r" 'prolog-consult-region) + (define-key map "\C-c\C-b" 'prolog-consult-buffer) + (define-key map "\C-c\C-f" 'prolog-consult-file) + (define-key map "\C-c\C-cp" 'prolog-compile-predicate) + (define-key map "\C-c\C-cr" 'prolog-compile-region) + (define-key map "\C-c\C-cb" 'prolog-compile-buffer) + (define-key map "\C-c\C-cf" 'prolog-compile-file)) + + ;; Inherited from the old prolog.el. + (define-key map "\e\C-x" 'prolog-consult-region) + (define-key map "\C-c\C-l" 'prolog-consult-file) + (define-key map "\C-c\C-z" 'switch-to-prolog)) + +(defun prolog-mode-keybindings-inferior (map) + "Define keybindings for inferior Prolog mode in MAP." + ;; No inferior mode specific keybindings now. + ) (defvar prolog-mode-map (let ((map (make-sparse-keymap))) - (define-key map "\e\C-x" 'prolog-consult-region) - (define-key map "\C-c\C-l" 'inferior-prolog-load-file) - (define-key map "\C-c\C-z" 'switch-to-prolog) + (prolog-mode-keybindings-common map) + (prolog-mode-keybindings-edit map) map)) - -(easy-menu-define prolog-mode-menu prolog-mode-map "Menu for Prolog mode." - ;; Mostly copied from scheme-mode's menu. - ;; Not tremendously useful, but it's a start. - '("Prolog" - ["Indent line" indent-according-to-mode t] - ["Indent region" indent-region t] - ["Comment region" comment-region t] - ["Uncomment region" uncomment-region t] - "--" - ["Run interactive Prolog session" run-prolog t] - )) - + + +(defvar prolog-mode-hook nil + "List of functions to call after the prolog mode has initialised.") + +(unless (fboundp 'prog-mode) + (defalias 'prog-mode 'fundamental-mode)) ;;;###autoload (define-derived-mode prolog-mode prog-mode "Prolog" - "Major mode for editing Prolog code for Prologs. -Blank lines and `%%...' separate paragraphs. `%'s start comments. + "Major mode for editing Prolog code. + +Blank lines and `%%...' separate paragraphs. `%'s starts a comment +line and comments can also be enclosed in /* ... */. + +If an optional argument SYSTEM is non-nil, set up mode for the given system. + +To find out what version of Prolog mode you are running, enter +`\\[prolog-mode-version]'. + Commands: \\{prolog-mode-map} Entry to this mode calls the value of `prolog-mode-hook' if that value is non-nil." + (setq mode-name (concat "Prolog" + (cond + ((eq prolog-system 'eclipse) "[ECLiPSe]") + ((eq prolog-system 'sicstus) "[SICStus]") + ((eq prolog-system 'swi) "[SWI]") + ((eq prolog-system 'gnu) "[GNU]") + (t "")))) (prolog-mode-variables) - (set (make-local-variable 'comment-add) 1) - (setq font-lock-defaults '(prolog-font-lock-keywords - nil nil nil - beginning-of-line))) - -(defun end-of-prolog-clause () - "Go to end of clause in this line." - (beginning-of-line 1) - (let* ((eolpos (line-end-position))) - (if (re-search-forward comment-start-skip eolpos 'move) - (goto-char (match-beginning 0))) - (skip-chars-backward " \t"))) - -;;; -;;; Inferior prolog mode -;;; -(defvar inferior-prolog-mode-map + (prolog-build-case-strings) + (prolog-set-atom-regexps) + (dolist (ar prolog-align-rules) (add-to-list 'align-rules-list ar)) + + ;; imenu entry moved to the appropriate hook for consistency + + ;; Load SICStus debugger if suitable + (if (and (eq prolog-system 'sicstus) + (prolog-atleast-version '(3 . 7)) + prolog-use-sicstus-sd) + (prolog-enable-sicstus-sd))) + +(defvar mercury-mode-map (let ((map (make-sparse-keymap))) - ;; This map will inherit from `comint-mode-map' when entering - ;; inferior-prolog-mode. - (define-key map [remap self-insert-command] - 'inferior-prolog-self-insert-command) + (set-keymap-parent map prolog-mode-map) map)) -(defvar inferior-prolog-mode-syntax-table prolog-mode-syntax-table) -(defvar inferior-prolog-mode-abbrev-table prolog-mode-abbrev-table) - -(defvar inferior-prolog-error-regexp-alist - ;; GNU Prolog used to not follow the GNU standard format. - '(("^\\(.*?\\):\\([0-9]+\\) error: .*(char:\\([0-9]+\\)" 1 2 3) - gnu)) - -(declare-function comint-mode "comint") -(declare-function comint-send-string "comint" (process string)) -(declare-function comint-send-region "comint" (process start end)) -(declare-function comint-send-eof "comint" ()) -(defvar compilation-error-regexp-alist) - -(define-derived-mode inferior-prolog-mode comint-mode "Inferior Prolog" +;;;###autoload +(define-derived-mode mercury-mode prolog-mode "Prolog[Mercury]" + "Major mode for editing Mercury programs. +Actually this is just customized `prolog-mode'." + (set (make-local-variable 'prolog-system) 'mercury)) + + +;;------------------------------------------------------------------- +;; Inferior prolog mode +;;------------------------------------------------------------------- + +(defvar prolog-inferior-mode-map + (let ((map (make-sparse-keymap))) + (prolog-mode-keybindings-common map) + (prolog-mode-keybindings-inferior map) + map)) + +(defvar prolog-inferior-mode-hook nil + "List of functions to call after the inferior prolog mode has initialised.") + +(define-derived-mode prolog-inferior-mode comint-mode "Inferior Prolog" "Major mode for interacting with an inferior Prolog process. The following commands are available: -\\{inferior-prolog-mode-map} +\\{prolog-inferior-mode-map} Entry to this mode calls the value of `prolog-mode-hook' with no arguments, if that value is non-nil. Likewise with the value of `comint-mode-hook'. `prolog-mode-hook' is called after `comint-mode-hook'. -You can send text to the inferior Prolog from other buffers using the commands -`process-send-region', `process-send-string' and \\[prolog-consult-region]. +You can send text to the inferior Prolog from other buffers +using the commands `send-region', `send-string' and \\[prolog-consult-region]. Commands: Tab indents for Prolog; with argument, shifts rest of expression rigidly with the current line. -Paragraphs are separated only by blank lines and '%%'. -'%'s start comments. +Paragraphs are separated only by blank lines and '%%'. '%'s start comments. Return at end of buffer sends line as input. Return not at end copies rest of line to end and sends it. -\\[comint-kill-input] and \\[backward-kill-word] are kill commands, imitating normal Unix input editing. +\\[comint-delchar-or-maybe-eof] sends end-of-file as input. +\\[comint-kill-input] and \\[backward-kill-word] are kill commands, +imitating normal Unix input editing. \\[comint-interrupt-subjob] interrupts the shell or its current subjob if any. -\\[comint-stop-subjob] stops. \\[comint-quit-subjob] sends quit signal." - (setq comint-prompt-regexp "^| [ ?][- ] *") - (set (make-local-variable 'compilation-error-regexp-alist) - inferior-prolog-error-regexp-alist) - (compilation-shell-minor-mode) - (prolog-mode-variables)) - -(defvar inferior-prolog-buffer nil) - -(defvar inferior-prolog-flavor 'unknown - "Either a symbol or a buffer position offset by one. -If a buffer position, the flavor has not been determined yet and -it is expected that the process's output has been or will -be inserted at that position plus one.") - -(defun inferior-prolog-run (&optional name) - (with-current-buffer (make-comint "prolog" (or name prolog-program-name)) - (inferior-prolog-mode) - (setq-default inferior-prolog-buffer (current-buffer)) - (make-local-variable 'inferior-prolog-buffer) - (when (and name (not (equal name prolog-program-name))) - (set (make-local-variable 'prolog-program-name) name)) - (set (make-local-variable 'inferior-prolog-flavor) - ;; Force re-detection. - (let* ((proc (get-buffer-process (current-buffer))) - (pmark (and proc (marker-position (process-mark proc))))) - (cond - ((null pmark) (1- (point-min))) - ;; The use of insert-before-markers in comint.el together with - ;; the potential use of comint-truncate-buffer in the output - ;; filter, means that it's difficult to reliably keep track of - ;; the buffer position where the process's output started. - ;; If possible we use a marker at "start - 1", so that - ;; insert-before-marker at `start' won't shift it. And if not, - ;; we fall back on using a plain integer. - ((> pmark (point-min)) (copy-marker (1- pmark))) - (t (1- pmark))))) - (add-hook 'comint-output-filter-functions - 'inferior-prolog-guess-flavor nil t))) - -(defun inferior-prolog-process (&optional dontstart) - (or (and (buffer-live-p inferior-prolog-buffer) - (get-buffer-process inferior-prolog-buffer)) - (unless dontstart - (inferior-prolog-run) - ;; Try again. - (inferior-prolog-process)))) - -(defun inferior-prolog-guess-flavor (&optional ignored) - (save-excursion - (goto-char (1+ inferior-prolog-flavor)) - (setq inferior-prolog-flavor - (cond - ((looking-at "GNU Prolog") 'gnu) - ((looking-at "Welcome to SWI-Prolog") 'swi) - ((looking-at ".*\n") 'unknown) ;There's at least one line. - (t inferior-prolog-flavor)))) - (when (symbolp inferior-prolog-flavor) - (remove-hook 'comint-output-filter-functions - 'inferior-prolog-guess-flavor t) - (if (eq inferior-prolog-flavor 'gnu) - (set (make-local-variable 'comint-process-echoes) t)))) +\\[comint-stop-subjob] stops, likewise. +\\[comint-quit-subjob] sends quit signal, likewise. + +To find out what version of Prolog mode you are running, enter +`\\[prolog-mode-version]'." + (setq comint-input-filter 'prolog-input-filter) + (setq mode-line-process '(": %s")) + (prolog-mode-variables) + (setq comint-prompt-regexp prolog-prompt-regexp-i) + (set (make-local-variable 'shell-dirstack-query) "pwd.")) + +(defun prolog-input-filter (str) + (cond ((string-match "\\`\\s *\\'" str) nil) ;whitespace + ((not (eq major-mode 'prolog-inferior-mode)) t) + ((= (length str) 1) nil) ;one character + ((string-match "\\`[rf] *[0-9]*\\'" str) nil) ;r(edo) or f(ail) + (t t))) ;;;###autoload -(defalias 'run-prolog 'switch-to-prolog) -;;;###autoload -(defun switch-to-prolog (&optional name) +(defun run-prolog (arg) "Run an inferior Prolog process, input and output via buffer *prolog*. -With prefix argument \\[universal-prefix], prompt for the program to use." - (interactive - (list (when current-prefix-arg - (let ((proc (inferior-prolog-process 'dontstart))) - (if proc - (if (yes-or-no-p "Kill current process before starting new one? ") - (kill-process proc) - (error "Abort"))) - (read-string "Run Prolog: " prolog-program-name))))) - (unless (inferior-prolog-process 'dontstart) - (inferior-prolog-run name)) - (pop-to-buffer inferior-prolog-buffer)) - -(defun inferior-prolog-self-insert-command () - "Insert the char in the buffer or pass it directly to the process." +With prefix argument ARG, restart the Prolog process if running before." + (interactive "P") + (if (and arg (get-process "prolog")) + (progn + (process-send-string "prolog" "halt.\n") + (while (get-process "prolog") (sit-for 0.1)))) + (let ((buff (buffer-name))) + (if (not (string= buff "*prolog*")) + (prolog-goto-prolog-process-buffer)) + ;; Load SICStus debugger if suitable + (if (and (eq prolog-system 'sicstus) + (prolog-atleast-version '(3 . 7)) + prolog-use-sicstus-sd) + (prolog-enable-sicstus-sd)) + (prolog-mode-variables) + (prolog-ensure-process) + )) + +(defun prolog-ensure-process (&optional wait) + "If Prolog process is not running, run it. +If the optional argument WAIT is non-nil, wait for Prolog prompt specified by +the variable `prolog-prompt-regexp'." + (if (null prolog-program-name-i) + (error "This Prolog system has defined no interpreter.")) + (if (comint-check-proc "*prolog*") + () + (apply 'make-comint "prolog" prolog-program-name-i nil + prolog-program-switches-i) + (with-current-buffer "*prolog*" + (prolog-inferior-mode) + (if wait + (progn + (goto-char (point-max)) + (while + (save-excursion + (not + (re-search-backward + (concat "\\(" prolog-prompt-regexp-i "\\)" "\\=") + nil t))) + (sit-for 0.1))))))) + +(defun prolog-process-insert-string (process string) + "Insert STRING into inferior Prolog buffer running PROCESS." + ;; Copied from elisp manual, greek to me + (with-current-buffer (process-buffer process) + ;; FIXME: Use window-point-insertion-type instead. + (let ((moving (= (point) (process-mark process)))) + (save-excursion + ;; Insert the text, moving the process-marker. + (goto-char (process-mark process)) + (insert string) + (set-marker (process-mark process) (point))) + (if moving (goto-char (process-mark process)))))) + +;;------------------------------------------------------------ +;; Old consulting and compiling functions +;;------------------------------------------------------------ + +(defun prolog-old-process-region (compilep start end) + "Process the region limited by START and END positions. +If COMPILEP is non-nil then use compilation, otherwise consulting." + (prolog-ensure-process) + ;(let ((tmpfile prolog-temp-filename) + (let ((tmpfile (prolog-bsts (prolog-temporary-file))) + ;(process (get-process "prolog")) + (first-line (1+ (count-lines + (point-min) + (save-excursion + (goto-char start) + (point)))))) + (write-region start end tmpfile) + (process-send-string + "prolog" (prolog-build-prolog-command + compilep tmpfile (prolog-bsts buffer-file-name) + first-line)) + (prolog-goto-prolog-process-buffer))) + +(defun prolog-old-process-predicate (compilep) + "Process the predicate around point. +If COMPILEP is non-nil then use compilation, otherwise consulting." + (prolog-old-process-region + compilep (prolog-pred-start) (prolog-pred-end))) + +(defun prolog-old-process-buffer (compilep) + "Process the entire buffer. +If COMPILEP is non-nil then use compilation, otherwise consulting." + (prolog-old-process-region compilep (point-min) (point-max))) + +(defun prolog-old-process-file (compilep) + "Process the file of the current buffer. +If COMPILEP is non-nil then use compilation, otherwise consulting." + (save-some-buffers) + (prolog-ensure-process) + (let ((filename (prolog-bsts buffer-file-name))) + (process-send-string + "prolog" (prolog-build-prolog-command + compilep filename filename)) + (prolog-goto-prolog-process-buffer))) + + +;;------------------------------------------------------------ +;; Consulting and compiling +;;------------------------------------------------------------ + +;;; Interactive interface functions, used by both the standard +;;; and the experimental consultation and compilation functions +(defun prolog-consult-file () + "Consult file of current buffer." + (interactive) + (if prolog-use-standard-consult-compile-method-flag + (prolog-old-process-file nil) + (prolog-consult-compile-file nil))) + +(defun prolog-consult-buffer () + "Consult buffer." + (interactive) + (if prolog-use-standard-consult-compile-method-flag + (prolog-old-process-buffer nil) + (prolog-consult-compile-buffer nil))) + +(defun prolog-consult-region (beg end) + "Consult region between BEG and END." + (interactive "r") + (if prolog-use-standard-consult-compile-method-flag + (prolog-old-process-region nil beg end) + (prolog-consult-compile-region nil beg end))) + +(defun prolog-consult-predicate () + "Consult the predicate around current point." + (interactive) + (if prolog-use-standard-consult-compile-method-flag + (prolog-old-process-predicate nil) + (prolog-consult-compile-predicate nil))) + +(defun prolog-compile-file () + "Compile file of current buffer." + (interactive) + (if prolog-use-standard-consult-compile-method-flag + (prolog-old-process-file t) + (prolog-consult-compile-file t))) + +(defun prolog-compile-buffer () + "Compile buffer." + (interactive) + (if prolog-use-standard-consult-compile-method-flag + (prolog-old-process-buffer t) + (prolog-consult-compile-buffer t))) + +(defun prolog-compile-region (beg end) + "Compile region between BEG and END." + (interactive "r") + (if prolog-use-standard-consult-compile-method-flag + (prolog-old-process-region t beg end) + (prolog-consult-compile-region t beg end))) + +(defun prolog-compile-predicate () + "Compile the predicate around current point." (interactive) - (let* ((proc (get-buffer-process (current-buffer))) - (pmark (and proc (marker-position (process-mark proc))))) - (if (and (eq inferior-prolog-flavor 'gnu) - pmark - (null current-prefix-arg) - (eobp) - (eq (point) pmark) + (if prolog-use-standard-consult-compile-method-flag + (prolog-old-process-predicate t) + (prolog-consult-compile-predicate t))) + +(defun prolog-buffer-module () + "Select Prolog module name appropriate for current buffer. +Bases decision on buffer contents (-*- line)." + ;; Look for -*- ... module: MODULENAME; ... -*- + (let (beg end) + (save-excursion + (goto-char (point-min)) + (skip-chars-forward " \t") + (and (search-forward "-*-" (save-excursion (end-of-line) (point)) t) + (progn + (skip-chars-forward " \t") + (setq beg (point)) + (search-forward "-*-" (save-excursion (end-of-line) (point)) t)) + (progn + (forward-char -3) + (skip-chars-backward " \t") + (setq end (point)) + (goto-char beg) + (and (let ((case-fold-search t)) + (search-forward "module:" end t)) + (progn + (skip-chars-forward " \t") + (setq beg (point)) + (if (search-forward ";" end t) + (forward-char -1) + (goto-char end)) + (skip-chars-backward " \t") + (buffer-substring beg (point))))))))) + +(defun prolog-build-prolog-command (compilep file buffername + &optional first-line) + "Make Prolog command for FILE compilation/consulting. +If COMPILEP is non-nil, consider compilation, otherwise consulting." + (let* ((compile-string + (if compilep prolog-compile-string-i prolog-consult-string-i)) + (module (prolog-buffer-module)) + (file-name (concat "'" file "'")) + (module-name (if module (concat "'" module "'"))) + (module-file (if module + (concat module-name ":" file-name) + file-name)) + strbeg strend + (lineoffset (if first-line + (- first-line 1) + 0))) + + ;; Assure that there is a buffer name + (if (not buffername) + (error "The buffer is not saved")) + + (if (not (string-match "^'.*'$" buffername)) ; Add quotes + (setq buffername (concat "'" buffername "'"))) + (while (string-match "%m" compile-string) + (setq strbeg (substring compile-string 0 (match-beginning 0))) + (setq strend (substring compile-string (match-end 0))) + (setq compile-string (concat strbeg module-file strend))) + (while (string-match "%f" compile-string) + (setq strbeg (substring compile-string 0 (match-beginning 0))) + (setq strend (substring compile-string (match-end 0))) + (setq compile-string (concat strbeg file-name strend))) + (while (string-match "%b" compile-string) + (setq strbeg (substring compile-string 0 (match-beginning 0))) + (setq strend (substring compile-string (match-end 0))) + (setq compile-string (concat strbeg buffername strend))) + (while (string-match "%l" compile-string) + (setq strbeg (substring compile-string 0 (match-beginning 0))) + (setq strend (substring compile-string (match-end 0))) + (setq compile-string (concat strbeg (format "%d" lineoffset) strend))) + (concat compile-string "\n"))) + +;;; The rest of this page is experimental code! + +;; Global variables for process filter function +(defvar prolog-process-flag nil + "Non-nil means that a prolog task (i.e. a consultation or compilation job) +is running.") +(defvar prolog-consult-compile-output "" + "Hold the unprocessed output from the current prolog task.") +(defvar prolog-consult-compile-first-line 1 + "The number of the first line of the file to consult/compile. +Used for temporary files.") +(defvar prolog-consult-compile-file nil + "The file to compile/consult (can be a temporary file).") +(defvar prolog-consult-compile-real-file nil + "The file name of the buffer to compile/consult.") + +(defun prolog-consult-compile (compilep file &optional first-line) + "Consult/compile FILE. +If COMPILEP is non-nil, perform compilation, otherwise perform CONSULTING. +COMMAND is a string described by the variables `prolog-consult-string' +and `prolog-compile-string'. +Optional argument FIRST-LINE is the number of the first line in the compiled +region. + +This function must be called from the source code buffer." + (if prolog-process-flag + (error "Another Prolog task is running.")) + (prolog-ensure-process t) + (let* ((buffer (get-buffer-create prolog-compilation-buffer)) + (real-file buffer-file-name) + (command-string (prolog-build-prolog-command compilep file + real-file first-line)) + (process (get-process "prolog")) + (old-filter (process-filter process))) + (with-current-buffer buffer + (delete-region (point-min) (point-max)) + (compilation-mode) + ;; Setting up font-locking for this buffer + (make-local-variable 'font-lock-defaults) + (setq font-lock-defaults + '(prolog-font-lock-keywords nil nil ((?_ . "w")))) + (if (eq prolog-system 'sicstus) + (progn + (make-local-variable 'compilation-parse-errors-function) + (setq compilation-parse-errors-function + 'prolog-parse-sicstus-compilation-errors))) + (toggle-read-only 0) + (insert command-string "\n")) + (save-selected-window + (pop-to-buffer buffer)) + (setq prolog-process-flag t + prolog-consult-compile-output "" + prolog-consult-compile-first-line (if first-line (1- first-line) 0) + prolog-consult-compile-file file + prolog-consult-compile-real-file (if (string= + file buffer-file-name) + nil + real-file)) + (with-current-buffer buffer + (goto-char (point-max)) + (set-process-filter process 'prolog-consult-compile-filter) + (process-send-string "prolog" command-string) + ;; (prolog-build-prolog-command compilep file real-file first-line)) + (while (and prolog-process-flag + (accept-process-output process 10)) ; 10 secs is ok? + (sit-for 0.1) + (unless (get-process "prolog") + (setq prolog-process-flag nil))) + (insert (if compilep + "\nCompilation finished.\n" + "\nConsulted.\n")) + (set-process-filter process old-filter)))) + +(defun prolog-parse-sicstus-compilation-errors (limit) + "Parse the prolog compilation buffer for errors. +Argument LIMIT is a buffer position limiting searching. +For use with the `compilation-parse-errors-function' variable." + (setq compilation-error-list nil) + (message "Parsing SICStus error messages...") + (let (filepath dir file errorline) + (while + (re-search-backward + "{\\([a-zA-Z ]* ERROR\\|Warning\\):.* in line[s ]*\\([0-9]+\\)" + limit t) + (setq errorline (string-to-number (match-string 2))) + (save-excursion + (re-search-backward + "{\\(consulting\\|compiling\\|processing\\) \\(.*\\)\\.\\.\\.}" + limit t) + (setq filepath (match-string 2))) + + ;; ###### Does this work with SICStus under Windows (i.e. backslahes and stuff?) + (if (string-match "\\(.*/\\)\\([^/]*\\)$" filepath) + (progn + (setq dir (match-string 1 filepath)) + (setq file (match-string 2 filepath)))) + + (setq compilation-error-list + (cons + (cons (save-excursion + (beginning-of-line) + (point-marker)) + (list (list file dir) errorline)) + compilation-error-list) + )) + )) + +(defun prolog-consult-compile-filter (process output) + "Filter function for Prolog compilation PROCESS. +Argument OUTPUT is a name of the output file." + ;;(message "start") + (setq prolog-consult-compile-output + (concat prolog-consult-compile-output output)) + ;;(message "pccf1: %s" prolog-consult-compile-output) + ;; Iterate through the lines of prolog-consult-compile-output + (let (outputtype) + (while (and prolog-process-flag + (or + ;; Trace question + (progn + (setq outputtype 'trace) + (and (eq prolog-system 'sicstus) + (string-match + "^[ \t]*[0-9]+[ \t]*[0-9]+[ \t]*Call:.*? " + prolog-consult-compile-output))) + + ;; Match anything + (progn + (setq outputtype 'normal) + (string-match "^.*\n" prolog-consult-compile-output)) + )) + ;;(message "outputtype: %s" outputtype) + + (setq output (match-string 0 prolog-consult-compile-output)) + ;; remove the text in output from prolog-consult-compile-output + (setq prolog-consult-compile-output + (substring prolog-consult-compile-output (length output))) + ;;(message "pccf2: %s" prolog-consult-compile-output) + + ;; If temporary files were used, then we change the error + ;; messages to point to the original source file. + (cond + + ;; If the prolog process was in trace mode then it requires + ;; user input + ((and (eq prolog-system 'sicstus) + (eq outputtype 'trace)) + (let (input) + (setq input (concat (read-string output) "\n")) + (process-send-string process input) + (setq output (concat output input)))) + + ((eq prolog-system 'sicstus) + (if (and prolog-consult-compile-real-file + (string-match + "\\({.*:.* in line[s ]*\\)\\([0-9]+\\)-\\([0-9]+\\)" output)) + (setq output (replace-match + ;; Adds a {processing ...} line so that + ;; `prolog-parse-sicstus-compilation-errors' + ;; finds the real file instead of the temporary one. + ;; Also fixes the line numbers. + (format "Added by Emacs: {processing %s...}\n%s%d-%d" + prolog-consult-compile-real-file + (match-string 1 output) + (+ prolog-consult-compile-first-line + (string-to-number + (match-string 2 output))) + (+ prolog-consult-compile-first-line + (string-to-number + (match-string 3 output)))) + t t output))) + ) + + ((eq prolog-system 'swi) + (if (and prolog-consult-compile-real-file + (string-match (format + "%s\\([ \t]*:[ \t]*\\)\\([0-9]+\\)" + prolog-consult-compile-file) + output)) + (setq output (replace-match + ;; Real filename + text + fixed linenum + (format "%s%s%d" + prolog-consult-compile-real-file + (match-string 1 output) + (+ prolog-consult-compile-first-line + (string-to-number + (match-string 2 output)))) + t t output))) + ) + + (t ()) + ) + ;; Write the output in the *prolog-compilation* buffer + (insert output))) + + ;; If the prompt is visible, then the task is finished + (if (string-match prolog-prompt-regexp-i prolog-consult-compile-output) + (setq prolog-process-flag nil))) + +(defun prolog-consult-compile-file (compilep) + "Consult/compile file of current buffer. +If COMPILEP is non-nil, compile, otherwise consult." + (let ((file buffer-file-name)) + (if file + (progn + (save-some-buffers) + (prolog-consult-compile compilep file)) + (prolog-consult-compile-region compilep (point-min) (point-max))))) + +(defun prolog-consult-compile-buffer (compilep) + "Consult/compile current buffer. +If COMPILEP is non-nil, compile, otherwise consult." + (prolog-consult-compile-region compilep (point-min) (point-max))) + +(defun prolog-consult-compile-region (compilep beg end) + "Consult/compile region between BEG and END. +If COMPILEP is non-nil, compile, otherwise consult." + ;(let ((file prolog-temp-filename) + (let ((file (prolog-bsts (prolog-temporary-file))) + (lines (count-lines 1 beg))) + (write-region beg end file nil 'no-message) + (write-region "\n" nil file t 'no-message) + (prolog-consult-compile compilep file + (if (looking-at "^") (1+ lines) lines)) + (delete-file file))) + +(defun prolog-consult-compile-predicate (compilep) + "Consult/compile the predicate around current point. +If COMPILEP is non-nil, compile, otherwise consult." + (prolog-consult-compile-region + compilep (prolog-pred-start) (prolog-pred-end))) + + +;;------------------------------------------------------------------- +;; Font-lock stuff +;;------------------------------------------------------------------- + +;; Auxilliary functions +(defun prolog-make-keywords-regexp (keywords &optional protect) + "Create regexp from the list of strings KEYWORDS. +If PROTECT is non-nil, surround the result regexp by word breaks." + (let ((regexp + (if (fboundp 'regexp-opt) + ;; Emacs 20 + ;; Avoid compile warnings under earlier versions by using eval + (eval '(regexp-opt keywords)) + ;; Older Emacsen + (concat (mapconcat 'regexp-quote keywords "\\|"))) + )) + (if protect + (concat "\\<\\(" regexp "\\)\\>") + regexp))) + +(defun prolog-font-lock-object-matcher (bound) + "Find SICStus objects method name for font lock. +Argument BOUND is a buffer position limiting searching." + (let (point + (case-fold-search nil)) + (while (and (not point) + (re-search-forward "\\(::[ \t\n]*{\\|&\\)[ \t]*" + bound t)) + (while (or (re-search-forward "\\=\n[ \t]*" bound t) + (re-search-forward "\\=%.*" bound t) + (and (re-search-forward "\\=/\\*" bound t) + (re-search-forward "\\*/[ \t]*" bound t)))) + (setq point (re-search-forward + (format "\\=\\(%s\\)" prolog-atom-regexp) + bound t))) + point)) + +(defsubst prolog-face-name-p (facename) + ;; Return t if FACENAME is the name of a face. This method is + ;; necessary since facep in XEmacs only returns t for the actual + ;; face objects (while it's only their names that are used just + ;; about anywhere else) without providing a predicate that tests + ;; face names. This function (including the above commentary) is + ;; borrowed from cc-mode. + (memq facename (face-list))) + +;; Set everything up +(defun prolog-font-lock-keywords () + "Set up font lock keywords for the current Prolog system." + ;(when window-system + (require 'font-lock) + + ;; Define Prolog faces + (defface prolog-redo-face + '((((class grayscale)) (:italic t)) + (((class color)) (:foreground "darkorchid")) + (t (:italic t))) + "Prolog mode face for highlighting redo trace lines." + :group 'prolog-faces) + (defface prolog-exit-face + '((((class grayscale)) (:underline t)) + (((class color) (background dark)) (:foreground "green")) + (((class color) (background light)) (:foreground "ForestGreen")) + (t (:underline t))) + "Prolog mode face for highlighting exit trace lines." + :group 'prolog-faces) + (defface prolog-exception-face + '((((class grayscale)) (:bold t :italic t :underline t)) + (((class color)) (:bold t :foreground "black" :background "Khaki")) + (t (:bold t :italic t :underline t))) + "Prolog mode face for highlighting exception trace lines." + :group 'prolog-faces) + (defface prolog-warning-face + '((((class grayscale)) (:underline t)) + (((class color) (background dark)) (:foreground "blue")) + (((class color) (background light)) (:foreground "MidnightBlue")) + (t (:underline t))) + "Face name to use for compiler warnings." + :group 'prolog-faces) + (defface prolog-builtin-face + '((((class color) (background light)) (:foreground "Purple")) + (((class color) (background dark)) (:foreground "Cyan")) + (((class grayscale) (background light)) (:foreground "LightGray" :bold t)) + (((class grayscale) (background dark)) (:foreground "DimGray" :bold t)) + (t (:bold t))) + "Face name to use for compiler warnings." + :group 'prolog-faces) + (defvar prolog-warning-face + (if (prolog-face-name-p 'font-lock-warning-face) + 'font-lock-warning-face + 'prolog-warning-face) + "Face name to use for built in predicates.") + (defvar prolog-builtin-face + (if (prolog-face-name-p 'font-lock-builtin-face) + 'font-lock-builtin-face + 'prolog-builtin-face) + "Face name to use for built in predicates.") + (defvar prolog-redo-face 'prolog-redo-face + "Face name to use for redo trace lines.") + (defvar prolog-exit-face 'prolog-exit-face + "Face name to use for exit trace lines.") + (defvar prolog-exception-face 'prolog-exception-face + "Face name to use for exception trace lines.") + + ;; Font Lock Patterns + (let ( + ;; "Native" Prolog patterns + (head-predicates + (list (format "^\\(%s\\)\\((\\|[ \t]*:-\\)" prolog-atom-regexp) + 1 font-lock-function-name-face)) + ;(list (format "^%s" prolog-atom-regexp) + ; 0 font-lock-function-name-face)) + (head-predicates-1 + (list (format "\\.[ \t]*\\(%s\\)" prolog-atom-regexp) + 1 font-lock-function-name-face) ) + (variables + '("\\<\\([_A-Z][a-zA-Z0-9_]*\\)" + 1 font-lock-variable-name-face)) + (important-elements + (list (if (eq prolog-system 'mercury) + "[][}{;|]\\|\\\\[+=]\\|<?=>?" + "[][}{!;|]\\|\\*->") + 0 'font-lock-keyword-face)) + (important-elements-1 + '("[^-*]\\(->\\)" 1 font-lock-keyword-face)) + (predspecs ; module:predicate/cardinality + (list (format "\\<\\(%s:\\|\\)%s/[0-9]+" + prolog-atom-regexp prolog-atom-regexp) + 0 font-lock-function-name-face 'prepend)) + (keywords ; directives (queries) + (list + (if (eq prolog-system 'mercury) + (concat + "\\<\\(" + (prolog-make-keywords-regexp prolog-keywords-i) + "\\|" + (prolog-make-keywords-regexp + prolog-determinism-specificators-i) + "\\)\\>") + (concat + "^[?:]- *\\(" + (prolog-make-keywords-regexp prolog-keywords-i) + "\\)\\>")) + 1 prolog-builtin-face)) + (quoted_atom (list prolog-quoted-atom-regexp + 2 'font-lock-string-face 'append)) + (string (list prolog-string-regexp + 1 'font-lock-string-face 'append)) + ;; SICStus specific patterns + (sicstus-object-methods + (if (eq prolog-system 'sicstus) + '(prolog-font-lock-object-matcher + 1 font-lock-function-name-face))) + ;; Mercury specific patterns + (types + (if (eq prolog-system 'mercury) + (list + (prolog-make-keywords-regexp prolog-types-i t) + 0 'font-lock-type-face))) + (modes + (if (eq prolog-system 'mercury) + (list + (prolog-make-keywords-regexp prolog-mode-specificators-i t) + 0 'font-lock-reference-face))) + (directives + (if (eq prolog-system 'mercury) + (list + (prolog-make-keywords-regexp prolog-directives-i t) + 0 'prolog-warning-face))) + ;; Inferior mode specific patterns + (prompt + (list prolog-prompt-regexp-i 0 'font-lock-keyword-face)) + (trace-exit + (cond + ((eq prolog-system 'sicstus) + '("[ \t]*[0-9]+[ \t]+[0-9]+[ \t]*\\(Exit\\):" + 1 prolog-exit-face)) + ((eq prolog-system 'swi) + '("[ \t]*\\(Exit\\):[ \t]*([ \t0-9]*)" 1 prolog-exit-face)) + (t nil))) + (trace-fail + (cond + ((eq prolog-system 'sicstus) + '("[ \t]*[0-9]+[ \t]+[0-9]+[ \t]*\\(Fail\\):" + 1 prolog-warning-face)) + ((eq prolog-system 'swi) + '("[ \t]*\\(Fail\\):[ \t]*([ \t0-9]*)" 1 prolog-warning-face)) + (t nil))) + (trace-redo + (cond + ((eq prolog-system 'sicstus) + '("[ \t]*[0-9]+[ \t]+[0-9]+[ \t]*\\(Redo\\):" + 1 prolog-redo-face)) + ((eq prolog-system 'swi) + '("[ \t]*\\(Redo\\):[ \t]*([ \t0-9]*)" 1 prolog-redo-face)) + (t nil))) + (trace-call + (cond + ((eq prolog-system 'sicstus) + '("[ \t]*[0-9]+[ \t]+[0-9]+[ \t]*\\(Call\\):" + 1 font-lock-function-name-face)) + ((eq prolog-system 'swi) + '("[ \t]*\\(Call\\):[ \t]*([ \t0-9]*)" + 1 font-lock-function-name-face)) + (t nil))) + (trace-exception + (cond + ((eq prolog-system 'sicstus) + '("[ \t]*[0-9]+[ \t]+[0-9]+[ \t]*\\(Exception\\):" + 1 prolog-exception-face)) + ((eq prolog-system 'swi) + '("[ \t]*\\(Exception\\):[ \t]*([ \t0-9]*)" + 1 prolog-exception-face)) + (t nil))) + (error-message-identifier + (cond + ((eq prolog-system 'sicstus) + '("{\\([A-Z]* ?ERROR:\\)" 1 prolog-exception-face prepend)) + ((eq prolog-system 'swi) + '("^[[]\\(WARNING:\\)" 1 prolog-builtin-face prepend)) + (t nil))) + (error-whole-messages + (cond + ((eq prolog-system 'sicstus) + '("{\\([A-Z]* ?ERROR:.*\\)}[ \t]*$" + 1 font-lock-comment-face append)) + ((eq prolog-system 'swi) + '("^[[]WARNING:[^]]*[]]$" 0 font-lock-comment-face append)) + (t nil))) + (error-warning-messages + ;; Mostly errors that SICStus asks the user about how to solve, + ;; such as "NAME CLASH:" for example. + (cond + ((eq prolog-system 'sicstus) + '("^[A-Z ]*[A-Z]+:" 0 prolog-warning-face)) + (t nil))) + (warning-messages + (cond + ((eq prolog-system 'sicstus) + '("\\({ ?\\(Warning\\|WARNING\\) ?:.*}\\)[ \t]*$" + 2 prolog-warning-face prepend)) + (t nil)))) + + ;; Make font lock list + (delq + nil + (cond + ((eq major-mode 'prolog-mode) + (list + head-predicates + head-predicates-1 + quoted_atom + string + variables + important-elements + important-elements-1 + predspecs + keywords + sicstus-object-methods + types + modes + directives)) + ((eq major-mode 'prolog-inferior-mode) + (list + prompt + error-message-identifier + error-whole-messages + error-warning-messages + warning-messages + predspecs + trace-exit + trace-fail + trace-redo + trace-call + trace-exception)) + ((eq major-mode 'compilation-mode) + (list + error-message-identifier + error-whole-messages + error-warning-messages + warning-messages + predspecs)))) + )) + + +;;------------------------------------------------------------------- +;; Indentation stuff +;;------------------------------------------------------------------- + +;; NB: This function *MUST* have this optional argument since XEmacs +;; assumes it. This does not mean we have to use it... +(defun prolog-indent-line (&optional whole-exp) + "Indent current line as Prolog code. +With argument, indent any additional lines of the same clause +rigidly along with this one (not yet)." + (interactive "p") + (let ((indent (prolog-indent-level)) + (pos (- (point-max) (point))) beg) + (beginning-of-line) + (setq beg (point)) + (skip-chars-forward " \t") + (if (zerop (- indent (current-column))) + nil + (delete-region beg (point)) + (indent-to indent)) + (if (> (- (point-max) pos) (point)) + (goto-char (- (point-max) pos))) + + ;; Align comments + (if prolog-align-comments-flag + (save-excursion + (prolog-goto-comment-column t))) + + ;; Insert spaces if needed + (if (or prolog-electric-tab-flag prolog-electric-if-then-else-flag) + (prolog-insert-spaces-after-paren)) + )) + +(defun prolog-comment-indent () + "Compute prolog comment indentation." + (cond ((looking-at "%%%") (prolog-indentation-level-of-line)) + ((looking-at "%%") (prolog-indent-level)) + (t + (save-excursion + (skip-chars-backward " \t") + ;; Insert one space at least, except at left margin. + (max (+ (current-column) (if (bolp) 0 1)) + comment-column))) + )) + +(defun prolog-indent-level () + "Compute prolog indentation level." + (save-excursion + (beginning-of-line) + (let ((totbal (prolog-region-paren-balance + (prolog-clause-start t) (point))) + (oldpoint (point))) + (skip-chars-forward " \t") + (cond + ((looking-at "%%%") (prolog-indentation-level-of-line)) + ;Large comment starts + ((looking-at "%[^%]") comment-column) ;Small comment starts + ((bobp) 0) ;Beginning of buffer + + ;; If we found '}' then we must check if it's the + ;; end of an object declaration or something else. + ((and (looking-at "}") (save-excursion - (goto-char (- pmark 3)) - (looking-at " \\? "))) - ;; This is GNU prolog waiting to know whether you want more answers - ;; or not (or abort, etc...). The answer is a single char, not - ;; a line, so pass this char directly rather than wait for RET to - ;; send a whole line. - (comint-send-string proc (string last-command-event)) - (call-interactively 'self-insert-command)))) - -(defun prolog-consult-region (compile beg end) - "Send the region to the Prolog process made by \"M-x run-prolog\". -If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode." - (interactive "P\nr") - (let ((proc (inferior-prolog-process))) - (comint-send-string proc - (if compile prolog-compile-string - prolog-consult-string)) - (comint-send-region proc beg end) - (comint-send-string proc "\n") ;May be unnecessary - (if prolog-eof-string - (comint-send-string proc prolog-eof-string) - (with-current-buffer (process-buffer proc) - (comint-send-eof))))) ;Send eof to prolog process. - -(defun prolog-consult-region-and-go (compile beg end) - "Send the region to the inferior Prolog, and switch to *prolog* buffer. -If COMPILE (prefix arg) is not nil, use compile mode rather than consult mode." - (interactive "P\nr") - (prolog-consult-region compile beg end) - (pop-to-buffer inferior-prolog-buffer)) - -;; inferior-prolog-mode uses the autoloaded compilation-shell-minor-mode. -(declare-function compilation-forget-errors "compile" ()) - -(defun inferior-prolog-load-file () - "Pass the current buffer's file to the inferior prolog process." + (forward-char 1) + ;; Goto to matching { + (if prolog-use-prolog-tokenizer-flag + (prolog-backward-list) + (backward-list)) + (skip-chars-backward " \t") + (backward-char 2) + (looking-at "::"))) + ;; It was an object + (if prolog-object-end-to-0-flag + 0 + prolog-indent-width)) + + ;;End of /* */ comment + ((looking-at "\\*/") + (save-excursion + (prolog-find-start-of-mline-comment) + (skip-chars-backward " \t") + (- (current-column) 2))) + + ;; Here we check if the current line is within a /* */ pair + ((and (looking-at "[^%/]") + (eq (prolog-in-string-or-comment) 'cmt)) + (if prolog-indent-mline-comments-flag + (prolog-find-start-of-mline-comment) + ;; Same as before + (prolog-indentation-level-of-line))) + + (t + (let ((empty t) ind linebal) + ;; See previous indentation + (while empty + (forward-line -1) + (beginning-of-line) + (if (= (point) (point-min)) + (setq empty nil) + (skip-chars-forward " \t") + (if (not (or (not (member (prolog-in-string-or-comment) '(nil txt))) + (looking-at "%") + (looking-at "\n"))) + (setq empty nil)))) + + ;; Store this line's indentation + (if (= (point) (point-min)) + (setq ind 0) ;Beginning of buffer + (setq ind (current-column))) ;Beginning of clause + + ;; Compute the balance of the line + (setq linebal (prolog-paren-balance)) + ;;(message "bal of previous line %d totbal %d" linebal totbal) + (if (< linebal 0) + (progn + ;; Add 'indent-level' mode to find-unmatched-paren instead? + (end-of-line) + (setq ind (prolog-find-indent-of-matching-paren)))) + + ;;(message "ind %d" ind) + (beginning-of-line) + + ;; Check if the line ends with ":-", ".", ":: {", "}" (might be + ;; unnecessary), "&" or ")" (The last four concerns SICStus objects) + (cond + ;; If the last char of the line is a '&' then set the indent level + ;; to prolog-indent-width (used in SICStus objects) + ((and (eq prolog-system 'sicstus) + (looking-at ".+&[ \t]*\\(%.*\\|\\)$")) + (setq ind prolog-indent-width)) + + ;; Increase indentation if the previous line was the head of a rule + ;; and does not contain a '.' + ((and (looking-at (format ".*%s[^\\.]*[ \t]*\\(%%.*\\|\\)$" + prolog-head-delimiter)) + ;; We must check that the match is at a paren balance of 0. + (save-excursion + (let ((p (point))) + (re-search-forward prolog-head-delimiter) + (>= 0 (prolog-region-paren-balance p (point)))))) + (let (headindent) + (if (< (prolog-paren-balance) 0) + (save-excursion + (end-of-line) + (setq headindent (prolog-find-indent-of-matching-paren))) + (setq headindent (prolog-indentation-level-of-line))) + (setq ind (+ headindent prolog-indent-width)))) + + ;; The previous line was the head of an object + ((looking-at ".+ *::.*{[ \t]*$") + (setq ind prolog-indent-width)) + + ;; If a '.' is found at the end of the previous line, then + ;; decrease the indentation. (The \\(%.*\\|\\) part of the + ;; regexp is for comments at the end of the line) + ((and (looking-at "^.+\\.[ \t]*\\(%.*\\|\\)$") + ;; Make sure that the '.' found is not in a comment or string + (save-excursion + (end-of-line) + (re-search-backward "\\.[ \t]*\\(%.*\\|\\)$" (point-min)) + ;; Guard against the real '.' being followed by a + ;; commented '.'. + (if (eq (prolog-in-string-or-comment) 'cmt) ;; commented out '.' + (let ((here (save-excursion + (beginning-of-line) + (point)))) + (end-of-line) + (re-search-backward "\\.[ \t]*%.*$" here t)) + (not (prolog-in-string-or-comment)) + ) + )) + (setq ind 0)) + + ;; If a '.' is found at the end of the previous line, then + ;; decrease the indentation. (The /\\*.*\\*/ part of the + ;; regexp is for C-like comments at the end of the + ;; line--can we merge with the case above?). + ((and (looking-at "^.+\\.[ \t]*\\(/\\*.*\\|\\)$") + ;; Make sure that the '.' found is not in a comment or string + (save-excursion + (end-of-line) + (re-search-backward "\\.[ \t]*\\(/\\*.*\\|\\)$" (point-min)) + ;; Guard against the real '.' being followed by a + ;; commented '.'. + (if (eq (prolog-in-string-or-comment) 'cmt) ;; commented out '.' + (let ((here (save-excursion + (beginning-of-line) + (point)))) + (end-of-line) + (re-search-backward "\\.[ \t]*/\\*.*$" here t)) + (not (prolog-in-string-or-comment)) + ) + )) + (setq ind 0)) + + ) + + ;; If the last non comment char is a ',' or left paren or a left- + ;; indent-regexp then indent to open parenthesis level + (if (and + (> totbal 0) + ;; SICStus objects have special syntax rules if point is + ;; not inside additional parens (objects are defined + ;; within {...}) + (not (and (eq prolog-system 'sicstus) + (= totbal 1) + (prolog-in-object)))) + (if (looking-at + (format "\\(%s\\|%s\\|0'.\\|[0-9]+'[0-9a-zA-Z]+\\|[^\n\'\"%%]\\)*\\(,\\|%s\\|%s\\)\[ \t]*\\(%%.*\\|\\)$" + prolog-quoted-atom-regexp prolog-string-regexp + prolog-left-paren prolog-left-indent-regexp)) + (progn + (goto-char oldpoint) + (setq ind (prolog-find-unmatched-paren (if prolog-paren-indent-p + 'termdependent + 'skipwhite))) + ;;(setq ind (prolog-find-unmatched-paren 'termdependent)) + ) + (goto-char oldpoint) + (setq ind (prolog-find-unmatched-paren nil)) + )) + + + ;; Return the indentation level + ind + )))))) + +(defun prolog-find-indent-of-matching-paren () + "Find the indentation level based on the matching parenthesis. +Indentation level is set to the one the point is after when the function is +called." + (save-excursion + ;; Go to the matching paren + (if prolog-use-prolog-tokenizer-flag + (prolog-backward-list) + (backward-list)) + + ;; If this was the first paren on the line then return this line's + ;; indentation level + (if (prolog-paren-is-the-first-on-line-p) + (prolog-indentation-level-of-line) + ;; It was not the first one + (progn + ;; Find the next paren + (prolog-goto-next-paren 0) + + ;; If this paren is a left one then use its column as indent level, + ;; if not then recurse this function + (if (looking-at prolog-left-paren) + (+ (current-column) 1) + (progn + (forward-char 1) + (prolog-find-indent-of-matching-paren))) + )) + )) + +(defun prolog-indentation-level-of-line () + "Return the indentation level of the current line." + (save-excursion + (beginning-of-line) + (skip-chars-forward " \t") + (current-column))) + +(defun prolog-first-pos-on-line () + "Return the first position on the current line." + (save-excursion + (beginning-of-line) + (point))) + +(defun prolog-paren-is-the-first-on-line-p () + "Return t if the parenthesis under the point is the first one on the line. +Return nil otherwise. +Note: does not check if the point is actually at a parenthesis!" + (save-excursion + (let ((begofline (prolog-first-pos-on-line))) + (if (= begofline (point)) + t + (if (prolog-goto-next-paren begofline) + nil + t))))) + +(defun prolog-find-unmatched-paren (&optional mode) + "Return the column of the last unmatched left parenthesis. +If MODE is `skipwhite' then any white space after the parenthesis is added to +the answer. +If MODE is `plusone' then the parenthesis' column +1 is returned. +If MODE is `termdependent' then if the unmatched parenthesis is part of +a compound term the function will work as `skipwhite', otherwise +it will return the column paren plus the value of `prolog-paren-indent'. +If MODE is nil or not set then the parenthesis' exact column is returned." + (save-excursion + ;; If the next paren we find is a left one we're finished, if it's + ;; a right one then we go back one step and recurse + (prolog-goto-next-paren 0) + + (let ((roundparen (looking-at "("))) + (if (looking-at prolog-left-paren) + (let ((not-part-of-term + (save-excursion + (backward-char 1) + (looking-at "[ \t]")))) + (if (eq mode nil) + (current-column) + (if (and roundparen + (eq mode 'termdependent) + not-part-of-term) + (+ (current-column) + (if prolog-electric-tab-flag + ;; Electric TAB + prolog-paren-indent + ;; Not electric TAB + (if (looking-at ".[ \t]*$") + 2 + prolog-paren-indent)) + ) + + (forward-char 1) + (if (or (eq mode 'skipwhite) (eq mode 'termdependent) ) + (skip-chars-forward " \t")) + (current-column)))) + ;; Not looking at left paren + (progn + (forward-char 1) + ;; Go to the matching paren. When we get there we have a total + ;; balance of 0. + (if prolog-use-prolog-tokenizer-flag + (prolog-backward-list) + (backward-list)) + (prolog-find-unmatched-paren mode))) + ))) + + +(defun prolog-paren-balance () + "Return the parenthesis balance of the current line. +A return value of n means n more left parentheses than right ones." + (save-excursion + (end-of-line) + (prolog-region-paren-balance (prolog-first-pos-on-line) (point)))) + +(defun prolog-region-paren-balance (beg end) + "Return the summed parenthesis balance in the region. +The region is limited by BEG and END positions." + (save-excursion + (let ((state (if prolog-use-prolog-tokenizer-flag + (prolog-tokenize beg end) + (parse-partial-sexp beg end)))) + (nth 0 state)))) + +(defun prolog-goto-next-paren (limit-pos) + "Move the point to the next parenthesis earlier in the buffer. +Return t if a match was found before LIMIT-POS. Return nil otherwise." + (let (retval) + (setq retval (re-search-backward + (concat prolog-left-paren "\\|" prolog-right-paren) + limit-pos t)) + + ;; If a match was found but it was in a string or comment, then recurse + (if (and retval (prolog-in-string-or-comment)) + (prolog-goto-next-paren limit-pos) + retval) + )) + +(defun prolog-in-string-or-comment () + "Check whether string, atom, or comment is under current point. +Return: + `txt' if the point is in a string, atom, or character code expression + `cmt' if the point is in a comment + nil otherwise." + (save-excursion + (let* ((start + (if (eq prolog-parse-mode 'beg-of-line) + ;; 'beg-of-line + (save-excursion + (let (safepoint) + (beginning-of-line) + (setq safepoint (point)) + (while (and (> (point) (point-min)) + (progn + (forward-line -1) + (end-of-line) + (if (not (bobp)) + (backward-char 1)) + (looking-at "\\\\")) + ) + (beginning-of-line) + (setq safepoint (point))) + safepoint)) + ;; 'beg-of-clause + (prolog-clause-start))) + (end (point)) + (state (if prolog-use-prolog-tokenizer-flag + (prolog-tokenize start end) + (parse-partial-sexp start end)))) + (cond + ((nth 3 state) 'txt) ; String + ((nth 4 state) 'cmt) ; Comment + (t + (cond + ((looking-at "%") 'cmt) ; Start of a comment + ((looking-at "/\\*") 'cmt) ; Start of a comment + ((looking-at "\'") 'txt) ; Start of an atom + ((looking-at "\"") 'txt) ; Start of a string + (t nil) + )))) + )) + +(defun prolog-find-start-of-mline-comment () + "Return the start column of a /* */ comment. +This assumes that the point is inside a comment." + (re-search-backward "/\\*" (point-min) t) + (forward-char 2) + (skip-chars-forward " \t") + (current-column)) + +(defun prolog-insert-spaces-after-paren () + "Insert spaces after the opening parenthesis, \"then\" (->) and \"else\" (;) branches. +Spaces are inserted if all preceding objects on the line are +whitespace characters, parentheses, or then/else branches." + (save-excursion + (let ((regexp (concat "(\\|" prolog-left-indent-regexp)) + level) + (beginning-of-line) + (skip-chars-forward " \t") + (when (looking-at regexp) + ;; Treat "( If -> " lines specially. + ;;(if (looking-at "(.*->") + ;; (setq incr 2) + ;; (setq incr prolog-paren-indent)) + + ;; work on all subsequent "->", "(", ";" + (while (looking-at regexp) + (goto-char (match-end 0)) + (setq level (+ (prolog-find-unmatched-paren) prolog-paren-indent)) + + ;; Remove old white space + (let ((start (point))) + (skip-chars-forward " \t") + (delete-region start (point))) + (indent-to level) + (skip-chars-forward " \t")) + ))) + (when (save-excursion + (backward-char 2) + (looking-at "\\s ;\\|\\s (\\|->")) ; (looking-at "\\s \\((\\|;\\)")) + (skip-chars-forward " \t")) + ) + +;;;; Comment filling + +(defun prolog-comment-limits () + "Return the current comment limits plus the comment type (block or line). +The comment limits are the range of a block comment or the range that +contains all adjacent line comments (i.e. all comments that starts in +the same column with no empty lines or non-whitespace characters +between them)." + (let ((here (point)) + lit-limits-b lit-limits-e lit-type beg end + ) + (save-restriction + ;; Widen to catch comment limits correctly. + (widen) + (setq end (save-excursion (end-of-line) (point)) + beg (save-excursion (beginning-of-line) (point))) + (save-excursion + (beginning-of-line) + (setq lit-type (if (search-forward-regexp "%" end t) 'line 'block)) + ; (setq lit-type 'line) + ;(if (search-forward-regexp "^[ \t]*%" end t) + ; (setq lit-type 'line) + ; (if (not (search-forward-regexp "%" end t)) + ; (setq lit-type 'block) + ; (if (not (= (forward-line 1) 0)) + ; (setq lit-type 'block) + ; (setq done t + ; ret (prolog-comment-limits))) + ; )) + (if (eq lit-type 'block) + (progn + (goto-char here) + (when (looking-at "/\\*") (forward-char 2)) + (when (and (looking-at "\\*") (> (point) (point-min)) + (forward-char -1) (looking-at "/")) + (forward-char 1)) + (when (save-excursion (search-backward "/*" nil t)) + (list (save-excursion (search-backward "/*") (point)) + (or (search-forward "*/" nil t) (point-max)) lit-type))) + ;; line comment + (setq lit-limits-b (- (point) 1) + lit-limits-e end) + (condition-case nil + (if (progn (goto-char lit-limits-b) + (looking-at "%")) + (let ((col (current-column)) done) + (setq beg (point) + end lit-limits-e) + ;; Always at the beginning of the comment + ;; Go backward now + (beginning-of-line) + (while (and (zerop (setq done (forward-line -1))) + (search-forward-regexp "^[ \t]*%" (save-excursion (end-of-line) (point)) t) + (= (+ 1 col) (current-column))) + (setq beg (- (point) 1))) + (when (= done 0) + (forward-line 1)) + ;; We may have a line with code above... + (when (and (zerop (setq done (forward-line -1))) + (search-forward "%" (save-excursion (end-of-line) (point)) t) + (= (+ 1 col) (current-column))) + (setq beg (- (point) 1))) + (when (= done 0) + (forward-line 1)) + ;; Go forward + (goto-char lit-limits-b) + (beginning-of-line) + (while (and (zerop (forward-line 1)) + (search-forward-regexp "^[ \t]*%" (save-excursion (end-of-line) (point)) t) + (= (+ 1 col) (current-column))) + (setq end (save-excursion (end-of-line) (point)))) + (list beg end lit-type)) + (list lit-limits-b lit-limits-e lit-type) + ) + (error (list lit-limits-b lit-limits-e lit-type)))) + )))) + +(defun prolog-guess-fill-prefix () + ;; fill 'txt entities? + (when (save-excursion + (end-of-line) + (equal (prolog-in-string-or-comment) 'cmt)) + (let* ((bounds (prolog-comment-limits)) + (cbeg (car bounds)) + (type (nth 2 bounds)) + beg end) + (save-excursion + (end-of-line) + (setq end (point)) + (beginning-of-line) + (setq beg (point)) + (if (and (eq type 'line) + (> cbeg beg) + (save-excursion (not (search-forward-regexp "^[ \t]*%" + cbeg t)))) + (progn + (goto-char cbeg) + (search-forward-regexp "%+[ \t]*" end t) + (prolog-replace-in-string (buffer-substring beg (point)) + "[^ \t%]" " ")) + ;(goto-char beg) + (if (search-forward-regexp "^[ \t]*\\(%+\\|\\*+\\|/\\*+\\)[ \t]*" + end t) + (prolog-replace-in-string (buffer-substring beg (point)) "/" " ") + (beginning-of-line) + (when (search-forward-regexp "^[ \t]+" end t) + (buffer-substring beg (point))))))))) + +(defun prolog-fill-paragraph () + "Fill paragraph comment at or after point." + (interactive) + (let* ((bounds (prolog-comment-limits)) + (type (nth 2 bounds))) + (if (eq type 'line) + (let ((fill-prefix (prolog-guess-fill-prefix))) + (fill-paragraph nil)) + (save-excursion + (save-restriction + ;; exclude surrounding lines that delimit a multiline comment + ;; and don't contain alphabetic characters, like "/*******", + ;; "- - - */" etc. + (save-excursion + (backward-paragraph) + (unless (bobp) (forward-line)) + (if (string-match "^/\\*[^a-zA-Z]*$" (thing-at-point 'line)) + (narrow-to-region (point-at-eol) (point-max)))) + (save-excursion + (forward-paragraph) + (forward-line -1) + (if (string-match "^[^a-zA-Z]*\\*/$" (thing-at-point 'line)) + (narrow-to-region (point-min) (point-at-bol)))) + (let ((fill-prefix (prolog-guess-fill-prefix))) + (fill-paragraph nil)))) + ))) + +(defun prolog-do-auto-fill () + "Carry out Auto Fill for Prolog mode. +In effect it sets the `fill-prefix' when inside comments and then calls +`do-auto-fill'." + (let ((fill-prefix (prolog-guess-fill-prefix))) + (do-auto-fill) + )) + +(defalias 'prolog-replace-in-string + (if (fboundp 'replace-in-string) + #'replace-in-string + (lambda (str regexp newtext &optional literal) + (replace-regexp-in-string regexp newtext str nil literal)))) + +;;------------------------------------------------------------------- +;; The tokenizer +;;------------------------------------------------------------------- + +(defconst prolog-tokenize-searchkey + (concat "[0-9]+'" + "\\|" + "['\"]" + "\\|" + prolog-left-paren + "\\|" + prolog-right-paren + "\\|" + "%" + "\\|" + "/\\*" + )) + +(defun prolog-tokenize (beg end &optional stopcond) + "Tokenize a region of prolog code between BEG and END. +STOPCOND decides the stop condition of the parsing. Valid values +are 'zerodepth which stops the parsing at the first right parenthesis +where the parenthesis depth is zero, 'skipover which skips over +the current entity (e.g. a list, a string, etc.) and nil. + +The function returns a list with the following information: + 0. parenthesis depth + 3. 'atm if END is inside an atom + 'str if END is inside a string + 'chr if END is in a character code expression (0'x) + nil otherwise + 4. non-nil if END is inside a comment + 5. end position (always equal to END if STOPCOND is nil) +The rest of the elements are undefined." + (save-excursion + (let* ((end2 (1+ end)) + oldp + (depth 0) + (quoted nil) + inside_cmt + (endpos end2) + skiptype ; The type of entity we'll skip over + ) + (goto-char beg) + + (if (and (eq stopcond 'skipover) + (looking-at "[^[({'\"]")) + (setq endpos (point)) ; Stay where we are + (while (and + (re-search-forward prolog-tokenize-searchkey end2 t) + (< (point) end2)) + (progn + (setq oldp (point)) + (goto-char (match-beginning 0)) + (cond + ;; Atoms and strings + ((looking-at "'") + ;; Find end of atom + (if (re-search-forward "[^\\]'" end2 'limit) + ;; Found end of atom + (progn + (setq oldp end2) + (if (and (eq stopcond 'skipover) + (not skiptype)) + (setq endpos (point)) + (setq oldp (point)))) ; Continue tokenizing + (setq quoted 'atm))) + + ((looking-at "\"") + ;; Find end of string + (if (re-search-forward "[^\\]\"" end2 'limit) + ;; Found end of string + (progn + (setq oldp end2) + (if (and (eq stopcond 'skipover) + (not skiptype)) + (setq endpos (point)) + (setq oldp (point)))) ; Continue tokenizing + (setq quoted 'str))) + + ;; Paren stuff + ((looking-at prolog-left-paren) + (setq depth (1+ depth)) + (setq skiptype 'paren)) + + ((looking-at prolog-right-paren) + (setq depth (1- depth)) + (if (and + (or (eq stopcond 'zerodepth) + (and (eq stopcond 'skipover) + (eq skiptype 'paren))) + (= depth 0)) + (progn + (setq endpos (1+ (point))) + (setq oldp end2)))) + + ;; Comment stuff + ((looking-at comment-start) + (end-of-line) + ;; (if (>= (point) end2) + (if (>= (point) end) + (progn + (setq inside_cmt t) + (setq oldp end2)) + (setq oldp (point)))) + + ((looking-at "/\\*") + (if (re-search-forward "\\*/" end2 'limit) + (setq oldp (point)) + (setq inside_cmt t) + (setq oldp end2))) + + ;; 0'char + ((looking-at "0'") + (setq oldp (1+ (match-end 0))) + (if (> oldp end) + (setq quoted 'chr))) + + ;; base'number + ((looking-at "[0-9]+'") + (goto-char (match-end 0)) + (skip-chars-forward "0-9a-zA-Z") + (setq oldp (point))) + + + ) + (goto-char oldp) + )) ; End of while + ) + + ;; Deal with multi-line comments + (and (prolog-inside-mline-comment end) + (setq inside_cmt t)) + + ;; Create return list + (list depth nil nil quoted inside_cmt endpos) + ))) + +(defun prolog-inside-mline-comment (here) + (save-excursion + (goto-char here) + (let* ((next-close (save-excursion (search-forward "*/" nil t))) + (next-open (save-excursion (search-forward "/*" nil t))) + (prev-open (save-excursion (search-backward "/*" nil t))) + (prev-close (save-excursion (search-backward "*/" nil t))) + (unmatched-next-close (and next-close + (or (not next-open) + (> next-open next-close)))) + (unmatched-prev-open (and prev-open + (or (not prev-close) + (> prev-open prev-close)))) + ) + (or unmatched-next-close unmatched-prev-open) + ))) + + +;;------------------------------------------------------------------- +;; Online help +;;------------------------------------------------------------------- + +(defvar prolog-help-function + '((mercury nil) + (eclipse prolog-help-online) + ;; (sicstus prolog-help-info) + (sicstus prolog-find-documentation) + (swi prolog-help-online) + (t prolog-help-online)) + "Alist for the name of the function for finding help on a predicate.") + +(defun prolog-help-on-predicate () + "Invoke online help on the atom under cursor." + (interactive) + + (cond + ;; Redirect help for SICStus to `prolog-find-documentation'. + ((eq prolog-help-function-i 'prolog-find-documentation) + (prolog-find-documentation)) + + ;; Otherwise, ask for the predicate name and then call the function + ;; in prolog-help-function-i + (t + (let* (word + predicate + ;point + ) + (setq word (prolog-atom-under-point)) + (setq predicate (read-from-minibuffer + (format "Help on predicate%s: " + (if word + (concat " (default " word ")") + "")))) + (if (string= predicate "") + (setq predicate word)) + (if prolog-help-function-i + (funcall prolog-help-function-i predicate) + (error "Sorry, no help method defined for this Prolog system.")))) + )) + +(defun prolog-help-info (predicate) + (let ((buffer (current-buffer)) + oldp + (str (concat "^\\* " (regexp-quote predicate) " */"))) + (require 'info) + (pop-to-buffer nil) + (Info-goto-node prolog-info-predicate-index) + (if (not (re-search-forward str nil t)) + (error (format "Help on predicate `%s' not found." predicate))) + + (setq oldp (point)) + (if (re-search-forward str nil t) + ;; Multiple matches, ask user + (let ((max 2) + n) + ;; Count matches + (while (re-search-forward str nil t) + (setq max (1+ max))) + + (goto-char oldp) + (re-search-backward "[^ /]" nil t) + (recenter 0) + (setq n (read-string ;; was read-input, which is obsolete + (format "Several matches, choose (1-%d): " max) "1")) + (forward-line (- (string-to-number n) 1))) + ;; Single match + (re-search-backward "[^ /]" nil t)) + + ;; (Info-follow-nearest-node (point)) + (prolog-Info-follow-nearest-node) + (re-search-forward (concat "^`" (regexp-quote predicate)) nil t) + (beginning-of-line) + (recenter 0) + (pop-to-buffer buffer))) + +(defun prolog-Info-follow-nearest-node () + (if (featurep 'xemacs) + (Info-follow-nearest-node (point)) + (Info-follow-nearest-node))) + +(defun prolog-help-online (predicate) + (prolog-ensure-process) + (process-send-string "prolog" (concat "help(" predicate ").\n")) + (display-buffer "*prolog*")) + +(defun prolog-help-apropos (string) + "Find Prolog apropos on given STRING. +This function is only available when `prolog-system' is set to `swi'." + (interactive "sApropos: ") + (cond + ((eq prolog-system 'swi) + (prolog-ensure-process) + (process-send-string "prolog" (concat "apropos(" string ").\n")) + (display-buffer "*prolog*")) + (t + (error "Sorry, no Prolog apropos available for this Prolog system.")))) + +(defun prolog-atom-under-point () + "Return the atom under or left to the point." + (save-excursion + (let ((nonatom_chars "[](){},\. \t\n") + start) + (skip-chars-forward (concat "^" nonatom_chars)) + (skip-chars-backward nonatom_chars) + (skip-chars-backward (concat "^" nonatom_chars)) + (setq start (point)) + (skip-chars-forward (concat "^" nonatom_chars)) + (buffer-substring-no-properties start (point)) + ))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Help function with completion +;; Stolen from Per Mildner's SICStus debugger mode and modified + +(defun prolog-find-documentation () + "Go to the Info node for a predicate in the SICStus Info manual." + (interactive) + (let ((pred (prolog-read-predicate))) + (prolog-goto-predicate-info pred))) + +(defvar prolog-info-alist nil + "Alist with all builtin predicates. +Only for internal use by `prolog-find-documentation'") + +;; Very similar to prolog-help-info except that that function cannot +;; cope with arity and that it asks the user if there are several +;; functors with different arity. This function also uses +;; prolog-info-alist for finding the info node, rather than parsing +;; the predicate index. +(defun prolog-goto-predicate-info (predicate) + "Go to the info page for PREDICATE, which is a PredSpec." + (interactive) + (require 'info) + (string-match "\\(.*\\)/\\([0-9]+\\).*$" predicate) + (let ((buffer (current-buffer)) + (name (match-string 1 predicate)) + (arity (match-string 2 predicate)) + ;oldp + ;(str (regexp-quote predicate)) + ) + (setq arity (string-to-number arity)) + (pop-to-buffer nil) + + (Info-goto-node + prolog-info-predicate-index) ;; We must be in the SICStus pages + (Info-goto-node (car (cdr (assoc predicate prolog-info-alist)))) + + (prolog-find-term (regexp-quote name) arity "^`") + + (recenter 0) + (pop-to-buffer buffer)) +) + +(defun prolog-read-predicate () + "Read a PredSpec from the user. +Returned value is a string \"FUNCTOR/ARITY\". +Interaction supports completion." + (let ((initial (prolog-atom-under-point)) + answer) + ;; If the predicate index is not yet built, do it now + (if (not prolog-info-alist) + (prolog-build-info-alist)) + ;; Test if the initial string could be the base for completion. + ;; Discard it if not. + (if (eq (try-completion initial prolog-info-alist) nil) + (setq initial "")) + ;; Read the PredSpec from the user + (setq answer (completing-read + "Help on predicate: " + prolog-info-alist nil t initial)) + (if (equal answer "") + initial + answer))) + +(defun prolog-build-info-alist (&optional verbose) + "Build an alist of all builtins and library predicates. +Each element is of the form (\"NAME/ARITY\" . (INFO-NODE1 INFO-NODE2 ...)). +Typically there is just one Info node associated with each name +If an optional argument VERBOSE is non-nil, print messages at the beginning +and end of list building." + (if verbose + (message "Building info alist...")) + (setq prolog-info-alist + (let ((l ()) + (last-entry (cons "" ()))) + (save-excursion + (save-window-excursion + ;; select any window but the minibuffer (as we cannot switch + ;; buffers in minibuffer window. + ;; I am not sure this is the right/best way + (if (active-minibuffer-window) ; nil if none active + (select-window (next-window))) + ;; Do this after going away from minibuffer window + (save-window-excursion + (info)) + (Info-goto-node prolog-info-predicate-index) + (goto-char (point-min)) + (while (re-search-forward + "^\\* \\(.+\\)/\\([0-9]+\\)\\([^\n:*]*\\):" nil t) + (let* ((name (match-string 1)) + (arity (string-to-number (match-string 2))) + (comment (match-string 3)) + (fa (format "%s/%d%s" name arity comment)) + info-node) + (beginning-of-line) + ;; Extract the info node name + (setq info-node (progn + (re-search-forward ":[ \t]*\\([^:]+\\).$") + (match-string 1) + )) + ;; ###### Easier? (from Milan version 0.1.28) + ;; (setq info-node (Info-extract-menu-node-name)) + (if (equal fa (car last-entry)) + (setcdr last-entry (cons info-node (cdr last-entry))) + (setq last-entry (cons fa (list info-node)) + l (cons last-entry l))))) + (nreverse l) + )))) + (if verbose + (message "Building info alist... done."))) + + +;;------------------------------------------------------------------- +;; Miscellaneous functions +;;------------------------------------------------------------------- + +;; For Windows. Change backslash to slash. SICStus handles either +;; path separator but backslash must be doubled, therefore use slash. +(defun prolog-bsts (string) + "Change backslashes to slashes in STRING." + (let ((str1 (copy-sequence string)) + (len (length string)) + (i 0)) + (while (< i len) + (if (char-equal (aref str1 i) ?\\) + (aset str1 i ?/)) + (setq i (1+ i))) + str1)) + +;(defun prolog-temporary-file () +; "Make temporary file name for compilation." +; (make-temp-name +; (concat +; (or +; (getenv "TMPDIR") +; (getenv "TEMP") +; (getenv "TMP") +; (getenv "SYSTEMP") +; "/tmp") +; "/prolcomp"))) +;(setq prolog-temp-filename (prolog-bsts (prolog-temporary-file))) + +(defun prolog-temporary-file () + "Make temporary file name for compilation." + (if prolog-temporary-file-name + ;; We already have a file, erase content and continue + (progn + (write-region "" nil prolog-temporary-file-name nil 'silent) + prolog-temporary-file-name) + ;; Actually create the file and set `prolog-temporary-file-name' accordingly + (let* ((umask (default-file-modes)) + (temporary-file-directory (or + (getenv "TMPDIR") + (getenv "TEMP") + (getenv "TMP") + (getenv "SYSTEMP") + "/tmp")) + (prefix (expand-file-name "prolcomp" temporary-file-directory)) + (suffix ".pl") + file) + (unwind-protect + (progn + ;; Create temp files with strict access rights. + (set-default-file-modes #o700) + (while (condition-case () + (progn + (setq file (concat (make-temp-name prefix) suffix)) + ;; (concat (make-temp-name "/tmp/prolcomp") ".pl") + (unless (file-exists-p file) + (write-region "" nil file nil 'silent)) + nil) + (file-already-exists t)) + ;; the file was somehow created by someone else between + ;; `make-temp-name' and `write-region', let's try again. + nil) + (setq prolog-temporary-file-name file)) + ;; Reset the umask. + (set-default-file-modes umask))) + )) + +(defun prolog-goto-prolog-process-buffer () + "Switch to the prolog process buffer and go to its end." + (switch-to-buffer-other-window "*prolog*") + (goto-char (point-max)) +) + +(defun prolog-enable-sicstus-sd () + "Enable the source level debugging facilities of SICStus 3.7 and later." + (interactive) + (require 'pltrace) ; Load the SICStus debugger code + ;; Turn on the source level debugging by default + (add-hook 'prolog-inferior-mode-hook 'pltrace-on) + (if (not prolog-use-sicstus-sd) + (progn + ;; If there is a *prolog* buffer, then call pltrace-on + (if (get-buffer "*prolog*") + ;; Avoid compilation warnings by using eval + (eval '(pltrace-on))) + (setq prolog-use-sicstus-sd t) + ))) + +(defun prolog-disable-sicstus-sd () + "Disable the source level debugging facilities of SICStus 3.7 and later." + (interactive) + (setq prolog-use-sicstus-sd nil) + ;; Remove the hook + (remove-hook 'prolog-inferior-mode-hook 'pltrace-on) + ;; If there is a *prolog* buffer, then call pltrace-off + (if (get-buffer "*prolog*") + ;; Avoid compile warnings by using eval + (eval '(pltrace-off)))) + +(defun prolog-debug-on (&optional arg) + "Enable debugging. +When called with prefix argument ARG, disable debugging instead." + (interactive "P") + (if arg + (prolog-debug-off) + (prolog-process-insert-string (get-process "prolog") + prolog-debug-on-string) + (process-send-string "prolog" prolog-debug-on-string))) + +(defun prolog-debug-off () + "Disable debugging." + (interactive) + (prolog-process-insert-string (get-process "prolog") + prolog-debug-off-string) + (process-send-string "prolog" prolog-debug-off-string)) + +(defun prolog-trace-on (&optional arg) + "Enable tracing. +When called with prefix argument ARG, disable tracing instead." + (interactive "P") + (if arg + (prolog-trace-off) + (prolog-process-insert-string (get-process "prolog") + prolog-trace-on-string) + (process-send-string "prolog" prolog-trace-on-string))) + +(defun prolog-trace-off () + "Disable tracing." + (interactive) + (prolog-process-insert-string (get-process "prolog") + prolog-trace-off-string) + (process-send-string "prolog" prolog-trace-off-string)) + +(defun prolog-zip-on (&optional arg) + "Enable zipping (for SICStus 3.7 and later). +When called with prefix argument ARG, disable zipping instead." + (interactive "P") + (if arg + (prolog-zip-off) + (prolog-process-insert-string (get-process "prolog") + prolog-zip-on-string) + (process-send-string "prolog" prolog-zip-on-string))) + +(defun prolog-zip-off () + "Disable zipping (for SICStus 3.7 and later)." (interactive) - (save-buffer) - (let ((file buffer-file-name) - (proc (inferior-prolog-process))) - (with-current-buffer (process-buffer proc) - (compilation-forget-errors) - (comint-send-string proc (concat "['" (file-relative-name file) "'].\n")) - (pop-to-buffer (current-buffer))))) + (prolog-process-insert-string (get-process "prolog") + prolog-zip-off-string) + (process-send-string "prolog" prolog-zip-off-string)) + +;; (defun prolog-create-predicate-index () +;; "Create an index for all predicates in the buffer." +;; (let ((predlist '()) +;; clauseinfo +;; object +;; pos +;; ) +;; (goto-char (point-min)) +;; ;; Replace with prolog-clause-start! +;; (while (re-search-forward "^.+:-" nil t) +;; (setq pos (match-beginning 0)) +;; (setq clauseinfo (prolog-clause-info)) +;; (setq object (prolog-in-object)) +;; (setq predlist (append +;; predlist +;; (list (cons +;; (if (and (eq prolog-system 'sicstus) +;; (prolog-in-object)) +;; (format "%s::%s/%d" +;; object +;; (nth 0 clauseinfo) +;; (nth 1 clauseinfo)) +;; (format "%s/%d" +;; (nth 0 clauseinfo) +;; (nth 1 clauseinfo))) +;; pos +;; )))) +;; (prolog-end-of-predicate)) +;; predlist)) + +(defun prolog-get-predspec () + (save-excursion + (let ((state (prolog-clause-info)) + (object (prolog-in-object))) + (if (or (equal (nth 0 state) "") (equal (prolog-in-string-or-comment) 'cmt)) + nil + (if (and (eq prolog-system 'sicstus) + object) + (format "%s::%s/%d" + object + (nth 0 state) + (nth 1 state)) + (format "%s/%d" + (nth 0 state) + (nth 1 state))) + )))) + +;; For backward compatibility. Stolen from custom.el. +(or (fboundp 'match-string) + ;; Introduced in Emacs 19.29. + (defun match-string (num &optional string) + "Return string of text matched by last search. +NUM specifies which parenthesized expression in the last regexp. + Value is nil if NUMth pair didn't match, or there were less than NUM pairs. +Zero means the entire text matched by the whole regexp or whole string. +STRING should be given if the last search was by `string-match' on STRING." + (if (match-beginning num) + (if string + (substring string (match-beginning num) (match-end num)) + (buffer-substring (match-beginning num) (match-end num)))))) + +(defun prolog-pred-start () + "Return the starting point of the first clause of the current predicate." + (save-excursion + (goto-char (prolog-clause-start)) + ;; Find first clause, unless it was a directive + (if (and (not (looking-at "[:?]-")) + (not (looking-at "[ \t]*[%/]")) ; Comment + + ) + (let* ((pinfo (prolog-clause-info)) + (predname (nth 0 pinfo)) + (arity (nth 1 pinfo)) + (op (point))) + (while (and (re-search-backward + (format "^%s\\([(\\.]\\| *%s\\)" + predname prolog-head-delimiter) nil t) + (= arity (nth 1 (prolog-clause-info))) + ) + (setq op (point))) + (if (eq prolog-system 'mercury) + ;; Skip to the beginning of declarations of the predicate + (progn + (goto-char (prolog-beginning-of-clause)) + (while (and (not (eq (point) op)) + (looking-at + (format ":-[ \t]*\\(pred\\|mode\\)[ \t]+%s" + predname))) + (setq op (point)) + (goto-char (prolog-beginning-of-clause))))) + op) + (point)))) + +(defun prolog-pred-end () + "Return the position at the end of the last clause of the current predicate." + (save-excursion + (goto-char (prolog-clause-end)) ; if we are before the first predicate + (goto-char (prolog-clause-start)) + (let* ((pinfo (prolog-clause-info)) + (predname (nth 0 pinfo)) + (arity (nth 1 pinfo)) + oldp + (notdone t) + (op (point))) + (if (looking-at "[:?]-") + ;; This was a directive + (progn + (if (and (eq prolog-system 'mercury) + (looking-at + (format ":-[ \t]*\\(pred\\|mode\\)[ \t]+\\(%s+\\)" + prolog-atom-regexp))) + ;; Skip predicate declarations + (progn + (setq predname (buffer-substring-no-properties + (match-beginning 2) (match-end 2))) + (while (re-search-forward + (format + "\n*\\(:-[ \t]*\\(pred\\|mode\\)[ \t]+\\)?%s[( \t]" + predname) + nil t)))) + (goto-char (prolog-clause-end)) + (setq op (point))) + ;; It was not a directive, find the last clause + (while (and notdone + (re-search-forward + (format "^%s\\([(\\.]\\| *%s\\)" + predname prolog-head-delimiter) nil t) + (= arity (nth 1 (prolog-clause-info)))) + (setq oldp (point)) + (setq op (prolog-clause-end)) + (if (>= oldp op) + ;; End of clause not found. + (setq notdone nil) + ;; Continue while loop + (goto-char op)))) + op))) + +(defun prolog-clause-start (&optional not-allow-methods) + "Return the position at the start of the head of the current clause. +If NOTALLOWMETHODS is non-nil then do not match on methods in +objects (relevent only if 'prolog-system' is set to 'sicstus)." + (save-excursion + (let ((notdone t) + (retval (point-min))) + (end-of-line) + + ;; SICStus object? + (if (and (not not-allow-methods) + (eq prolog-system 'sicstus) + (prolog-in-object)) + (while (and + notdone + ;; Search for a head or a fact + (re-search-backward + ;; If in object, then find method start. + ;; "^[ \t]+[a-z$].*\\(:-\\|&\\|:: {\\|,\\)" + "^[ \t]+[a-z$].*\\(:-\\|&\\|:: {\\)" ; The comma causes + ; problems since we cannot assume + ; that the line starts at column 0, + ; thus we don't know if the line + ; is a head or a subgoal + (point-min) t)) + (if (>= (prolog-paren-balance) 0) ; To no match on " a) :-" + ;; Start of method found + (progn + (setq retval (point)) + (setq notdone nil))) + ) ; End of while + + ;; Not in object + (while (and + notdone + ;; Search for a text at beginning of a line + ;; ###### + ;; (re-search-backward "^[a-z$']" nil t)) + (let ((case-fold-search nil)) + (re-search-backward + ;; (format "^[%s$']" prolog-lower-case-string) + ;; FIXME: Use [:lower:] + (format "^\\([%s$']\\|[:?]-\\)" prolog-lower-case-string) + nil t))) + (let ((bal (prolog-paren-balance))) + (cond + ((> bal 0) + ;; Start of clause found + (progn + (setq retval (point)) + (setq notdone nil))) + ((and (= bal 0) + (looking-at + (format ".*\\(\\.\\|%s\\|!,\\)[ \t]*\\(%%.*\\|\\)$" + prolog-head-delimiter))) + ;; Start of clause found if the line ends with a '.' or + ;; a prolog-head-delimiter + (progn + (setq retval (point)) + (setq notdone nil)) + ) + (t nil) ; Do nothing + )))) + + retval))) + +(defun prolog-clause-end (&optional not-allow-methods) + "Return the position at the end of the current clause. +If NOTALLOWMETHODS is non-nil then do not match on methods in +objects (relevent only if 'prolog-system' is set to 'sicstus)." + (save-excursion + (beginning-of-line) ; Necessary since we use "^...." for the search + (if (re-search-forward + (if (and (not not-allow-methods) + (eq prolog-system 'sicstus) + (prolog-in-object)) + (format + "^\\(%s\\|%s\\|[^\n\'\"%%]\\)*&[ \t]*\\(\\|%%.*\\)$\\|[ \t]*}" + prolog-quoted-atom-regexp prolog-string-regexp) + (format + "^\\(%s\\|%s\\|[^\n\'\"%%]\\)*\\.[ \t]*\\(\\|%%.*\\)$" + prolog-quoted-atom-regexp prolog-string-regexp)) + nil t) + (if (and (prolog-in-string-or-comment) + (not (eobp))) + (progn + (forward-char) + (prolog-clause-end)) + (point)) + (point)))) + +(defun prolog-clause-info () + "Return a (name arity) list for the current clause." + (let (predname (arity 0)) + (save-excursion + (goto-char (prolog-clause-start)) + (let ((op (point))) + (if (looking-at prolog-atom-char-regexp) + (progn + (skip-chars-forward "^ (\\.") + (setq predname (buffer-substring op (point)))) + (setq predname "")) + ;; Retrieve the arity + (if (looking-at prolog-left-paren) + (let ((endp (save-excursion + (prolog-forward-list) (point)))) + (setq arity 1) + (forward-char 1) ; Skip the opening paren + (while (progn + (skip-chars-forward "^[({,'\"") + (< (point) endp)) + (if (looking-at ",") + (progn + (setq arity (1+ arity)) + (forward-char 1) ; Skip the comma + ) + ;; We found a string, list or something else we want + ;; to skip over. Always use prolog-tokenize, + ;; parse-partial-sexp does not have a 'skipover mode. + (goto-char (nth 5 (prolog-tokenize (point) endp 'skipover)))) + ))) + (list predname arity) + )))) + +(defun prolog-in-object () + "Return object name if the point is inside a SICStus object definition." + ;; Return object name if the last line that starts with a character + ;; that is neither white space nor a comment start + (save-excursion + (if (save-excursion + (beginning-of-line) + (looking-at "\\([^\n ]+\\)[ \t]*::[ \t]*{")) + ;; We were in the head of the object + (match-string 1) + ;; We were not in the head + (if (and (re-search-backward "^[a-z$'}]" nil t) + (looking-at "\\([^\n ]+\\)[ \t]*::[ \t]*{")) + (match-string 1) + nil)))) + +(defun prolog-forward-list () + "Move the point to the matching right parenthesis." + (interactive) + (if prolog-use-prolog-tokenizer-flag + (let ((state (prolog-tokenize (point) (point-max) 'zerodepth))) + (goto-char (nth 5 state))) + (forward-list))) + +;; NB: This could be done more efficiently! +(defun prolog-backward-list () + "Move the point to the matching left parenthesis." + (interactive) + (if prolog-use-prolog-tokenizer-flag + (let ((bal 0) + (paren-regexp (concat prolog-left-paren "\\|" prolog-right-paren)) + (notdone t)) + (while (and notdone (re-search-backward paren-regexp nil t)) + (cond + ((looking-at prolog-left-paren) + (if (not (prolog-in-string-or-comment)) + (setq bal (1+ bal))) + (if (= bal 0) + (setq notdone nil))) + ((looking-at prolog-right-paren) + (if (not (prolog-in-string-or-comment)) + (setq bal (1- bal)))) + ))) + (backward-list))) + +(defun prolog-beginning-of-clause () + "Move to the beginning of current clause. +If already at the beginning of clause, move to previous clause." + (interactive) + (let ((point (point)) + (new-point (prolog-clause-start))) + (if (and (>= new-point point) + (> point 1)) + (progn + (goto-char (1- point)) + (goto-char (prolog-clause-start))) + (goto-char new-point) + (skip-chars-forward " \t")))) + +;; (defun prolog-previous-clause () +;; "Move to the beginning of the previous clause." +;; (interactive) +;; (forward-char -1) +;; (prolog-beginning-of-clause)) + +(defun prolog-end-of-clause () + "Move to the end of clause. +If already at the end of clause, move to next clause." + (interactive) + (let ((point (point)) + (new-point (prolog-clause-end))) + (if (and (<= new-point point) + (not (eq new-point (point-max)))) + (progn + (goto-char (1+ point)) + (goto-char (prolog-clause-end))) + (goto-char new-point)))) + +;; (defun prolog-next-clause () +;; "Move to the beginning of the next clause." +;; (interactive) +;; (prolog-end-of-clause) +;; (forward-char) +;; (prolog-end-of-clause) +;; (prolog-beginning-of-clause)) + +(defun prolog-beginning-of-predicate () + "Go to the nearest beginning of predicate before current point. +Return the final point or nil if no such a beginning was found." + (interactive) + (let ((op (point)) + (pos (prolog-pred-start))) + (if pos + (if (= op pos) + (if (not (bobp)) + (progn + (goto-char pos) + (backward-char 1) + (setq pos (prolog-pred-start)) + (if pos + (progn + (goto-char pos) + (point))))) + (goto-char pos) + (point))))) + +(defun prolog-end-of-predicate () + "Go to the end of the current predicate." + (interactive) + (let ((op (point))) + (goto-char (prolog-pred-end)) + (if (= op (point)) + (progn + (forward-line 1) + (prolog-end-of-predicate))))) + +(defun prolog-insert-predspec () + "Insert the predspec for the current predicate." + (interactive) + (let* ((pinfo (prolog-clause-info)) + (predname (nth 0 pinfo)) + (arity (nth 1 pinfo))) + (insert (format "%s/%d" predname arity)))) + +(defun prolog-view-predspec () + "Insert the predspec for the current predicate." + (interactive) + (let* ((pinfo (prolog-clause-info)) + (predname (nth 0 pinfo)) + (arity (nth 1 pinfo))) + (message (format "%s/%d" predname arity)))) + +(defun prolog-insert-predicate-template () + "Insert the template for the current clause." + (interactive) + (let* ((n 1) + oldp + (pinfo (prolog-clause-info)) + (predname (nth 0 pinfo)) + (arity (nth 1 pinfo))) + (insert predname) + (if (> arity 0) + (progn + (insert "(") + (when prolog-electric-dot-full-predicate-template + (setq oldp (point)) + (while (< n arity) + (insert ",") + (setq n (1+ n))) + (insert ")") + (goto-char oldp)) + )) + )) + +(defun prolog-insert-next-clause () + "Insert newline and the name of the current clause." + (interactive) + (insert "\n") + (prolog-insert-predicate-template)) + +(defun prolog-insert-module-modeline () + "Insert a modeline for module specification. +This line should be first in the buffer. +The module name should be written manually just before the semi-colon." + (interactive) + (insert "%%% -*- Module: ; -*-\n") + (backward-char 6)) + +(defalias 'prolog-uncomment-region + (if (fboundp 'uncomment-region) #'uncomment-region + (lambda (beg end) + "Uncomment the region between BEG and END." + (interactive "r") + (comment-region beg end -1)))) + +(defun prolog-goto-comment-column (&optional nocreate) + "Move comments on the current line to the correct position. +If NOCREATE is nil (or omitted) and there is no comment on the line, then +a new comment is created." + (interactive) + (beginning-of-line) + (if (or (not nocreate) + (and + (re-search-forward + (format "^\\(\\(%s\\|%s\\|[^\n\'\"%%]\\)*\\)%% *" + prolog-quoted-atom-regexp prolog-string-regexp) + (save-excursion (end-of-line) (point)) 'limit) + (progn + (goto-char (match-beginning 0)) + (not (eq (prolog-in-string-or-comment) 'txt))))) + (indent-for-comment))) + +(defun prolog-indent-predicate () + "*Indent the current predicate." + (interactive) + (indent-region (prolog-pred-start) (prolog-pred-end) nil)) + +(defun prolog-indent-buffer () + "*Indent the entire buffer." + (interactive) + (indent-region (point-min) (point-max) nil)) + +(defun prolog-mark-clause () + "Put mark at the end of this clause and move point to the beginning." + (interactive) + (let ((pos (point))) + (goto-char (prolog-clause-end)) + (forward-line 1) + (beginning-of-line) + (set-mark (point)) + (goto-char pos) + (goto-char (prolog-clause-start)))) + +(defun prolog-mark-predicate () + "Put mark at the end of this predicate and move point to the beginning." + (interactive) + (let (pos) + (goto-char (prolog-pred-end)) + (setq pos (point)) + (forward-line 1) + (beginning-of-line) + (set-mark (point)) + (goto-char pos) + (goto-char (prolog-pred-start)))) + +;; Stolen from `cc-mode.el': +(defun prolog-electric-delete (arg) + "Delete preceding character or whitespace. +If `prolog-hungry-delete-key-flag' is non-nil, then all preceding whitespace is +consumed. If however an ARG is supplied, or `prolog-hungry-delete-key-flag' is +nil, or point is inside a literal then the function in the variable +`backward-delete-char' is called." + (interactive "P") + (if (or (not prolog-hungry-delete-key-flag) + arg + (prolog-in-string-or-comment)) + (funcall 'backward-delete-char (prefix-numeric-value arg)) + (let ((here (point))) + (skip-chars-backward " \t\n") + (if (/= (point) here) + (delete-region (point) here) + (funcall 'backward-delete-char 1) + )))) + +;; For XEmacs compatibility (suggested by Per Mildner) +(put 'prolog-electric-delete 'pending-delete 'supersede) + +(defun prolog-electric-if-then-else (arg) + "If `prolog-electric-if-then-else-flag' is non-nil, indent if-then-else constructs. +Bound to the >, ; and ( keys." + (interactive "P") + (self-insert-command (prefix-numeric-value arg)) + (if prolog-electric-if-then-else-flag (prolog-insert-spaces-after-paren))) + +(defun prolog-electric-colon (arg) + "If `prolog-electric-colon-flag' is non-nil, insert the electric `:' construct. +That is, insert space (if appropriate), `:-' and newline if colon is pressed +at the end of a line that starts in the first column (i.e., clause +heads)." + (interactive "P") + (if (and prolog-electric-colon-flag + (null arg) + (eolp) + ;(not (string-match "^\\s " (thing-at-point 'line)))) + (not (string-match "^\\(\\s \\|%\\)" (thing-at-point 'line)))) + (progn + (unless (save-excursion (backward-char 1) (looking-at "\\s ")) + (insert " ")) + (insert ":-\n") + (prolog-indent-line)) + (self-insert-command (prefix-numeric-value arg)))) + +(defun prolog-electric-dash (arg) + "If `prolog-electric-dash-flag' is non-nil, insert the electric `-' construct. +that is, insert space (if appropriate), `-->' and newline if dash is pressed +at the end of a line that starts in the first column (i.e., DCG +heads)." + (interactive "P") + (if (and prolog-electric-dash-flag + (null arg) + (eolp) + ;(not (string-match "^\\s " (thing-at-point 'line)))) + (not (string-match "^\\(\\s \\|%\\)" (thing-at-point 'line)))) + (progn + (unless (save-excursion (backward-char 1) (looking-at "\\s ")) + (insert " ")) + (insert "-->\n") + (prolog-indent-line)) + (self-insert-command (prefix-numeric-value arg)))) + +(defun prolog-electric-dot (arg) + "Insert dot and newline or a head of a new clause. + +If `prolog-electric-dot-flag' is nil, then simply insert dot. +Otherwise:: +When invoked at the end of nonempty line, insert dot and newline. +When invoked at the end of an empty line, insert a recursive call to +the current predicate. +When invoked at the beginning of line, insert a head of a new clause +of the current predicate. + +When called with prefix argument ARG, insert just dot." + (interactive "P") + ;; Check for situations when the electricity should not be active + (if (or (not prolog-electric-dot-flag) + arg + (prolog-in-string-or-comment) + ;; Do not be electric in a floating point number or an operator + (not + (or + ;; (re-search-backward + ;; ###### + ;; "\\(^\\|[])}a-zA-Z_!'0-9]+\\)[ \t]*\\=" nil t))) + (save-excursion + (re-search-backward + ;; "\\(^\\|[])}_!'0-9]+\\)[ \t]*\\=" nil t))) + "\\(^\\|[])}_!'0-9]+\\)[ \t]*\\=" + nil t)) + (save-excursion + (re-search-backward + ;; "\\(^\\|[])}a-zA-Z]+\\)[ \t]*\\=" nil t))) + (format "\\(^\\|[])}%s]+\\)[ \t]*\\=" + prolog-lower-case-string) ;FIXME: [:lower:] + nil t)) + (save-excursion + (re-search-backward + ;; "\\(^\\|[])}a-zA-Z]+\\)[ \t]*\\=" nil t))) + (format "\\(^\\|[])}%s]+\\)[ \t]*\\=" + prolog-upper-case-string) ;FIXME: [:upper:] + nil t)) + ) + ) + ;; Do not be electric if inside a parenthesis pair. + (not (= (prolog-region-paren-balance (prolog-clause-start) (point)) + 0)) + ) + (funcall 'self-insert-command (prefix-numeric-value arg)) + (cond + ;; Beginning of line + ((bolp) + (prolog-insert-predicate-template)) + ;; At an empty line with at least one whitespace + ((save-excursion + (beginning-of-line) + (looking-at "[ \t]+$")) + (prolog-insert-predicate-template) + (when prolog-electric-dot-full-predicate-template + (save-excursion + (end-of-line) + (insert ".\n")))) + ;; Default + (t + (insert ".\n")) + ))) + +(defun prolog-electric-underscore () + "Replace variable with an underscore. +If `prolog-electric-underscore-flag' is non-nil and the point is +on a variable then replace the variable with underscore and skip +the following comma and whitespace, if any. +If the point is not on a variable then insert underscore." + (interactive) + (if prolog-electric-underscore-flag + (let (;start + (oldcase case-fold-search) + (oldp (point))) + (setq case-fold-search nil) + ;; ###### + ;;(skip-chars-backward "a-zA-Z_") + (skip-chars-backward + (format "%s%s_" + ;; FIXME: Why not "a-zA-Z"? + prolog-lower-case-string + prolog-upper-case-string)) + + ;(setq start (point)) + (if (and (not (prolog-in-string-or-comment)) + ;; ###### + ;; (looking-at "\\<[_A-Z][a-zA-Z_0-9]*\\>")) + (looking-at (format "\\<[_%s][%s%s_0-9]*\\>" + ;; FIXME: Use [:upper:] and friends. + prolog-upper-case-string + prolog-lower-case-string + prolog-upper-case-string))) + (progn + (replace-match "_") + (skip-chars-forward ", \t\n")) + (goto-char oldp) + (self-insert-command 1)) + (setq case-fold-search oldcase) + ) + (self-insert-command 1)) + ) + + +(defun prolog-find-term (functor arity &optional prefix) + "Go to the position at the start of the next occurance of a term. +The term is specified with FUNCTOR and ARITY. The optional argument +PREFIX is the prefix of the search regexp." + (let* (;; If prefix is not set then use the default "\\<" + (prefix (if (not prefix) + "\\<" + prefix)) + (regexp (concat prefix functor)) + (i 1)) + + ;; Build regexp for the search if the arity is > 0 + (if (= arity 0) + ;; Add that the functor must be at the end of a word. This + ;; does not work if the arity is > 0 since the closing ) + ;; is not a word constituent. + (setq regexp (concat regexp "\\>")) + ;; Arity is > 0, add parens and commas + (setq regexp (concat regexp "(")) + (while (< i arity) + (setq regexp (concat regexp ".+,")) + (setq i (1+ i))) + (setq regexp (concat regexp ".+)"))) + + ;; Search, and return position + (if (re-search-forward regexp nil t) + (goto-char (match-beginning 0)) + (error "Term not found")) + )) + +(defun prolog-variables-to-anonymous (beg end) + "Replace all variables within a region BEG to END by anonymous variables." + (interactive "r") + (save-excursion + (let ((oldcase case-fold-search)) + (setq case-fold-search nil) + (goto-char end) + (while (re-search-backward "\\<[A-Z_][a-zA-Z_0-9]*\\>" beg t) + (progn + (replace-match "_") + (backward-char))) + (setq case-fold-search oldcase) + ))) + + +(defun prolog-set-atom-regexps () + "Set the `prolog-atom-char-regexp' and `prolog-atom-regexp' variables. +Must be called after `prolog-build-case-strings'." + (setq prolog-atom-char-regexp + (format "[%s%s0-9_$]" + ;; FIXME: why not a-zA-Z? + prolog-lower-case-string + prolog-upper-case-string)) + (setq prolog-atom-regexp + (format "[%s$]%s*" + prolog-lower-case-string + prolog-atom-char-regexp)) + ) + +(defun prolog-build-case-strings () + "Set `prolog-upper-case-string' and `prolog-lower-case-string'. +Uses the current case-table for extracting the relevant information." + (let ((up_string "") + (low_string "")) + ;; Use `map-char-table' if it is defined. Otherwise enumerate all + ;; numbers between 0 and 255. `map-char-table' is probably safer. + ;; + ;; `map-char-table' causes problems under Emacs 23.0.0.1, the + ;; while loop seems to do its job well (Ryszard Szopa) + ;; + ;;(if (and (not (featurep 'xemacs)) + ;; (fboundp 'map-char-table)) + ;; (map-char-table + ;; (lambda (key value) + ;; (cond + ;; ((and + ;; (eq (prolog-int-to-char key) (downcase key)) + ;; (eq (prolog-int-to-char key) (upcase key))) + ;; ;; Do nothing if upper and lower case are the same + ;; ) + ;; ((eq (prolog-int-to-char key) (downcase key)) + ;; ;; The char is lower case + ;; (setq low_string (format "%s%c" low_string key))) + ;; ((eq (prolog-int-to-char key) (upcase key)) + ;; ;; The char is upper case + ;; (setq up_string (format "%s%c" up_string key))) + ;; )) + ;; (current-case-table)) + ;; `map-char-table' was undefined. + (let ((key 0)) + (while (< key 256) + (cond + ((and + (eq (prolog-int-to-char key) (downcase key)) + (eq (prolog-int-to-char key) (upcase key))) + ;; Do nothing if upper and lower case are the same + ) + ((eq (prolog-int-to-char key) (downcase key)) + ;; The char is lower case + (setq low_string (format "%s%c" low_string key))) + ((eq (prolog-int-to-char key) (upcase key)) + ;; The char is upper case + (setq up_string (format "%s%c" up_string key))) + ) + (setq key (1+ key)))) + ;; ) + ;; The strings are single-byte strings + (setq prolog-upper-case-string (prolog-dash-letters up_string)) + (setq prolog-lower-case-string (prolog-dash-letters low_string)) + )) + +;(defun prolog-regexp-dash-continuous-chars (chars) +; (let ((ints (mapcar #'prolog-char-to-int (string-to-list chars))) +; (beg 0) +; (end 0)) +; (if (null ints) +; chars +; (while (and (< (+ beg 1) (length chars)) +; (not (or (= (+ (nth beg ints) 1) (nth (+ beg 1) ints)) +; (= (nth beg ints) (nth (+ beg 1) ints))))) +; (setq beg (+ beg 1))) +; (setq beg (+ beg 1) +; end beg) +; (while (and (< (+ end 1) (length chars)) +; (or (= (+ (nth end ints) 1) (nth (+ end 1) ints)) +; (= (nth end ints) (nth (+ end 1) ints)))) +; (setq end (+ end 1))) +; (if (equal (substring chars end) "") +; (substring chars 0 beg) +; (concat (substring chars 0 beg) "-" +; (prolog-regexp-dash-continuous-chars (substring chars end)))) +; ))) + +(defun prolog-ints-intervals (ints) + "Return a list of intervals (from . to) covering INTS." + (when ints + (setq ints (sort ints '<)) + (let ((prev (car ints)) + (interval-start (car ints)) + intervals) + (while ints + (let ((next (car ints))) + (when (> next (1+ prev)) ; start of new interval + (setq intervals (cons (cons interval-start prev) intervals)) + (setq interval-start next)) + (setq prev next) + (setq ints (cdr ints)))) + (setq intervals (cons (cons interval-start prev) intervals)) + (reverse intervals)))) + +(defun prolog-dash-letters (string) + "Return a condensed regexp covering all letters in STRING." + (let ((intervals (prolog-ints-intervals (mapcar #'prolog-char-to-int + (string-to-list string)))) + codes) + (while intervals + (let* ((i (car intervals)) + (from (car i)) + (to (cdr i)) + (c (cond ((= from to) `(,from)) + ((= (1+ from) to) `(,from ,to)) + (t `(,from ?- ,to))))) + (setq codes (cons c codes))) + (setq intervals (cdr intervals))) + (apply 'concat (reverse codes)))) + +;(defun prolog-condense-character-sets (regexp) +; "Condense adjacent characters in character sets of REGEXP." +; (let ((next -1)) +; (while (setq next (string-match "\\[\\(.*?\\)\\]" regexp (1+ next))) +; (setq regexp (replace-match (prolog-dash-letters (match-string 1 regexp)) +; t t regexp 1)))) +; regexp) + +;; GNU Emacs compatibility: GNU Emacs does not differentiate between +;; ints and chars, or at least these two are interchangeable. +(defalias 'prolog-int-to-char + (if (fboundp 'int-to-char) #'int-to-char #'identity)) + +(defalias 'prolog-char-to-int + (if (fboundp 'char-to-int) #'char-to-int #'identity)) + +;;------------------------------------------------------------------- +;; Menu stuff (both for the editing buffer and for the inferior +;; prolog buffer) +;;------------------------------------------------------------------- + +(unless (fboundp 'region-exists-p) + (defun region-exists-p () + "Non-nil iff the mark is set. Lobotomized version for Emacsen that do not provide their own." + (mark))) + +(defun prolog-menu () + "Create the menus for the Prolog editing buffers. +These menus are dynamically created because one may change systems +during the life of an Emacs session, and because GNU Emacs wants them +so by ignoring `easy-menu-add'." + + ;; GNU Emacs ignores `easy-menu-add' so the order in which the menus + ;; are defined _is_ important! + + (easy-menu-define + prolog-edit-menu-help (current-local-map) + "Help menu for the Prolog mode." + (append + (if (featurep 'xemacs) '("Help") '("Prolog-help")) + (cond + ((eq prolog-system 'sicstus) + '(["On predicate" prolog-help-on-predicate t] + "---")) + ((eq prolog-system 'swi) + '(["On predicate" prolog-help-on-predicate t] + ["Apropos" prolog-help-apropos t] + "---"))) + '(["Describe mode" describe-mode t]))) + + (easy-menu-define + prolog-edit-menu-runtime (current-local-map) + "Runtime Prolog commands available from the editing buffer" + (append + ;; runtime menu name + (list (cond ((eq prolog-system 'eclipse) + "ECLiPSe") + ((eq prolog-system 'mercury) + "Mercury") + (t + "Prolog"))) + ;; consult items, NIL for mercury + (unless (eq prolog-system 'mercury) + '("---" + ["Consult file" prolog-consult-file t] + ["Consult buffer" prolog-consult-buffer t] + ["Consult region" prolog-consult-region (region-exists-p)] + ["Consult predicate" prolog-consult-predicate t] + )) + ;; compile items, NIL for everything but SICSTUS + (when (eq prolog-system 'sicstus) + '("---" + ["Compile file" prolog-compile-file t] + ["Compile buffer" prolog-compile-buffer t] + ["Compile region" prolog-compile-region (region-exists-p)] + ["Compile predicate" prolog-compile-predicate t] + )) + ;; debug items, NIL for mercury + (cond + ((eq prolog-system 'sicstus) + ;; In SICStus, these are pairwise disjunctive, + ;; so it's enough with one "off"-command + (if (prolog-atleast-version '(3 . 7)) + (list "---" + ["Debug" prolog-debug-on t] + ["Trace" prolog-trace-on t] + ["Zip" prolog-zip-on t] + ["All debug off" prolog-debug-off t] + '("Source level debugging" + ["Enable" prolog-enable-sicstus-sd t] + ["Disable" prolog-disable-sicstus-sd t])) + (list "---" + ["Debug" prolog-debug-on t] + ["Trace" prolog-trace-on t] + ["All debug off" prolog-debug-off t]))) + ((not (eq prolog-system 'mercury)) + '("---" + ["Debug" prolog-debug-on t] + ["Debug off" prolog-debug-off t] + ["Trace" prolog-trace-on t] + ["Trace off" prolog-trace-off t])) + ;; default (mercury) nil + ) + (list "---" + (if (featurep 'xemacs) + [(concat "Run " (cond ((eq prolog-system 'eclipse) "ECLiPSe") + ((eq prolog-system 'mercury) "Mercury") + (t "Prolog"))) + run-prolog t] + ["Run Prolog" run-prolog t])))) + + (easy-menu-define + prolog-edit-menu-insert-move (current-local-map) + "Commands for Prolog code manipulation." + (append + (list "Code" + ["Comment region" comment-region (region-exists-p)] + ["Uncomment region" prolog-uncomment-region (region-exists-p)] + ["Add comment/move to comment" indent-for-comment t]) + (unless (eq prolog-system 'mercury) + (list ["Convert variables in region to '_'" prolog-variables-to-anonymous (region-exists-p)])) + (list "---" + ["Insert predicate template" prolog-insert-predicate-template t] + ["Insert next clause head" prolog-insert-next-clause t] + ["Insert predicate spec" prolog-insert-predspec t] + ["Insert module modeline" prolog-insert-module-modeline t] + "---" + ["Beginning of clause" prolog-beginning-of-clause t] + ["End of clause" prolog-end-of-clause t] + ["Beginning of predicate" prolog-beginning-of-predicate t] + ["End of predicate" prolog-end-of-predicate t] + "---" + ["Indent line" prolog-indent-line t] + ["Indent region" indent-region (region-exists-p)] + ["Indent predicate" prolog-indent-predicate t] + ["Indent buffer" prolog-indent-buffer t] + ["Align region" align (region-exists-p)] + "---" + ["Mark clause" prolog-mark-clause t] + ["Mark predicate" prolog-mark-predicate t] + ["Mark paragraph" mark-paragraph t] + ;"---" + ;["Fontify buffer" font-lock-fontify-buffer t] + ))) + + (easy-menu-add prolog-edit-menu-insert-move) + (easy-menu-add prolog-edit-menu-runtime) + + ;; Add predicate index menu + ;(make-variable-buffer-local 'imenu-create-index-function) + (make-local-variable 'imenu-create-index-function) + (setq imenu-create-index-function 'imenu-default-create-index-function) + ;;Milan (this has problems with object methods...) ###### Does it? (Stefan) + (setq imenu-prev-index-position-function 'prolog-beginning-of-predicate) + (setq imenu-extract-index-name-function 'prolog-get-predspec) + + (if (and prolog-imenu-flag + (< (count-lines (point-min) (point-max)) prolog-imenu-max-lines)) + (imenu-add-to-menubar "Predicates")) + + (easy-menu-add prolog-edit-menu-help)) + +(defun prolog-inferior-menu () + "Create the menus for the Prolog inferior buffer. +This menu is dynamically created because one may change systems during +the life of an Emacs session." + + (easy-menu-define + prolog-inferior-menu-help (current-local-map) + "Help menu for the Prolog inferior mode." + (append + (if (featurep 'xemacs) '("Help") '("Prolog-help")) + (cond + ((eq prolog-system 'sicstus) + '(["On predicate" prolog-help-on-predicate t] + "---")) + ((eq prolog-system 'swi) + '(["On predicate" prolog-help-on-predicate t] + ["Apropos" prolog-help-apropos t] + "---"))) + '(["Describe mode" describe-mode t]))) + + (easy-menu-define + prolog-inferior-menu-all (current-local-map) + "Menu for the inferior Prolog buffer." + (append + ;; menu name + (list (cond ((eq prolog-system 'eclipse) + "ECLiPSe") + ((eq prolog-system 'mercury) + "Mercury") + (t + "Prolog"))) + ;; debug items, NIL for mercury + (cond + ((eq prolog-system 'sicstus) + ;; In SICStus, these are pairwise disjunctive, + ;; so it's enough with one "off"-command + (if (prolog-atleast-version '(3 . 7)) + (list "---" + ["Debug" prolog-debug-on t] + ["Trace" prolog-trace-on t] + ["Zip" prolog-zip-on t] + ["All debug off" prolog-debug-off t] + '("Source level debugging" + ["Enable" prolog-enable-sicstus-sd t] + ["Disable" prolog-disable-sicstus-sd t])) + (list "---" + ["Debug" prolog-debug-on t] + ["Trace" prolog-trace-on t] + ["All debug off" prolog-debug-off t]))) + ((not (eq prolog-system 'mercury)) + '("---" + ["Debug" prolog-debug-on t] + ["Debug off" prolog-debug-off t] + ["Trace" prolog-trace-on t] + ["Trace off" prolog-trace-off t])) + ;; default (mercury) nil + ) + ;; runtime + '("---" + ["Interrupt Prolog" comint-interrupt-subjob t] + ["Quit Prolog" comint-quit-subjob t] + ["Kill Prolog" comint-kill-subjob t]) + )) + + (easy-menu-add prolog-inferior-menu-all) + (easy-menu-add prolog-inferior-menu-help)) + +(add-hook 'prolog-mode-hook 'prolog-menu) ;FIXME. +(add-hook 'prolog-inferior-mode-hook 'prolog-inferior-menu) ;FIXME. + +(defun prolog-mode-version () + "Echo the current version of Prolog mode in the minibuffer." + (interactive) + (message "Using Prolog mode version %s" prolog-mode-version)) (provide 'prolog)
--- a/lisp/subr.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/subr.el Tue Jan 11 21:57:19 2011 -0800 @@ -1,7 +1,7 @@ ;;; subr.el --- basic lisp subroutines for Emacs ;; Copyright (C) 1985, 1986, 1992, 1994, 1995, 1999, 2000, 2001, 2002, 2003, -;; 2004, 2005, 2006, 2007, 2008, 2009, 2010 +;; 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011 ;; Free Software Foundation, Inc. ;; Maintainer: FSF @@ -60,7 +60,7 @@ `defstruct'. To specify a value for FILEONLY without passing an argument list, -set ARGLIST to `t'. This is necessary because `nil' means an +set ARGLIST to t. This is necessary because nil means an empty argument list, rather than an unspecified one. Note that for the purposes of `check-declare', this statement @@ -483,6 +483,7 @@ (read-kbd-macro keys)) (defun undefined () + "Beep to tell the user this binding is undefined." (interactive) (ding)) @@ -1599,11 +1600,7 @@ this name matching. Alternatively, FILE can be a feature (i.e. a symbol), in which case FORM -is evaluated whenever that feature is `provide'd. Note that although -provide statements are usually at the end of files, this is not always -the case (e.g., sometimes they are at the start to avoid a recursive -load error). If your FORM should not be evaluated until the code in -FILE has been, do not use the symbol form for FILE in such cases. +is evaluated at the end of any file that `provide's this feature. Usually FILE is just a library name like \"font-lock\" or a feature name like 'font-lock. @@ -1612,11 +1609,27 @@ ;; Add this FORM into after-load-alist (regardless of whether we'll be ;; evaluating it now). (let* ((regexp-or-feature - (if (stringp file) (setq file (purecopy (load-history-regexp file))) file)) + (if (stringp file) + (setq file (purecopy (load-history-regexp file))) + file)) (elt (assoc regexp-or-feature after-load-alist))) (unless elt (setq elt (list regexp-or-feature)) (push elt after-load-alist)) + (when (symbolp regexp-or-feature) + ;; For features, the after-load-alist elements get run when `provide' is + ;; called rather than at the end of the file. So add an indirection to + ;; make sure that `form' is really run "after-load" in case the provide + ;; call happens early. + (setq form + `(when load-file-name + (let ((fun (make-symbol "eval-after-load-helper"))) + (fset fun `(lambda (file) + (if (not (equal file ',load-file-name)) + nil + (remove-hook 'after-load-functions ',fun) + ,',form))) + (add-hook 'after-load-functions fun))))) ;; Add FORM to the element unless it's already there. (unless (member form (cdr elt)) (nconc elt (purecopy (list form)))) @@ -1872,7 +1885,7 @@ The user ends with RET, LFD, or ESC. DEL or C-h rubs out. C-y yanks the current kill. C-u kills line. C-g quits; if `inhibit-quit' was non-nil around this function, -then it returns nil if the user types C-g, but quit-flag remains set. +then it returns nil if the user types C-g, but `quit-flag' remains set. Once the caller uses the password, it can erase the password by doing (clear-string STRING)." @@ -1985,7 +1998,7 @@ (unless (get-text-property 0 'face prompt) (setq prompt (propertize prompt 'face 'minibuffer-prompt))) (setq char (let ((inhibit-quit inhibit-keyboard-quit)) - (read-event prompt))) + (read-key prompt))) (cond ((not (numberp char))) ((memq char chars) @@ -2043,8 +2056,11 @@ (defun y-or-n-p (prompt &rest args) "Ask user a \"y or n\" question. Return t if answer is \"y\". -The argument PROMPT is the string to display to ask the question. -It should end in a space; `y-or-n-p' adds `(y or n) ' to it. +The string to display to ask the question is obtained by +formatting the string PROMPT with arguments ARGS (see `format'). +The result should end in a space; `y-or-n-p' adds \"(y or n) \" +to it. + No confirmation of the answer is requested; a single character is enough. Also accepts Space to mean yes, or Delete to mean no. \(Actually, it uses the bindings in `query-replace-map'; see the documentation of that variable @@ -2493,7 +2509,7 @@ (defvar yank-undo-function) (defun insert-for-yank (string) - "Calls `insert-for-yank-1' repetitively for each `yank-handler' segment. + "Call `insert-for-yank-1' repetitively for each `yank-handler' segment. See `insert-for-yank-1' for more details." (let (to) @@ -3177,7 +3193,7 @@ REP is either a string used as the NEWTEXT arg of `replace-match' or a function. If it is a function, it is called with the actual text of each match, and its value is used as the replacement text. When REP is called, -the match-data are the result of matching REGEXP against a substring +the match data are the result of matching REGEXP against a substring of STRING. To replace only the first match (if any), make REGEXP match up to \\'
--- a/lisp/tool-bar.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/tool-bar.el Tue Jan 11 21:57:19 2011 -0800 @@ -254,7 +254,7 @@ (tool-bar-add-item-from-menu 'save-buffer "save" nil :label "Save") (define-key-after (default-value 'tool-bar-map) [separator-1] menu-bar-separator) - (tool-bar-add-item-from-menu 'undo "undo" nil :vert-only t) + (tool-bar-add-item-from-menu 'undo "undo" nil) (define-key-after (default-value 'tool-bar-map) [separator-2] menu-bar-separator) (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [cut]) "cut" nil :vert-only t) @@ -263,25 +263,22 @@ (tool-bar-add-item-from-menu (lookup-key menu-bar-edit-menu [paste]) "paste" nil :vert-only t) (define-key-after (default-value 'tool-bar-map) [separator-3] menu-bar-separator) - (tool-bar-add-item-from-menu 'nonincremental-search-forward "search" - nil :label "Search") + (tool-bar-add-item-from-menu 'isearch-forward "search" + nil :label "Search" :vert-only t) ;;(tool-bar-add-item-from-menu 'ispell-buffer "spell") ;; There's no icon appropriate for News and we need a command rather ;; than a lambda for Read Mail. ;;(tool-bar-add-item-from-menu 'compose-mail "mail/compose") - - ;; tool-bar-add-item-from-menu itself operates on - ;; (default-value 'tool-bar-map), but when we don't use that function, - ;; we must explicitly operate on the default value. - - (let ((tool-bar-map (default-value 'tool-bar-map))) - (tool-bar-add-item "help" (lambda () - (interactive) - (popup-menu menu-bar-help-menu)) - 'help - :help "Pop up the Help menu"))) + ;; Help button on a tool bar is rather non-standard... + ;; (let ((tool-bar-map (default-value 'tool-bar-map))) + ;; (tool-bar-add-item "help" (lambda () + ;; (interactive) + ;; (popup-menu menu-bar-help-menu)) + ;; 'help + ;; :help "Pop up the Help menu")) +) (if (featurep 'move-toolbar) (defcustom tool-bar-position 'top
--- a/lisp/vc/vc-dir.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/vc/vc-dir.el Tue Jan 11 21:57:19 2011 -0800 @@ -196,7 +196,7 @@ '(menu-item "Show Incoming Log" vc-log-incoming :help "Show a log of changes that will be received with a pull operation")) (define-key map [log] - '(menu-item "Show history" vc-print-log + '(menu-item "Show History" vc-print-log :help "List the change log of the current file set in a window")) (define-key map [rlog] '(menu-item "Show Top of the Tree History " vc-print-root-log @@ -307,33 +307,36 @@ (defvar vc-dir-tool-bar-map (let ((map (make-sparse-keymap))) - (tool-bar-local-item-from-menu 'vc-dir-find-file "open" - map vc-dir-mode-map) - (tool-bar-local-item "bookmark_add" - 'vc-dir-toggle-mark 'vc-dir-toggle-mark map - :help "Toggle mark on current item" - :label "Toggle Mark") - (tool-bar-local-item-from-menu 'vc-dir-previous-line "left-arrow" - map vc-dir-mode-map - :rtl "right-arrow") - (tool-bar-local-item-from-menu 'vc-dir-next-line "right-arrow" - map vc-dir-mode-map - :rtl "left-arrow") + (tool-bar-local-item-from-menu 'find-file "new" map nil + :label "New File" :vert-only t) + (tool-bar-local-item-from-menu 'menu-find-file-existing "open" map nil + :label "Open" :vert-only t) + (tool-bar-local-item-from-menu 'dired "diropen" map nil + :vert-only t) + (tool-bar-local-item-from-menu 'quit-window "close" map vc-dir-mode-map + :vert-only t) + (tool-bar-local-item-from-menu 'vc-next-action "saveas" map + vc-dir-mode-map :label "Commit") (tool-bar-local-item-from-menu 'vc-print-log "info" - map vc-dir-mode-map) - (tool-bar-local-item-from-menu 'revert-buffer "refresh" - map vc-dir-mode-map) - (tool-bar-local-item-from-menu 'nonincremental-search-forward - "search" map nil - :label "Search") - (tool-bar-local-item-from-menu 'vc-dir-query-replace-regexp - "search-replace" map vc-dir-mode-map - :label "Replace") + map vc-dir-mode-map + :label "Log") + (define-key-after map [separator-1] menu-bar-separator) (tool-bar-local-item-from-menu 'vc-dir-kill-dir-status-process "cancel" map vc-dir-mode-map - :label "Cancel") - (tool-bar-local-item-from-menu 'quit-window "exit" - map vc-dir-mode-map) + :label "Stop" :vert-only t) + (tool-bar-local-item-from-menu 'revert-buffer "refresh" + map vc-dir-mode-map :vert-only t) + (define-key-after map [separator-2] menu-bar-separator) + (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [cut]) + "cut" map nil :vert-only t) + (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [copy]) + "copy" map nil :vert-only t) + (tool-bar-local-item-from-menu (lookup-key menu-bar-edit-menu [paste]) + "paste" map nil :vert-only t) + (define-key-after map [separator-3] menu-bar-separator) + (tool-bar-local-item-from-menu 'isearch-forward + "search" map nil + :label "Search" :vert-only t) map)) (defun vc-dir-node-directory (node)
--- a/lisp/wid-edit.el Sun Jan 09 00:42:24 2011 -0800 +++ b/lisp/wid-edit.el Tue Jan 11 21:57:19 2011 -0800 @@ -2162,21 +2162,13 @@ (defun widget-toggle-value-create (widget) "Insert text representing the `on' and `off' states." - (if (widget-value widget) - (let ((image (widget-get widget :on-glyph))) - (and (display-graphic-p) - (listp image) - (not (eq (car image) 'image)) - (widget-put widget :on-glyph (setq image (eval image)))) - (widget-image-insert widget - (widget-get widget :on) - image)) - (let ((image (widget-get widget :off-glyph))) - (and (display-graphic-p) - (listp image) - (not (eq (car image) 'image)) - (widget-put widget :off-glyph (setq image (eval image)))) - (widget-image-insert widget (widget-get widget :off) image)))) + (let* ((val (widget-value widget)) + (text (widget-get widget (if val :on :off))) + (img (widget-image-find + (widget-get widget (if val :on-glyph :off-glyph))))) + (widget-image-insert widget (or text "") + (if img + (append img '(:ascent center)))))) (defun widget-toggle-action (widget &optional event) ;; Toggle value. @@ -2816,34 +2808,22 @@ "An indicator and manipulator for hidden items. The following properties have special meanings for this widget: -:on-image Image filename or spec to display when the item is visible. +:on-glyph Image filename or spec to display when the item is visible. :on Text shown if the \"on\" image is nil or cannot be displayed. -:off-image Image filename or spec to display when the item is hidden. +:off-glyph Image filename or spec to display when the item is hidden. :off Text shown if the \"off\" image is nil cannot be displayed." :format "%[%v%]" :button-prefix "" :button-suffix "" - :on-image "down" + :on-glyph "down" :on "Hide" - :off-image "right" + :off-glyph "right" :off "Show" :value-create 'widget-visibility-value-create :action 'widget-toggle-action :match (lambda (widget value) t)) -(defun widget-visibility-value-create (widget) - ;; Insert text representing the `on' and `off' states. - (let* ((val (widget-value widget)) - (text (widget-get widget (if val :on :off))) - (img (widget-image-find - (widget-get widget (if val :on-image :off-image))))) - (widget-image-insert widget - (if text - (concat widget-push-button-prefix text - widget-push-button-suffix) - "") - (if img - (append img '(:ascent center)))))) +(defalias 'widget-visibility-value-create 'widget-toggle-value-create) ;;; The `documentation-link' Widget. ;;
--- a/src/ChangeLog Sun Jan 09 00:42:24 2011 -0800 +++ b/src/ChangeLog Tue Jan 11 21:57:19 2011 -0800 @@ -1,4 +1,4 @@ -2011-01-09 Paul Eggert <eggert@cs.ucla.edu> +2011-01-11 Paul Eggert <eggert@cs.ucla.edu> Give a name FLOAT_TO_STRING_BUFSIZE to the constant 350. * lisp.h (FLOAT_TO_STRING_BUFSIZE): New macro. @@ -27,14 +27,50 @@ (float_to_string): Use dtoastr rather than rolling our own code, which had an off-by-one bug on non-IEEE hosts. -2011-01-08 Paul Eggert <eggert@cs.ucla.edu> - Automate syncing from gnulib. * Makefile.in (lib): New macro. (ALL_CFLAGS): Add -I$(lib) -I$(srcdir)/../lib. ($(lib)/libgnu.a): New rule. (temacs$(EXEEXT)): Also link $(lib)/libgnu.a. +2011-01-11 Tassilo Horn <tassilo@member.fsf.org> + + * image.c (imagemagick_load_image, Finit_image_library): Free + intermediate image after creating a MagickWand from it. Terminate + MagickWand environment after image loading. + +2011-01-10 Michael Albinus <michael.albinus@gmx.de> + + * dbusbind.c (Fdbus_register_service): Raise an error in case of + unexpected return values. + (Fdbus_register_method): Remove connection initialization. + +2011-01-10 Jan Moringen <jan.moringen@uni-bielefeld.de> + + * dbusbind.c (QCdbus_request_name_allow_replacement): New symbol; + used by Fdbus_register_service. + (QCdbus_request_name_replace_existing): Likewise. + (QCdbus_request_name_do_not_queue): Likewise. + (QCdbus_request_name_reply_primary_owner): Likewise. + (QCdbus_request_name_reply_in_queue): Likewise. + (QCdbus_request_name_reply_exists): Likewise. + (QCdbus_request_name_reply_already_owner): Likewise. + (Fdbus_register_service): New function. + (Fdbus_register_method): Use Fdbus_register_service to do the name + registration. + (syms_of_dbusbind): Add symbols dbus-register-service, + :allow-replacement, :replace-existing, :do-not-queue, + :primary-owner, :existing, :in-queue and :already-owner. + +2011-01-09 Chong Yidong <cyd@stupidchicken.com> + + * gtkutil.c (update_frame_tool_bar): Don't advance tool-bar index + when removing extra buttons. + +2011-01-08 Chong Yidong <cyd@stupidchicken.com> + + * fns.c (Fyes_or_no_p): Doc fix. + 2011-01-08 Andreas Schwab <schwab@linux-m68k.org> * fns.c (Fyes_or_no_p): Add usage.
--- a/src/dbusbind.c Sun Jan 09 00:42:24 2011 -0800 +++ b/src/dbusbind.c Tue Jan 11 21:57:19 2011 -0800 @@ -38,6 +38,7 @@ Lisp_Object Qdbus_method_return_internal; Lisp_Object Qdbus_method_error_internal; Lisp_Object Qdbus_send_signal; +Lisp_Object Qdbus_register_service; Lisp_Object Qdbus_register_signal; Lisp_Object Qdbus_register_method; @@ -50,6 +51,17 @@ /* Lisp symbol for method call timeout. */ Lisp_Object QCdbus_timeout; +/* Lisp symbols for name request flags. */ +Lisp_Object QCdbus_request_name_allow_replacement; +Lisp_Object QCdbus_request_name_replace_existing; +Lisp_Object QCdbus_request_name_do_not_queue; + +/* Lisp symbols for name request replies. */ +Lisp_Object QCdbus_request_name_reply_primary_owner; +Lisp_Object QCdbus_request_name_reply_in_queue; +Lisp_Object QCdbus_request_name_reply_exists; +Lisp_Object QCdbus_request_name_reply_already_owner; + /* Lisp symbols of D-Bus types. */ Lisp_Object QCdbus_type_byte, QCdbus_type_boolean; Lisp_Object QCdbus_type_int16, QCdbus_type_uint16; @@ -1835,6 +1847,114 @@ xd_in_read_queued_messages = 0; } +DEFUN ("dbus-register-service", Fdbus_register_service, Sdbus_register_service, + 2, MANY, 0, + doc: /* Register known name SERVICE on the D-Bus BUS. + +BUS is either a Lisp symbol, `:system' or `:session', or a string +denoting the bus address. + +SERVICE is the D-Bus service name that should be registered. It must +be a known name. + +FLAGS are keywords, which control how the service name is registered. +The following keywords are recognized: + +`:allow-replacement': Allow another service to become the primary +owner if requested. + +`:replace-existing': Request to replace the current primary owner. + +`:do-not-queue': If we can not become the primary owner do not place +us in the queue. + +The function returns a keyword, indicating the result of the +operation. One of the following keywords is returned: + +`:primary-owner': Service has become the primary owner of the +requested name. + +`:in-queue': Service could not become the primary owner and has been +placed in the queue. + +`:exists': Service is already in the queue. + +`:already-owner': Service is already the primary owner. + +Example: + +\(dbus-register-service :session dbus-service-emacs) + + => :primary-owner. + +\(dbus-register-service + :session "org.freedesktop.TextEditor" + dbus-service-allow-replacement dbus-service-replace-existing) + + => :already-owner. + +usage: (dbus-register-service BUS SERVICE &rest FLAGS) */) + (int nargs, register Lisp_Object *args) +{ + Lisp_Object bus, service; + struct gcpro gcpro1, gcpro2; + DBusConnection *connection; + unsigned int i; + unsigned int value; + unsigned int flags = 0; + int result; + DBusError derror; + + bus = args[0]; + service = args[1]; + + /* Check parameters. */ + CHECK_STRING (service); + + /* Process flags. */ + for (i = 2; i < nargs; ++i) { + value = ((EQ (args[i], QCdbus_request_name_replace_existing)) + ? DBUS_NAME_FLAG_REPLACE_EXISTING + : (EQ (args[i], QCdbus_request_name_allow_replacement)) + ? DBUS_NAME_FLAG_ALLOW_REPLACEMENT + : (EQ (args[i], QCdbus_request_name_do_not_queue)) + ? DBUS_NAME_FLAG_DO_NOT_QUEUE + : -1); + if (value == -1) + XD_SIGNAL2 (build_string ("Unrecognized name request flag"), args[i]); + flags |= value; + } + + /* Open a connection to the bus. */ + connection = xd_initialize (bus, TRUE); + + /* Request the known name from the bus. */ + dbus_error_init (&derror); + result = dbus_bus_request_name (connection, SDATA (service), flags, + &derror); + if (dbus_error_is_set (&derror)) + XD_ERROR (derror); + + /* Cleanup. */ + dbus_error_free (&derror); + + /* Return object. */ + switch (result) + { + case DBUS_REQUEST_NAME_REPLY_PRIMARY_OWNER: + return QCdbus_request_name_reply_primary_owner; + case DBUS_REQUEST_NAME_REPLY_IN_QUEUE: + return QCdbus_request_name_reply_in_queue; + case DBUS_REQUEST_NAME_REPLY_EXISTS: + return QCdbus_request_name_reply_exists; + case DBUS_REQUEST_NAME_REPLY_ALREADY_OWNER: + return QCdbus_request_name_reply_already_owner; + default: + /* This should not happen. */ + XD_SIGNAL2 (build_string ("Could not register service"), service); + } +} + DEFUN ("dbus-register-signal", Fdbus_register_signal, Sdbus_register_signal, 6, MANY, 0, doc: /* Register for signal SIGNAL on the D-Bus BUS. @@ -2011,9 +2131,8 @@ Lisp_Object dont_register_service) { Lisp_Object key, key1, value; - DBusConnection *connection; - int result; DBusError derror; + Lisp_Object args[2] = { bus, service }; /* Check parameters. */ CHECK_STRING (service); @@ -2025,21 +2144,9 @@ /* TODO: We must check for a valid service name, otherwise there is a segmentation fault. */ - /* Open a connection to the bus. */ - connection = xd_initialize (bus, TRUE); - - /* Request the known name from the bus. We can ignore the result, - it is set to -1 if there is an error - kind of redundancy. */ + /* Request the name. */ if (NILP (dont_register_service)) - { - dbus_error_init (&derror); - result = dbus_bus_request_name (connection, SDATA (service), 0, &derror); - if (dbus_error_is_set (&derror)) - XD_ERROR (derror); - - /* Cleanup. */ - dbus_error_free (&derror); - } + Fdbus_register_service (2, args); /* Create a hash table entry. We use nil for the unique name, because the method might be called from anybody. */ @@ -2091,6 +2198,10 @@ staticpro (&Qdbus_send_signal); defsubr (&Sdbus_send_signal); + Qdbus_register_service = intern_c_string ("dbus-register-service"); + staticpro (&Qdbus_register_service); + defsubr (&Sdbus_register_service); + Qdbus_register_signal = intern_c_string ("dbus-register-signal"); staticpro (&Qdbus_register_signal); defsubr (&Sdbus_register_signal); @@ -2112,6 +2223,27 @@ QCdbus_session_bus = intern_c_string (":session"); staticpro (&QCdbus_session_bus); + QCdbus_request_name_allow_replacement = intern_c_string (":allow-replacement"); + staticpro (&QCdbus_request_name_allow_replacement); + + QCdbus_request_name_replace_existing = intern_c_string (":replace-existing"); + staticpro (&QCdbus_request_name_replace_existing); + + QCdbus_request_name_do_not_queue = intern_c_string (":do-not-queue"); + staticpro (&QCdbus_request_name_do_not_queue); + + QCdbus_request_name_reply_primary_owner = intern_c_string (":primary-owner"); + staticpro (&QCdbus_request_name_reply_primary_owner); + + QCdbus_request_name_reply_exists = intern_c_string (":exists"); + staticpro (&QCdbus_request_name_reply_exists); + + QCdbus_request_name_reply_in_queue = intern_c_string (":in-queue"); + staticpro (&QCdbus_request_name_reply_in_queue); + + QCdbus_request_name_reply_already_owner = intern_c_string (":already-owner"); + staticpro (&QCdbus_request_name_reply_already_owner); + QCdbus_timeout = intern_c_string (":timeout"); staticpro (&QCdbus_timeout);
--- a/src/fns.c Sun Jan 09 00:42:24 2011 -0800 +++ b/src/fns.c Tue Jan 11 21:57:19 2011 -0800 @@ -2460,10 +2460,13 @@ DEFUN ("yes-or-no-p", Fyes_or_no_p, Syes_or_no_p, 1, MANY, 0, doc: /* Ask user a yes-or-no question. Return t if answer is yes. -Takes one argument, which is the string to display to ask the question. -It should end in a space; `yes-or-no-p' adds `(yes or no) ' to it. -The user must confirm the answer with RET, -and can edit it until it has been confirmed. +The string to display to ask the question is obtained by +formatting the string PROMPT with arguments ARGS (see `format'). +The result should end in a space; `yes-or-no-p' adds +\"(yes or no) \" to it. + +The user must confirm the answer with RET, and can edit it until it +has been confirmed. Under a windowing system a dialog box will be used if `last-nonmenu-event' is nil, and `use-dialog-box' is non-nil.
--- a/src/gtkutil.c Sun Jan 09 00:42:24 2011 -0800 +++ b/src/gtkutil.c Tue Jan 11 21:57:19 2011 -0800 @@ -4439,7 +4439,7 @@ /* Remove buttons not longer needed. */ do { - ti = gtk_toolbar_get_nth_item (GTK_TOOLBAR (wtoolbar), j++); + ti = gtk_toolbar_get_nth_item (GTK_TOOLBAR (wtoolbar), j); if (ti) gtk_container_remove (GTK_CONTAINER (wtoolbar), GTK_WIDGET (ti)); } while (ti != NULL);
--- a/src/image.c Sun Jan 09 00:42:24 2011 -0800 +++ b/src/image.c Tue Jan 11 21:57:19 2011 -0800 @@ -7518,6 +7518,9 @@ image. Interface :index is same as for GIF. First we "ping" the image to see how many sub-images it contains. Pinging is faster than loading the image to find out things about it. */ + + /* MagickWandGenesis() initializes the imagemagick library. */ + MagickWandGenesis (); image = image_spec_value (img->spec, QCindex, NULL); ino = INTEGERP (image) ? XFASTINT (image) : 0; ping_wand = NewMagickWand (); @@ -7546,6 +7549,7 @@ img->data.lisp_val)); DestroyMagickWand (ping_wand); + /* Now, after pinging, we know how many images are inside the file. If its not a bundle, just one. */ @@ -7563,6 +7567,7 @@ if (im_image != NULL) { image_wand = NewMagickWandFromImage (im_image); + DestroyImage(im_image); status = MagickTrue; } else @@ -7573,7 +7578,7 @@ image_wand = NewMagickWand (); status = MagickReadImageBlob (image_wand, contents, size); } - image_error ("im read failed", Qnil, Qnil); + if (status == MagickFalse) goto imagemagick_error; /* If width and/or height is set in the display spec assume we want @@ -7802,11 +7807,13 @@ /* Final cleanup. image_wand should be the only resource left. */ DestroyMagickWand (image_wand); + MagickWandTerminus (); return 1; imagemagick_error: DestroyMagickWand (image_wand); + MagickWandTerminus (); /* TODO more cleanup. */ image_error ("Error parsing IMAGEMAGICK image `%s'", img->spec, Qnil); return 0; @@ -8678,8 +8685,6 @@ #if defined (HAVE_IMAGEMAGICK) if (EQ (type, Qimagemagick)) { - /* MagickWandGenesis() initializes the imagemagick library. */ - MagickWandGenesis (); return CHECK_LIB_AVAILABLE (&imagemagick_type, init_imagemagick_functions, libraries); }