code:
## Process this file with automake to produce Makefile.in.
##
##  	Copyright (C) 2006, 2008 Free Software Foundation, Inc.
##
##   This file is part of GUILE.
##
##   GUILE is free software; you can redistribute it and/or modify
##   it under the terms of the GNU General Public License as
##   published by the Free Software Foundation; either version 2, or
##   (at your option) any later version.
##
##   GUILE 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 GUILE; see the file COPYING.  If not, write
##   to the Free Software Foundation, Inc., 51 Franklin Street, Fifth
##   Floor, Boston, MA 02110-1301 USA

AUTOMAKE_OPTIONS = gnu

dist_lisp_LISP = gds.el gds-server.el gds-scheme.el
ELCFILES =

ETAGS_ARGS = $(dist_lisp_LISP) ChangeLog-2008


code:
Index

gud-guile.el --- Support for debugging guile internals
guile-c.el --- Guile C editing commands
guile-scheme.el --- Guile Scheme editing mode
guile.el --- Emacs Guile interface
multistring.el --- editing multiline strings.
patch.el --- mail/apply a patch
ppexpand.el --- temporarily expanding macros in a pretty way.
update-changelog.el --- stitch rcs2log output to ChangeLog

Generated using: for f in *.el ; do sed -e 's/^....//g' -e '1q' $f ; done

path: emacs/README

license: unknown


code:
;;; gds-scheme.el -- GDS function for Scheme mode buffers

;;;; Copyright (C) 2005 Neil Jerram
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later
;;;; version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

(require 'comint)
(require 'scheme)
(require 'derived)
(require 'pp)

;;;; Maintaining an association between a Guile client process and a
;;;; set of Scheme mode buffers.

(defcustom gds-auto-create-utility-client t
  "Whether to automatically create a utility Guile client, and
associate the current buffer with it, if there are no existing Guile
clients available to GDS when the user does something that requires a
running Guile client."
  :type 'boolean
  :group 'gds)

(defcustom gds-auto-associate-single-client t
  "Whether to automatically associate the current buffer with an
existing Guile client, if there is only only client known to GDS when
the user does something that requires a running Guile client, and the
current buffer is not already associated with a Guile client."
  :type 'boolean
  :group 'gds)

(defcustom gds-auto-associate-last-client t
  "Whether to automatically associate the current buffer with the
Guile client that most recently caused that buffer to be displayed,
when the user does something that requires a running Guile client and
the current buffer is not already associated with a Guile client."
  :type 'boolean
  :group 'gds)

(defvar gds-last-touched-by nil
  "For each Scheme mode buffer, this records the GDS client that most
recently `touched' that buffer in the sense of using it to display
source code, for example for the source code relevant to a debugger
stack frame.")
(make-variable-buffer-local 'gds-last-touched-by)

(defun gds-auto-associate-buffer ()
  "Automatically associate the current buffer with a Guile client, if
possible."
  (let* ((num-clients (length gds-client-info))
	 (client
	  (or
	   ;; If there are no clients yet, and
	   ;; `gds-auto-create-utility-client' allows us to create one
	   ;; automatically, do that.
	   (and (= num-clients 0)
		gds-auto-create-utility-client
		(gds-start-utility-guile))
	   ;; Otherwise, if there is a single existing client, and
	   ;; `gds-auto-associate-single-client' allows us to use it
	   ;; for automatic association, do that.
	   (and (= num-clients 1)
		gds-auto-associate-single-client
		(caar gds-client-info))
	   ;; Otherwise, if the current buffer was displayed because
	   ;; of a Guile client trapping somewhere in its code, and
	   ;; `gds-auto-associate-last-client' allows us to associate
	   ;; with that client, do so.
	   (and gds-auto-associate-last-client
		gds-last-touched-by))))
    (if client
	(gds-associate-buffer client))))

(defun gds-associate-buffer (client)
  "Associate the current buffer with the Guile process CLIENT.
This means that operations in this buffer that require a running Guile
process - such as evaluation, help, completion and setting traps -
will be sent to the Guile process whose name or connection number is
CLIENT."
  (interactive (list (gds-choose-client)))
  ;; If this buffer is already associated, dissociate from its
  ;; existing client first.
  (if gds-client (gds-dissociate-buffer))
  ;; Store the client number in the buffer-local variable gds-client.
  (setq gds-client client)
  ;; Add this buffer to the list of buffers associated with the
  ;; client.
  (gds-client-put client 'associated-buffers
		  (cons (current-buffer)
			(gds-client-get client 'associated-buffers))))

(defun gds-dissociate-buffer ()
  "Dissociate the current buffer from any specific Guile process."
  (interactive)
  (if gds-client
      (progn
        ;; Remove this buffer from the list of buffers associated with
        ;; the current client.
	(gds-client-put gds-client 'associated-buffers
			(delq (current-buffer)
			      (gds-client-get gds-client 'associated-buffers)))
        ;; Reset the buffer-local variable gds-client.
        (setq gds-client nil)
        ;; Clear any process status indication from the modeline.
        (setq mode-line-process nil)
        (force-mode-line-update))))

(defun gds-show-client-status (client status-string)
  "Show a client's status in the modeline of all its associated
buffers."
  (let ((buffers (gds-client-get client 'associated-buffers)))
    (while buffers
      (if (buffer-live-p (car buffers))
          (with-current-buffer (car buffers)
            (setq mode-line-process status-string)
            (force-mode-line-update)))
      (setq buffers (cdr buffers)))))

(defcustom gds-running-text ":running"
  "*Mode line text used to show that a Guile process is \"running\".
\"Running\" means that the process cannot currently accept any input
from the GDS frontend in Emacs, because all of its threads are busy
running code that GDS cannot easily interrupt."
  :type 'string
  :group 'gds)

(defcustom gds-ready-text ":ready"
  "*Mode line text used to show that a Guile process is \"ready\".
\"Ready\" means that the process is ready to interact with the GDS
frontend in Emacs, because at least one of its threads is waiting for
GDS input."
  :type 'string
  :group 'gds)

(defcustom gds-debug-text ":debug"
  "*Mode line text used to show that a Guile process is \"debugging\".
\"Debugging\" means that the process is using the GDS frontend in
Emacs to display an error or trap so that the user can debug it."
  :type 'string
  :group 'gds)

(defun gds-choose-client ()
  "Ask the user to choose a GDS client process from a list."
  (let ((table '())
        (default nil))
    ;; Prepare a table containing all current clients.
    (mapcar (lambda (client-info)
               (setq table (cons (cons (cadr (memq 'name client-info))
				       (car client-info))
				 table)))
             gds-client-info)
    ;; Add an entry to allow the user to ask for a new process.
    (setq table (cons (cons "Start a new Guile process" nil) table))
    ;; Work out a good default.  If the buffer has a good value in
    ;; gds-last-touched-by, we use that; otherwise default to starting
    ;; a new process.
    (setq default (or (and gds-last-touched-by
                           (gds-client-get gds-last-touched-by 'name))
                      (caar table)))
    ;; Read using this table.
    (let* ((name (completing-read "Choose a Guile process: "
                                  table
                                  nil
                                  t     ; REQUIRE-MATCH
                                  nil   ; INITIAL-INPUT
                                  nil   ; HIST
                                  default))
           ;; Convert name to a client number.
           (client (cdr (assoc name table))))
      ;; If the user asked to start a new Guile process, do that now.
      (or client (setq client (gds-start-utility-guile)))
      ;; Return the chosen client ID.
      client)))

(defvar gds-last-utility-number 0
  "Number of the last started Guile utility process.")

(defun gds-start-utility-guile ()
  "Start a new utility Guile process."
  (setq gds-last-utility-number (+ gds-last-utility-number 1))
  (let* ((procname (format "gds-util[%d]" gds-last-utility-number))
         (code (format "(begin
                          %s
                          (use-modules (ice-9 gds-client))
                          (run-utility))"
		       (if gds-scheme-directory
			   (concat "(set! %load-path (cons "
				   (format "%S" gds-scheme-directory)
				   " %load-path))")
			 "")))
         (proc (start-process procname
                              (get-buffer-create procname)
                              gds-guile-program
                              "-q"
                              "--debug"
                              "-c"
                              code))
         (client nil))
    ;; Note that this process can be killed automatically on Emacs
    ;; exit.
    (process-kill-without-query proc)
    ;; Set up a process filter to catch the new client's number.
    (set-process-filter proc
                        (lambda (proc string)
                          (setq client (string-to-number string))
                          (if (process-buffer proc)
                              (with-current-buffer (process-buffer proc)
                                (insert string)))))
    ;; Accept output from the new process until we have its number.
    (while (not client)
      (accept-process-output proc))
    ;; Return the new process's client number.
    client))

;;;; Evaluating code.

;; The following commands send code for evaluation through the GDS TCP
;; connection, receive the result and any output generated through the
;; same connection, and display the result and output to the user.
;;
;; For each buffer where evaluations can be requested, GDS uses the
;; buffer-local variable `gds-client' to track which GDS client
;; program should receive and handle that buffer's evaluations.

(defun gds-module-name (start end)
  "Determine and return the name of the module that governs the
specified region.  The module name is returned as a list of symbols."
  (interactive "r")			; why not?
  (save-excursion
    (goto-char start)
    (let (module-name)
      (while (and (not module-name)
		  (beginning-of-defun-raw 1))
	(if (looking-at "(define-module ")
	    (setq module-name
		  (progn
		    (goto-char (match-end 0))
		    (read (current-buffer))))))
      module-name)))

(defcustom gds-emacs-buffer-port-name-prefix "Emacs buffer: "
  "Prefix used when telling Guile the name of the port from which a
chunk of Scheme code (to be evaluated) comes.  GDS uses this prefix,
followed by the buffer name, in two cases: when the buffer concerned
is not associated with a file, or if the buffer has been modified
since last saving to its file.  In the case where the buffer is
identical to a saved file, GDS uses the file name as the port name."
  :type '(string)
  :group 'gds)

(defun gds-port-name (start end)
  "Return port name for the specified region of the current buffer.
The name will be used by Guile as the port name when evaluating that
region's code."
  (or (and (not (buffer-modified-p))
	   buffer-file-name)
      (concat gds-emacs-buffer-port-name-prefix (buffer-name))))

(defun gds-line-and-column (pos)
  "Return 0-based line and column number at POS."
  (let (line column)
    (save-excursion
      (goto-char pos)
      (setq column (current-column))
      (beginning-of-line)
      (setq line (count-lines (point-min) (point))))
    (cons line column)))

(defun gds-eval-region (start end &optional debugp)
  "Evaluate the current region.  If invoked with `C-u' prefix (or, in
a program, with optional DEBUGP arg non-nil), pause and pop up the
stack at the start of the evaluation, so that the user can single-step
through the code."
  (interactive "r\nP")
  (or gds-client
      (gds-auto-associate-buffer)
      (call-interactively 'gds-associate-buffer))
  (let ((module (gds-module-name start end))
	(port-name (gds-port-name start end))
	(lc (gds-line-and-column start)))
    (let ((code (buffer-substring-no-properties start end)))
      (gds-send (format "eval (region . %S) %s %S %d %d %S %s"
			(gds-abbreviated code)
			(if module (prin1-to-string module) "#f")
			port-name (car lc) (cdr lc)
			code
			(if debugp '(debug) '(none)))
		gds-client))))

(defun gds-eval-expression (expr &optional correlator debugp)
  "Evaluate the supplied EXPR (a string).  If invoked with `C-u'
prefix (or, in a program, with optional DEBUGP arg non-nil), pause and
pop up the stack at the start of the evaluation, so that the user can
single-step through the code."
  (interactive "sEvaluate expression: \ni\nP")
  (or gds-client
      (gds-auto-associate-buffer)
      (call-interactively 'gds-associate-buffer))
  (set-text-properties 0 (length expr) nil expr)
  (gds-send (format "eval (%S . %S) #f \"Emacs expression\" 0 0 %S %s"
		    (or correlator 'expression)
		    (gds-abbreviated expr)
		    expr
		    (if debugp '(debug) '(none)))
	    gds-client))

(defconst gds-abbreviated-length 35)

(defun gds-abbreviated (code)
  (let ((nlpos (string-match (regexp-quote "\n") code)))
    (while nlpos
      (setq code
	    (if (= nlpos (- (length code) 1))
		(substring code 0 nlpos)
	      (concat (substring code 0 nlpos)
		      "\\n"
		      (substring code (+ nlpos 1)))))
      (setq nlpos (string-match (regexp-quote "\n") code))))
  (if (> (length code) gds-abbreviated-length)
      (concat (substring code 0 (- gds-abbreviated-length 3)) "...")
    code))

(defun gds-eval-defun (&optional debugp)
  "Evaluate the defun (top-level form) at point.  If invoked with
`C-u' prefix (or, in a program, with optional DEBUGP arg non-nil),
pause and pop up the stack at the start of the evaluation, so that the
user can single-step through the code."
  (interactive "P")
  (save-excursion
   (end-of-defun)
   (let ((end (point)))
     (beginning-of-defun)
     (gds-eval-region (point) end debugp))))

(defun gds-eval-last-sexp (&optional debugp)
  "Evaluate the sexp before point.  If invoked with `C-u' prefix (or,
in a program, with optional DEBUGP arg non-nil), pause and pop up the
stack at the start of the evaluation, so that the user can single-step
through the code."
  (interactive "P")
  (gds-eval-region (save-excursion (backward-sexp) (point)) (point) debugp))

;;;; Help.

;; Help is implemented as a special case of evaluation, identified by
;; the evaluation correlator 'help.

(defun gds-help-symbol (sym)
  "Get help for SYM (a Scheme symbol)."
  (interactive
   (let ((sym (thing-at-point 'symbol))
	 (enable-recursive-minibuffers t)
	 val)
     (setq val (read-from-minibuffer
		(if sym
		    (format "Describe Guile symbol (default %s): " sym)
		  "Describe Guile symbol: ")))
     (list (if (zerop (length val)) sym val))))
  (gds-eval-expression (format "(help %s)" sym) 'help))

(defun gds-apropos (regex)
  "List Guile symbols matching REGEX."
  (interactive
   (let ((sym (thing-at-point 'symbol))
	 (enable-recursive-minibuffers t)
	 val)
     (setq val (read-from-minibuffer
		(if sym
		    (format "Guile apropos (regexp, default \"%s\"): " sym)
		  "Guile apropos (regexp): ")))
     (list (if (zerop (length val)) sym val))))
  (set-text-properties 0 (length regex) nil regex)
  (gds-eval-expression (format "(apropos %S)" regex) 'apropos))

;;;; Displaying results of help and eval.

(defun gds-display-results (client correlator stack-available results)
  (let* ((helpp+bufname (cond ((eq (car correlator) 'help)
                               '(t . "*Guile Help*"))
                              ((eq (car correlator) 'apropos)
                               '(t . "*Guile Apropos*"))
                              (t
                               '(nil . "*Guile Evaluation*"))))
         (helpp (car helpp+bufname)))
    (let ((buf (get-buffer-create (cdr helpp+bufname))))
      (save-selected-window
	(save-excursion
	  (set-buffer buf)
	  (gds-dissociate-buffer)
	  (erase-buffer)
	  (scheme-mode)
	  (insert (cdr correlator) "\n\n")
	  (while results
	    (insert (car results))
	    (or (bolp) (insert "\\\n"))
	    (if helpp
		nil
	      (if (cadr results)
		  (mapcar (function (lambda (value)
				      (insert " => " value "\n")))
			  (cadr results))
		(insert " => no (or unspecified) value\n"))
	      (insert "\n"))
	    (setq results (cddr results)))
	  (if stack-available
	      (let ((beg (point))
		    (map (make-sparse-keymap)))
		(define-key map [mouse-1] 'gds-show-last-stack)
		(define-key map "\C-m" 'gds-show-last-stack)
		(insert "[click here to show error stack]")
		(add-text-properties beg (point)
				     (list 'keymap map
					   'mouse-face 'highlight))
		(insert "\n")))
	  (goto-char (point-min))
	  (gds-associate-buffer client))
	(pop-to-buffer buf)
	(run-hooks 'temp-buffer-show-hook)))))

(defun gds-show-last-stack ()
  "Show stack of the most recent error."
  (interactive)
  (or gds-client
      (gds-auto-associate-buffer)
      (call-interactively 'gds-associate-buffer))
  (gds-send "debug-lazy-trap-context" gds-client))

;;;; Completion.

(defvar gds-completion-results nil)

(defun gds-complete-symbol ()
  "Complete the Guile symbol before point.  Returns `t' if anything
interesting happened, `nil' if not."
  (interactive)
  (or gds-client
      (gds-auto-associate-buffer)
      (call-interactively 'gds-associate-buffer))
  (let* ((chars (- (point) (save-excursion
			     (while (let ((syntax (char-syntax (char-before (point)))))
				      (or (eq syntax ?w) (eq syntax ?_)))
			       (forward-char -1))
			     (point)))))
    (if (zerop chars)
	nil
      (setq gds-completion-results nil)
      (gds-send (format "complete %s"
			(prin1-to-string
			 (buffer-substring-no-properties (- (point) chars)
							 (point))))
		 gds-client)
      (while (null gds-completion-results)
	(accept-process-output gds-debug-server 0 200))
      (cond ((eq gds-completion-results 'error)
             (error "Internal error - please report the contents of the *Guile Evaluation* window"))
	    ((eq gds-completion-results t)
	     nil)
	    ((stringp gds-completion-results)
	     (if (<= (length gds-completion-results) chars)
		 nil
	       (insert (substring gds-completion-results chars))
	       (message "Sole completion")
	       t))
	    ((= (length gds-completion-results) 1)
	     (if (<= (length (car gds-completion-results)) chars)
		 nil
	       (insert (substring (car gds-completion-results) chars))
	       t))
	    (t
	     (with-output-to-temp-buffer "*Completions*"
	       (display-completion-list gds-completion-results))
	     t)))))

;;;; Dispatcher for non-debug protocol.

(defun gds-nondebug-protocol (client proc args)
  (cond (;; (eval-results ...) - Results of evaluation.
         (eq proc 'eval-results)
         (gds-display-results client (car args) (cadr args) (cddr args))
         ;; If these results indicate an error, set
         ;; gds-completion-results to non-nil in case the error arose
         ;; when trying to do a completion.
         (if (eq (caar args) 'error)
             (setq gds-completion-results 'error)))

        (;; (completion-result ...) - Available completions.
         (eq proc 'completion-result)
         (setq gds-completion-results (or (car args) t)))

	(;; (note ...) - For debugging only.
	 (eq proc 'note))

        (;; (trace ...) - Tracing.
         (eq proc 'trace)
         (with-current-buffer (get-buffer-create "*GDS Trace*")
           (save-excursion
             (goto-char (point-max))
             (or (bolp) (insert "\n"))
             (insert "[client " (number-to-string client) "] " (car args) "\n"))))

        (t
         ;; Unexpected.
         (error "Bad protocol: %S" form))))

;;;; Scheme mode keymap items.

(define-key scheme-mode-map "\M-\C-x" 'gds-eval-defun)
(define-key scheme-mode-map "\C-x\C-e" 'gds-eval-last-sexp)
(define-key scheme-mode-map "\C-c\C-e" 'gds-eval-expression)
(define-key scheme-mode-map "\C-c\C-r" 'gds-eval-region)
(define-key scheme-mode-map "\C-hg" 'gds-help-symbol)
(define-key scheme-mode-map "\C-h\C-g" 'gds-apropos)
(define-key scheme-mode-map "\C-hG" 'gds-apropos)
(define-key scheme-mode-map "\C-hS" 'gds-show-last-stack)
(define-key scheme-mode-map "\e\t" 'gds-complete-symbol)

;;;; The end!

(provide 'gds-scheme)

;;; gds-scheme.el ends here.


code:
;;; gds-server.el -- infrastructure for running GDS server processes

;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later
;;;; version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

;;;; Customization group setup.

(defgroup gds nil
  "Customization options for Guile Emacs frontend."
  :group 'scheme)

;;;; Communication with the (ice-9 gds-server) subprocess.

;; Subprocess output goes into the `*GDS Process*' buffer, and
;; is then read from there one form at a time.  `gds-read-cursor' is
;; the buffer position of the start of the next unread form.
(defvar gds-read-cursor nil)

;; The guile executable used by the GDS server process.
(defcustom gds-guile-program "guile"
  "*The guile executable used by the GDS server process."
  :type 'string
  :group 'gds)

(defcustom gds-scheme-directory nil
  "Where GDS's Scheme code is, if not in one of the standard places."
  :group 'gds
  :type '(choice (const :tag "nil" nil) directory))

(defun gds-start-server (procname port-or-path protocol-handler &optional bufname)
  "Start a GDS server process called PROCNAME, listening on TCP port
or Unix domain socket PORT-OR-PATH.  PROTOCOL-HANDLER should be a
function that accepts and processes one protocol form.  Optional arg
BUFNAME specifies the name of the buffer that is used for process
output; if not specified the buffer name is the same as the process
name."
  (with-current-buffer (get-buffer-create (or bufname procname))
    (erase-buffer)
    (let* ((code (format "(begin
                            %s
                            (use-modules (ice-9 gds-server))
                            (run-server %S))"
			 (if gds-scheme-directory
			     (concat "(set! %load-path (cons "
				     (format "%S" gds-scheme-directory)
				     " %load-path))")
			   "")
                         port-or-path))
           (process-connection-type nil) ; use a pipe
           (proc (start-process procname
                                (current-buffer)
                                gds-guile-program
                                "-q"
                                "--debug"
                                "-c"
                                code)))
      (set (make-local-variable 'gds-read-cursor) (point-min))
      (set (make-local-variable 'gds-protocol-handler) protocol-handler)
      (set-process-filter proc (function gds-filter))
      (set-process-sentinel proc (function gds-sentinel))
      (set-process-coding-system proc 'latin-1-unix)
      (process-kill-without-query proc)
      proc)))

;; Subprocess output filter: inserts normally into the process buffer,
;; then tries to reread the output one form at a time and delegates
;; processing of each form to `gds-protocol-handler'.
(defun gds-filter (proc string)
  (with-current-buffer (process-buffer proc)
    (save-excursion
      (goto-char (process-mark proc))
      (insert-before-markers string))
    (goto-char gds-read-cursor)
    (while (let ((form (condition-case nil
			   (read (current-buffer))
			 (error nil))))
	     (if form
		 (save-excursion
		   (funcall gds-protocol-handler (car form) (cdr form))))
	     form)
      (setq gds-read-cursor (point)))))

;; Subprocess sentinel: do nothing.  (Currently just here to avoid
;; inserting un-`read'able process status messages into the process
;; buffer.)
(defun gds-sentinel (proc event)
  )

;;;; The end!

(provide 'gds-server)

;;; gds-server.el ends here.


code:
;;; gds.el -- frontend for Guile development in Emacs

;;;; Copyright (C) 2003, 2004 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2.1 of the License, or (at your option) any later
;;;; version.
;;;;
;;;; This library is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;;; Lesser General Public License for more details.
;;;;
;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with this library; if not, write to the Free
;;;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
;;;; 02111-1307 USA

; TODO:
; ?transcript
; scheme-mode menu
; interrupt/sigint/async-break
; (module browsing)
; load file
; doing common protocol from debugger
; thread override for debugging

;;;; Prerequisites.

(require 'scheme)
(require 'cl)
(require 'gds-server)
(require 'gds-scheme)

;; The subprocess object for the debug server.
(defvar gds-debug-server nil)

(defvar gds-socket-type-alist '((tcp . 8333)
				(unix . "/tmp/.gds_socket"))
  "Maps each of the possible socket types that the GDS server can
listen on to the path that it should bind to for each one.")

(defun gds-run-debug-server ()
  "Start (or restart, if already running) the GDS debug server process."
  (interactive)
  (if gds-debug-server (gds-kill-debug-server))
  (setq gds-debug-server
        (gds-start-server "gds-debug"
			  (cdr (assq gds-server-socket-type
				     gds-socket-type-alist))
			  'gds-debug-protocol))
  (process-kill-without-query gds-debug-server))

(defun gds-kill-debug-server ()
  "Kill the GDS debug server process."
  (interactive)
  (mapcar (function gds-client-gone)
	  (mapcar (function car) gds-client-info))
  (condition-case nil
      (progn
	(kill-process gds-debug-server)
	(accept-process-output gds-debug-server 0 200))
    (error))
  (setq gds-debug-server nil))

;; Send input to the subprocess.
(defun gds-send (string client)
  (with-current-buffer (get-buffer-create "*GDS Transcript*")
    (goto-char (point-max))
    (insert (number-to-string client) ": (" string ")\n"))
  (gds-client-put client 'thread-id nil)
  (gds-show-client-status client gds-running-text)
  (process-send-string gds-debug-server (format "(%S %s)\n" client string)))

;;;; Per-client information

(defun gds-client-put (client property value)
  (let ((client-info (assq client gds-client-info)))
    (if client-info
	(let ((prop-info (memq property client-info)))
	  (if prop-info
	      (setcar (cdr prop-info) value)
	    (setcdr client-info
		    (list* property value (cdr client-info)))))
      (setq gds-client-info
	    (cons (list client property value) gds-client-info)))))

(defun gds-client-get (client property)
  (let ((client-info (assq client gds-client-info)))
    (and client-info
	 (cadr (memq property client-info)))))

(defvar gds-client-info '())

(defun gds-get-client-buffer (client)
  (let ((existing-buffer (gds-client-get client 'stack-buffer)))
    (if (and existing-buffer
	     (buffer-live-p existing-buffer))
	existing-buffer
      (let ((new-buffer (generate-new-buffer (gds-client-get client 'name))))
	(with-current-buffer new-buffer
	  (gds-debug-mode)
	  (setq gds-client client)
	  (setq gds-stack nil))
	(gds-client-put client 'stack-buffer new-buffer)
	new-buffer))))

(defun gds-client-gone (client &rest ignored)
  ;; Kill the client's stack buffer, if it has one.
  (let ((stack-buffer (gds-client-get client 'stack-buffer)))
    (if (and stack-buffer
	     (buffer-live-p stack-buffer))
	(kill-buffer stack-buffer)))
  ;; Dissociate all the client's associated buffers.
  (mapcar (function (lambda (buffer)
		      (if (buffer-live-p buffer)
			  (with-current-buffer buffer
			    (gds-dissociate-buffer)))))
	  (copy-sequence (gds-client-get client 'associated-buffers)))
  ;; Remove this client's record from gds-client-info.
  (setq gds-client-info (delq (assq client gds-client-info) gds-client-info)))

(defvar gds-client nil)
(make-variable-buffer-local 'gds-client)

(defvar gds-stack nil)
(make-variable-buffer-local 'gds-stack)

(defvar gds-tweaking nil)
(make-variable-buffer-local 'gds-tweaking)

(defvar gds-selected-frame-index nil)
(make-variable-buffer-local 'gds-selected-frame-index)

;;;; Debugger protocol

(defun gds-debug-protocol (client form)
  (or (eq client '*)
      (let ((proc (car form)))
        (cond ((eq proc 'name)
               ;; (name ...) - client name.
	       (gds-client-put client 'name (caddr form)))

              ((eq proc 'stack)
               ;; (stack ...) - stack information.
               (with-current-buffer (gds-get-client-buffer client)
                 (setq gds-stack (cddr form))
                 (setq gds-tweaking (memq 'instead (cadr gds-stack)))
                 (setq gds-selected-frame-index (cadr form))
                 (gds-display-stack)))

              ((eq proc 'closed)
               ;; (closed) - client has gone/died.
               (gds-client-gone client))

              ((eq proc 'eval-result)
               ;; (eval-result RESULT) - result of evaluation.
	       (if gds-last-eval-result
		   (message "%s" (cadr form))
		 (setq gds-last-eval-result (cadr form))))

              ((eq proc 'info-result)
               ;; (info-result RESULT) - info about selected frame.
               (message "%s" (cadr form)))

	      ((eq proc 'thread-id)
               ;; (thread-id THREAD) - says which client thread is reading.
               (let ((thread-id (cadr form))
                     (debug-thread-id (gds-client-get client 'debug-thread-id)))
                 (if (and debug-thread-id
                          (/= thread-id debug-thread-id))
                     ;; Tell the newly reading thread to go away.
                     (gds-send "dismiss" client)
                   ;; Either there's no current debug-thread-id, or
                   ;; the thread now reading is the debug thread.
                   (if debug-thread-id
                       (progn
                         ;; Reset the debug-thread-id.
                         (gds-client-put client 'debug-thread-id nil)
                         ;; Indicate debug status in modelines.
                         (gds-show-client-status client gds-debug-text))
                     ;; Indicate normal read status in modelines..
                     (gds-show-client-status client gds-ready-text)))))

	      ((eq proc 'debug-thread-id)
               ;; (debug-thread-id THREAD) - debug override indication.
               (gds-client-put client 'debug-thread-id (cadr form))
               ;; If another thread is already reading, send it away.
               (if (gds-client-get client 'thread-id)
                   (gds-send "dismiss" client)))

              (t
               ;; Non-debug-specific protocol.
               (gds-nondebug-protocol client proc (cdr form)))))))

;;;; Displaying a stack

(define-derived-mode gds-debug-mode
  scheme-mode
  "Guile-Debug"
  "Major mode for debugging a Guile client application."
  (use-local-map gds-mode-map))

(defun gds-display-stack-first-line ()
  (let ((flags (cadr gds-stack)))
    (cond ((memq 'application flags)
           (insert "Calling procedure:\n"))
          ((memq 'evaluation flags)
           (insert "Evaluating expression"
                   (cond ((stringp gds-tweaking) (format " (tweaked: %s)"
							 gds-tweaking))
			 (gds-tweaking " (tweakable)")
			 (t ""))
                   ":\n"))
          ((memq 'return flags)
           (let ((value (cadr (memq 'return flags))))
             (while (string-match "\n" value)
               (setq value (replace-match "\\n" nil t value)))
             (insert "Return value"
                     (cond ((stringp gds-tweaking) (format " (tweaked: %s)"
							   gds-tweaking))
			   (gds-tweaking " (tweakable)")
			   (t ""))
                     ": " value "\n")))
          ((memq 'error flags)
           (let ((value (cadr (memq 'error flags))))
             (while (string-match "\n" value)
               (setq value (replace-match "\\n" nil t value)))
             (insert "Error: " value "\n")))
          (t
           (insert "Stack: " (prin1-to-string flags) "\n")))))

(defun gds-display-stack ()
  (if gds-undisplay-timer
      (cancel-timer gds-undisplay-timer))
  (setq gds-undisplay-timer nil)
  ;(setq buffer-read-only nil)
  (mapcar 'delete-overlay
          (overlays-in (point-min) (point-max)))
  (erase-buffer)
  (gds-display-stack-first-line)
  (let ((frames (car gds-stack)))
    (while frames
      (let ((frame-text (cadr (car frames)))
            (frame-source (caddr (car frames))))
        (while (string-match "\n" frame-text)
          (setq frame-text (replace-match "\\n" nil t frame-text)))
        (insert "   "
                (if frame-source "s" " ")
                frame-text
                "\n"))
      (setq frames (cdr frames))))
  ;(setq buffer-read-only t)
  (gds-show-selected-frame))

(defun gds-tweak (expr)
  (interactive "sTweak expression or return value: ")
  (or gds-tweaking
      (error "The current stack cannot be tweaked"))
  (setq gds-tweaking
        (if (> (length expr) 0)
            expr
          t))
  (save-excursion
    (goto-char (point-min))
    (delete-region (point) (progn (forward-line 1) (point)))
    (gds-display-stack-first-line)))

(defvar gds-undisplay-timer nil)
(make-variable-buffer-local 'gds-undisplay-timer)

(defvar gds-undisplay-wait 1)

(defun gds-undisplay-buffer ()
  (if gds-undisplay-timer
      (cancel-timer gds-undisplay-timer))
  (setq gds-undisplay-timer
        (run-at-time gds-undisplay-wait
                     nil
                     (function kill-buffer)
                     (current-buffer))))

(defun gds-show-selected-frame ()
  (setq gds-local-var-cache nil)
  (goto-char (point-min))
  (forward-line (+ gds-selected-frame-index 1))
  (delete-char 3)
  (insert "=> ")
  (beginning-of-line)
  (gds-show-selected-frame-source (caddr (nth gds-selected-frame-index
                                              (car gds-stack)))))

(defun gds-unshow-selected-frame ()
  (if gds-frame-source-overlay
      (move-overlay gds-frame-source-overlay 0 0))
  (save-excursion
    (goto-char (point-min))
    (forward-line (+ gds-selected-frame-index 1))
    (delete-char 3)
    (insert "   ")))

;; Overlay used to highlight the source expression corresponding to
;; the selected frame.
(defvar gds-frame-source-overlay nil)

(defcustom gds-source-file-name-transforms nil
  "Alist of regexps and substitutions for transforming Scheme source
file names.  Each element in the alist is (REGEXP . SUBSTITUTION).
Each source file name in a Guile backtrace is compared against each
REGEXP in turn until the first one that matches, then `replace-match'
is called with SUBSTITUTION to transform that file name.

This mechanism targets the situation where you are working on a Guile
application and want to install it, in /usr/local say, before each
test run.  In this situation, even though Guile is reading your Scheme
files from /usr/local/share/guile, you probably want Emacs to pop up
the corresponding files from your working codebase instead.  Therefore
you would add an element to this alist to transform
\"^/usr/local/share/guile/whatever\" to \"~/codebase/whatever\"."
  :type '(alist :key-type regexp :value-type string)
  :group 'gds)

(defun gds-show-selected-frame-source (source)
  ;; Highlight the frame source, if possible.
  (if source
      (let ((filename (car source))
            (client gds-client)
	    (transforms gds-source-file-name-transforms))
	;; Apply possible transforms to the source file name.
	(while transforms
	  (if (string-match (caar transforms) filename)
	      (let ((trans-fn (replace-match (cdar transforms)
					     t nil filename)))
		(if (file-readable-p trans-fn)
		    (setq filename trans-fn
			  transforms nil))))
	  (setq transforms (cdr transforms)))
	;; Try to map the (possibly transformed) source file to a
	;; buffer.
	(let ((source-buffer (gds-source-file-name-to-buffer filename)))
	  (if source-buffer
	      (with-current-buffer source-buffer
		(if gds-frame-source-overlay
		    nil
		  (setq gds-frame-source-overlay (make-overlay 0 0))
		  (overlay-put gds-frame-source-overlay 'face 'highlight)
                  (overlay-put gds-frame-source-overlay
                               'help-echo
                               (function gds-show-local-var)))
		;; Move to source line.  Note that Guile line numbering
		;; is 0-based, while Emacs numbering is 1-based.
		(save-restriction
		  (widen)
		  (goto-line (+ (cadr source) 1))
		  (move-to-column (caddr source))
		  (move-overlay gds-frame-source-overlay
				(point)
				(if (not (looking-at ")"))
				    (save-excursion (forward-sexp 1) (point))
				  ;; It seems that the source
				  ;; coordinates for backquoted
				  ;; expressions are at the end of the
				  ;; sexp rather than the beginning...
				  (save-excursion (forward-char 1)
						  (backward-sexp 1) (point)))
				(current-buffer)))
		;; Record that this source buffer has been touched by a
		;; GDS client process.
		(setq gds-last-touched-by client))
	    (message "Source for this frame cannot be shown: %s:%d:%d"
		     filename
		     (cadr source)
		     (caddr source)))))
    (message "Source for this frame was not recorded"))
  (gds-display-buffers))

(defvar gds-local-var-cache nil)

(defun gds-show-local-var (window overlay position)
  (let ((frame-index gds-selected-frame-index)
	(client gds-client))
    (with-current-buffer (overlay-buffer overlay)
      (save-excursion
        (goto-char position)
        (let ((gds-selected-frame-index frame-index)
	      (gds-client client)
	      (varname (thing-at-point 'symbol))
	      (state (parse-partial-sexp (overlay-start overlay) (point))))
          (when (and gds-selected-frame-index
		     gds-client
		     varname
		     (not (or (nth 3 state)
			      (nth 4 state))))
	    (set-text-properties 0 (length varname) nil varname)
            (let ((existing (assoc varname gds-local-var-cache)))
              (if existing
                  (cdr existing)
                (gds-evaluate varname)
                (setq gds-last-eval-result nil)
                (while (not gds-last-eval-result)
                  (accept-process-output gds-debug-server))
                (setq gds-local-var-cache
                      (cons (cons varname gds-last-eval-result)
                            gds-local-var-cache))
                gds-last-eval-result))))))))

(defun gds-source-file-name-to-buffer (filename)
  ;; See if filename begins with gds-emacs-buffer-port-name-prefix.
  (if (string-match (concat "^"
			    (regexp-quote gds-emacs-buffer-port-name-prefix))
		    filename)
      ;; It does, so get the named buffer.
      (get-buffer (substring filename (match-end 0)))
    ;; It doesn't, so treat as a file name.
    (and (file-readable-p filename)
	 (find-file-noselect filename))))

(defun gds-select-stack-frame (&optional frame-index)
  (interactive)
  (let ((new-frame-index (or frame-index
                             (gds-current-line-frame-index))))
    (or (and (>= new-frame-index 0)
             (< new-frame-index (length (car gds-stack))))
        (error (if frame-index
                   "No more frames in this direction"
                 "No frame here")))
    (gds-unshow-selected-frame)
    (setq gds-selected-frame-index new-frame-index)
    (gds-show-selected-frame)))

(defun gds-up ()
  (interactive)
  (gds-select-stack-frame (- gds-selected-frame-index 1)))

(defun gds-down ()
  (interactive)
  (gds-select-stack-frame (+ gds-selected-frame-index 1)))

(defun gds-current-line-frame-index ()
  (- (count-lines (point-min)
                  (save-excursion
                    (beginning-of-line)
                    (point)))
     1))

(defun gds-display-buffers ()
  (let ((buf (current-buffer)))
    ;; If there's already a window showing the buffer, use it.
    (let ((window (get-buffer-window buf t)))
      (if window
          (progn
            (make-frame-visible (window-frame window))
            (select-window window))
        (switch-to-buffer buf)
        (setq window (get-buffer-window buf t))))
    ;; If there is an associated source buffer, display it as well.
    (if (and gds-frame-source-overlay
	     (overlay-end gds-frame-source-overlay)
	     (> (overlay-end gds-frame-source-overlay) 1))
        (progn
          (delete-other-windows)
          (let ((window (display-buffer
                         (overlay-buffer gds-frame-source-overlay))))
            (set-window-point window
                              (overlay-start gds-frame-source-overlay)))))))

;;;; Debugger commands.

;; Typically but not necessarily used from the `stack' view.

(defun gds-send-tweaking ()
  (if (stringp gds-tweaking)
      (gds-send (format "tweak %S" gds-tweaking) gds-client)))

(defun gds-go ()
  (interactive)
  (gds-send-tweaking)
  (gds-send "continue" gds-client)
  (gds-unshow-selected-frame)
  (gds-undisplay-buffer))

(defvar gds-last-eval-result t)

(defun gds-evaluate (expr)
  (interactive "sEvaluate variable or expression: ")
  (gds-send (format "evaluate %d %s"
                    gds-selected-frame-index
                    (prin1-to-string expr))
	    gds-client))

(defun gds-frame-info ()
  (interactive)
  (gds-send (format "info-frame %d" gds-selected-frame-index)
            gds-client))

(defun gds-frame-args ()
  (interactive)
  (gds-send (format "info-args %d" gds-selected-frame-index)
            gds-client))

(defun gds-proc-source ()
  (interactive)
  (gds-send (format "proc-source %d" gds-selected-frame-index)
            gds-client))

(defun gds-traps-here ()
  (interactive)
  (gds-send "traps-here" gds-client))

(defun gds-step-into ()
  (interactive)
  (gds-send-tweaking)
  (gds-send (format "step-into %d" gds-selected-frame-index)
            gds-client)
  (gds-unshow-selected-frame)
  (gds-undisplay-buffer))

(defun gds-step-over ()
  (interactive)
  (gds-send-tweaking)
  (gds-send (format "step-over %d" gds-selected-frame-index)
            gds-client)
  (gds-unshow-selected-frame)
  (gds-undisplay-buffer))

(defun gds-step-file ()
  (interactive)
  (gds-send-tweaking)
  (gds-send (format "step-file %d" gds-selected-frame-index)
            gds-client)
  (gds-unshow-selected-frame)
  (gds-undisplay-buffer))

;;;; Guile Interaction mode keymap and menu items.

(defvar gds-mode-map (make-sparse-keymap))
(define-key gds-mode-map "c" (function gds-go))
(define-key gds-mode-map "g" (function gds-go))
(define-key gds-mode-map "q" (function gds-go))
(define-key gds-mode-map "e" (function gds-evaluate))
(define-key gds-mode-map "I" (function gds-frame-info))
(define-key gds-mode-map "A" (function gds-frame-args))
(define-key gds-mode-map "S" (function gds-proc-source))
(define-key gds-mode-map "T" (function gds-traps-here))
(define-key gds-mode-map "\C-m" (function gds-select-stack-frame))
(define-key gds-mode-map "u" (function gds-up))
(define-key gds-mode-map [up] (function gds-up))
(define-key gds-mode-map "\C-p" (function gds-up))
(define-key gds-mode-map "d" (function gds-down))
(define-key gds-mode-map [down] (function gds-down))
(define-key gds-mode-map "\C-n" (function gds-down))
(define-key gds-mode-map " " (function gds-step-file))
(define-key gds-mode-map "i" (function gds-step-into))
(define-key gds-mode-map "o" (function gds-step-over))
(define-key gds-mode-map "t" (function gds-tweak))

(defvar gds-menu nil
  "Global menu for GDS commands.")
(if nil;gds-menu
    nil
  (setq gds-menu (make-sparse-keymap "Guile-Debug"))
  (define-key gds-menu [traps-here]
    '(menu-item "Show Traps Here" gds-traps-here))
  (define-key gds-menu [proc-source]
    '(menu-item "Show Procedure Source" gds-proc-source))
  (define-key gds-menu [frame-args]
    '(menu-item "Show Frame Args" gds-frame-args))
  (define-key gds-menu [frame-info]
    '(menu-item "Show Frame Info" gds-frame-info))
  (define-key gds-menu [separator-1]
    '("--"))
  (define-key gds-menu [evaluate]
    '(menu-item "Evaluate..." gds-evaluate))
  (define-key gds-menu [separator-2]
    '("--"))
  (define-key gds-menu [down]
    '(menu-item "Move Down A Frame" gds-down))
  (define-key gds-menu [up]
    '(menu-item "Move Up A Frame" gds-up))
  (define-key gds-menu [separator-3]
    '("--"))
  (define-key gds-menu [step-over]
    '(menu-item "Step Over Current Expression" gds-step-over))
  (define-key gds-menu [step-into]
    '(menu-item "Step Into Current Expression" gds-step-into))
  (define-key gds-menu [step-file]
    '(menu-item "Step Through Current Source File" gds-step-file))
  (define-key gds-menu [separator-4]
    '("--"))
  (define-key gds-menu [go]
    '(menu-item "Go  [continue execution]" gds-go))
  (define-key gds-mode-map [menu-bar gds-debug]
    (cons "Guile-Debug" gds-menu)))

;;;; Autostarting the GDS server.

(defcustom gds-autorun-debug-server t
  "Whether to automatically run the GDS server when `gds.el' is loaded."
  :type 'boolean
  :group 'gds)

(defcustom gds-server-socket-type 'tcp
  "What kind of socket the GDS server should listen on."
  :group 'gds
  :type '(choice (const :tag "TCP" tcp)
		 (const :tag "Unix" unix)))

;;;; If requested, autostart the server after loading.

(if (and gds-autorun-debug-server
	 (not gds-debug-server))
    (gds-run-debug-server))

;;;; The end!

(provide 'gds)

;;; gds.el ends here.


code:
;;; gud-guile.el --- Support for debugging guile internals

;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.

;; 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 2, or (at your option)
;; any later version.

;; 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Version: 1
;;; Favorite-Favorite: Favorite-Favorite

;;; Commentary:

;; This is a grab bag of stuff for doing "gdb guile" in Emacs.
;; The var `gdb-guile-suggested-gdbinit' has a string that is
;; snarfed from ../HACKING.  (todo: Write `gdb-guile-init' to
;; send it to gdb...)

;;; Code:

(require 'cl)

(defun gdb-guile-display-scm ()
  (interactive)
  (save-excursion
    (let ((sym (thing-at-point 'symbol))
          (proc (get-buffer-process
                 (find-if (lambda (buf)
                            (string-match "^.gud-." (buffer-name buf)))
                          (buffer-list)))))
      (mapc (lambda (template)
              (process-send-string proc (format template sym)))
            (list
             "set gdb_print(%s)\n"
             "printf \"%s: %%s\\n\", gdb_output\n")))))

(defvar gdb-guile-suggested-gdbinit "
define gp
set gdb_print($arg0)
print gdb_output
end
document gp
Executes (object->string arg)
end

define ge
call gdb_read($arg0)
call gdb_eval(gdb_result)
set gdb_print(gdb_result)
print gdb_output
end
document ge
Executes (print (eval (read arg))): ge \"(+ 1 2)\" => 3
end

define gh
call g_help(scm_str2symbol($arg0), 20)
set gdb_print($1)
print gdb_output
end
document gh
Prints help string for arg: gh \"enved-target\"
end
"
  "A useful .gdbinit")

(provide 'gud-guile)

;;; gud-guile.el ends here


code:
;;; guile-c.el --- Guile C editing commands

;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; (add-hook 'c-mode-hook
;;   (lambda ()
;;     (require 'guile-c)
;;     (define-key c-mode-map "\C-c\C-g\C-p" 'guile-c-insert-define)
;;     (define-key c-mode-map "\C-c\C-g\C-e" 'guile-c-edit-docstring)
;;     (define-key c-mode-map "\C-c\C-g\C-d" 'guile-c-deprecate-region)
;;     ))

;;; Code:

(require 'cc-mode)

(defvar guile-c-prefix "scm_")

;;;
;;; Insert templates
;;;

(defun guile-c-insert-define ()
  "Insert a template of a Scheme procedure.

  M-x guile-c-insert-define RET foo arg , opt . rest =>

  SCM_DEFINE (scm_foo, \"foo\", 1, 1, 1,
              (SCM arg, SCM opt, SCM rest),
              \"\")
  #define FUNC_NAME s_scm_foo
  {

  }
  #undef FUNC_NAME"
  (interactive)
  (let ((tokens (split-string (read-string "Procedure: ")))
	name args opts rest)
    ;; Get procedure name
    (if (not tokens) (error "No procedure name"))
    (setq name (car tokens) tokens (cdr tokens))
    ;; Get requisite arguments
    (while (and tokens (not (member (car tokens) '("," "."))))
      (setq args (cons (car tokens) args) tokens (cdr tokens)))
    (setq args (nreverse args))
    ;; Get optional arguments
    (when (string= (car tokens) ",")
      (setq tokens (cdr tokens))
      (while (and tokens (not (string= (car tokens) ".")))
	(setq opts (cons (car tokens) opts) tokens (cdr tokens)))
      (setq opts (nreverse opts)))
    ;; Get rest argument
    (when (string= (car tokens) ".")
      (setq rest (list (cadr tokens))))
    ;; Insert template
    (let ((c-name (guile-c-name-from-scheme-name name)))
      (insert (format "SCM_DEFINE (%s, \"%s\", %d, %d, %d,\n"
		      c-name name (length args) (length opts) (length rest))
	      "\t    ("
	      (mapconcat (lambda (a) (concat "SCM " a))
			 (append args opts rest) ", ")
	      "),\n"
	      "\t    \"\")\n"
	      "#define FUNC_NAME s_" c-name "\n"
	      "{\n\n}\n"
	      "#undef FUNC_NAME\n\n")
      (previous-line 4)
      (indent-for-tab-command))))

(defun guile-c-name-from-scheme-name (name)
  (while (string-match "\\?$" name) (setq name (replace-match "_p" t t name)))
  (while (string-match "!$" name) (setq name (replace-match "_x" t t name)))
  (while (string-match "^%" name) (setq name (replace-match "sys_" t t name)))
  (while (string-match "->" name) (setq name (replace-match "_to_" t t name)))
  (while (string-match "[-:]" name) (setq name (replace-match "_" t t name)))
  (concat guile-c-prefix name))

;;;
;;; Edit docstrings
;;;

(defvar guile-c-window-configuration nil)

(defun guile-c-edit-docstring ()
  (interactive)
  (let* ((region (guile-c-find-docstring))
	 (doc (if region (buffer-substring (car region) (cdr region)))))
    (if (not doc)
	(error "No docstring!")
      (setq guile-c-window-configuration (current-window-configuration))
      (with-current-buffer (get-buffer-create "*Guile Docstring*")
	(erase-buffer)
	(insert doc)
	(goto-char (point-min))
	(while (not (eobp))
	  (if (looking-at "[ \t]*\"")
	      (delete-region (match-beginning 0) (match-end 0)))
	  (end-of-line)
	  (if (eq (char-before (point)) ?\")
	      (delete-backward-char 1))
	  (if (and (eq (char-before (point)) ?n)
		   (eq (char-before (1- (point))) ?\\))
	      (delete-backward-char 2))
	  (forward-line))
	(goto-char (point-min))
	(texinfo-mode)
	(if global-font-lock-mode
	    (font-lock-fontify-buffer))
	(local-set-key "\C-c\C-c" 'guile-c-edit-finish)
	(setq fill-column 63)
	(switch-to-buffer-other-window (current-buffer))
        (message "Type `C-c C-c' to finish")))))

(defun guile-c-edit-finish ()
  (interactive)
  (goto-char (point-max))
  (while (eq (char-before) ?\n) (backward-delete-char 1))
  (goto-char (point-min))
  (if (eobp)
      (insert "\"\"")
    (while (not (eobp))
      (insert "\t    \"")
      (end-of-line)
      (insert (if (eobp) "\"" "\\n\""))
      (forward-line 1)))
  (let ((doc (buffer-string)))
    (kill-buffer (current-buffer))
    (set-window-configuration guile-c-window-configuration)
    (let ((region (guile-c-find-docstring)))
      (goto-char (car region))
      (delete-region (car region) (cdr region)))
    (insert doc)))

(defun guile-c-find-docstring ()
  (save-excursion
    (if (re-search-backward "^SCM_DEFINE" nil t)
	(let ((start (progn (forward-line 2) (point))))
	  (while (looking-at "[ \t]*\"")
	    (forward-line 1))
	  (cons start (- (point) 2))))))

;;;
;;; Others
;;;

(defun guile-c-deprecate-region (start end)
  (interactive "r")
  (save-excursion
    (let ((marker (make-marker)))
      (set-marker marker end)
      (goto-char start)
      (insert "#if (SCM_DEBUG_DEPRECATED == 0)\n\n")
      (goto-char marker)
      (insert "\n#endif /* (SCM_DEBUG_DEPRECATED == 0) */\n"))))

(provide 'guile-c)

;; guile-c.el ends here


code:
;;; guile-emacs.scm --- Guile Emacs interface

;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>

;; 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 2, or (at your option)
;; any later version.

;; 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Code:

(use-modules (ice-9 regex))
(use-modules (ice-9 channel))
(use-modules (ice-9 session))
(use-modules (ice-9 documentation))

;;;
;;; Emacs Lisp channel
;;;

(define (emacs-lisp-channel)

  (define (native-type? x)
    (or (integer? x) (symbol? x) (string? x) (pair? x) (vector? x)))

  (define (emacs-lisp-print ch val)
    (cond
      ((unspecified? val))
      ((eq? val #t) (channel-print-value ch 't))
      ((or (eq? val #f) (null? val)) (channel-print-value ch 'nil))
      ((native-type? val) (channel-print-value ch val))
      (else (channel-print-token ch val))))

  (channel-open (make-object-channel emacs-lisp-print)))

;;;
;;; Scheme channel
;;;

(define (emacs-scheme-channel)
  (define (print ch val) (channel-print-value ch (object->string val)))
  (channel-open (make-object-channel print)))

;;;
;;; for guile-import and guile-import-module
;;;

(define (guile-emacs-export-procedure name proc docs)
  (define (procedure-arity proc)
    (assq-ref (procedure-properties proc) 'arity))

  (define (procedure-args proc)
    (let ((source (procedure-source proc)))
      (if source
	;; formals -> emacs args
	(let loop ((formals (cadr source)))
	  (cond
	    ((null? formals) '())
	    ((symbol? formals) `(&rest ,formals))
	    (else (cons (car formals) (loop (cdr formals))))))
	;; arity -> emacs args
	(let* ((arity (procedure-arity proc))
	       (nreqs (car arity))
	       (nopts (cadr arity))
	       (restp (caddr arity)))
	  (define (nsyms n)
	    (if (= n 0) '() (cons (gensym "a") (nsyms (1- n)))))
	  (append! (nsyms nreqs)
		   (if (> nopts 0) (cons '&optional (nsyms nopts)) '())
		   (if restp (cons '&rest (nsyms 1)) '()))))))

  (define (procedure-call name args)
    (let ((restp (memq '&rest args))
	  (args (delq '&rest (delq '&optional args))))
      (if restp
	`('apply ',name ,@args)
	`(',name ,@args))))

  (let ((args (procedure-args proc))
	(docs (and docs (object-documentation proc))))
    `(defun ,name ,args
       ,@(if docs (list docs) '())
       (guile-lisp-flat-eval ,@(procedure-call (procedure-name proc) args)))))

(define (guile-emacs-export proc-name func-name docs)
  (let ((proc (module-ref (current-module) proc-name)))
    (guile-emacs-export-procedure func-name proc docs)))

(define (guile-emacs-export-procedures module-name docs)
  (define (module-public-procedures name)
    (hash-fold (lambda (s v d)
		 (let ((val (variable-ref v)))
		   (if (procedure? val) (acons s val d) d)))
	       '() (module-obarray (resolve-interface name))))
  `(progn ,@(map (lambda (n+p)
		   (guile-emacs-export-procedure (car n+p) (cdr n+p) docs))
		 (module-public-procedures module-name))))

;;;
;;; for guile-scheme-complete-symbol
;;;

(define (guile-emacs-complete-alist str)
  (sort! (apropos-fold (lambda (module name val data)
			 (cons (list (symbol->string name)
				     (cond ((procedure? val) " <p>")
					   ((macro? val)     " <m>")
					   (else "")))
			       data))
		       '() (string-append "^" (regexp-quote str))
		       apropos-fold-all)
	 (lambda (p1 p2) (string<? (car p1) (car p2)))))

;;;
;;; for guile-scheme-apropos
;;;

(define (guile-emacs-apropos regexp)
  (with-output-to-string (lambda () (apropos regexp))))

;;;
;;; for guile-scheme-describe
;;;

(define (guile-emacs-describe sym)
  (object-documentation (eval sym (current-module))))

;;;
;;; Guile 1.4 compatibility
;;;

(define object->string
  (if (defined? 'object->string)
    object->string
    (lambda (x) (format #f "~S" x))))

;;; guile-emacs.scm ends here


code:
;;; guile-scheme.el --- Guile Scheme editing mode

;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.

;; 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 2, or (at your option)
;; any later version.

;; 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; Put the following lines in your ~/.emacs:
;;
;;   (require 'guile-scheme)
;;   (setq initial-major-mode 'scheme-interaction-mode)

;;; Code:

(require 'guile)
(require 'scheme)

(defgroup guile-scheme nil
  "Editing Guile-Scheme code"
  :group 'lisp)

(defvar guile-scheme-syntax-keywords
  '((begin 0) (if 1) (cond 0) (case 1) (do 2)
    quote syntax lambda and or else delay receive use-modules
    (match 1) (match-lambda 0) (match-lambda* 0)
    (let scheme-let-indent) (let* 1) (letrec 1) (and-let* 1)
    (let-syntax 1) (letrec-syntax 1) (syntax-rules 1) (syntax-case 2)))

(defvar guile-scheme-special-procedures
  '((catch 1) (lazy-catch 1) (stack-catch 1)
    map for-each (dynamic-wind 3)))

;; set indent functions
(dolist (x (append guile-scheme-syntax-keywords
		   guile-scheme-special-procedures))
  (when (consp x)
    (put (car x) 'scheme-indent-function (cadr x))))

(defconst guile-scheme-font-lock-keywords
  (eval-when-compile
    (list
     (list (concat "(\\(define\\*?\\("
		   ;; Function names.
		   "\\(\\|-public\\|-method\\|-generic\\)\\|"
		   ;; Macro names, as variable names.
		   "\\(-syntax\\|-macro\\)\\|"
		   ;; Others
		   "-\\sw+\\)\\)\\>"
		   ;; Any whitespace and declared object.
		   "\\s *(?\\(\\sw+\\)?")
	   '(1 font-lock-keyword-face)
	   '(5 (cond ((match-beginning 3) font-lock-function-name-face)
		     ((match-beginning 4) font-lock-variable-name-face)
		     (t font-lock-type-face)) nil t))
     (list (concat
	    "(" (regexp-opt
		 (mapcar (lambda (e)
			   (prin1-to-string (if (consp e) (car e) e)))
			 (append guile-scheme-syntax-keywords
				 guile-scheme-special-procedures)) 'words))
	   '(1 font-lock-keyword-face))
     '("<\\sw+>" . font-lock-type-face)
     '("\\<:\\sw+\\>" . font-lock-builtin-face)
     ))
  "Expressions to highlight in Guile Scheme mode.")

;;;
;;; Guile Scheme mode
;;;

(defvar guile-scheme-mode-map nil
  "Keymap for Guile Scheme mode.
All commands in `lisp-mode-shared-map' are inherited by this map.")

(unless guile-scheme-mode-map
  (let ((map (make-sparse-keymap "Guile-Scheme")))
    (setq guile-scheme-mode-map map)
    (cond ((boundp 'lisp-mode-shared-map)
	   (set-keymap-parent map lisp-mode-shared-map))
	  ((boundp 'shared-lisp-mode-map)
	   (set-keymap-parent map shared-lisp-mode-map)))
    (define-key map [menu-bar] (make-sparse-keymap))
    (define-key map [menu-bar guile-scheme] (cons "Guile-Scheme" map))
    (define-key map [uncomment-region]
      '("Uncomment Out Region" . (lambda (beg end)
                                   (interactive "r")
                                   (comment-region beg end '(4)))))
    (define-key map [comment-region] '("Comment Out Region" . comment-region))
    (define-key map [indent-region] '("Indent Region" . indent-region))
    (define-key map [indent-line] '("Indent Line" . lisp-indent-line))
    (define-key map "\e\C-i" 'guile-scheme-complete-symbol)
    (define-key map "\e\C-x" 'guile-scheme-eval-define)
    (define-key map "\C-x\C-e" 'guile-scheme-eval-last-sexp)
    (define-key map "\C-c\C-b" 'guile-scheme-eval-buffer)
    (define-key map "\C-c\C-r" 'guile-scheme-eval-region)
    (define-key map "\C-c:" 'guile-scheme-eval-expression)
    (define-key map "\C-c\C-a" 'guile-scheme-apropos)
    (define-key map "\C-c\C-d" 'guile-scheme-describe)
    (define-key map "\C-c\C-k" 'guile-scheme-kill-process)

    (put 'comment-region 'menu-enable 'mark-active)
    (put 'uncomment-region 'menu-enable 'mark-active)
    (put 'indent-region 'menu-enable 'mark-active)))

(defcustom guile-scheme-mode-hook nil
  "Normal hook run when entering `guile-scheme-mode'."
  :type 'hook
  :group 'guile-scheme)

;;;###autoload
(defun guile-scheme-mode ()
  "Major mode for editing Guile Scheme code.
Editing commands are similar to those of `scheme-mode'.

\\{scheme-mode-map}
Entry to this mode calls the value of `scheme-mode-hook'
if that value is non-nil."
  (interactive)
  (kill-all-local-variables)
  (setq mode-name "Guile Scheme")
  (setq major-mode 'guile-scheme-mode)
  (use-local-map guile-scheme-mode-map)
  (scheme-mode-variables)
  (setq mode-line-process
	'(:eval (if (processp guile-scheme-adapter)
		    (format " [%s]" guile-scheme-command)
		  "")))
  (setq font-lock-defaults
        '((guile-scheme-font-lock-keywords)
          nil t (("+-*/.<>=!?$%_&~^:@" . "w")) beginning-of-defun
          (font-lock-mark-block-function . mark-defun)))
  (run-hooks 'guile-scheme-mode-hook))

;;;
;;; Scheme interaction mode
;;;

(defvar scheme-interaction-mode-map ()
  "Keymap for Scheme Interaction mode.
All commands in `guile-scheme-mode-map' are inherited by this map.")

(unless scheme-interaction-mode-map
  (let ((map (make-sparse-keymap)))
    (setq scheme-interaction-mode-map map)
    (set-keymap-parent map guile-scheme-mode-map)
    (define-key map "\C-j" 'guile-scheme-eval-print-last-sexp)
    ))

(defvar scheme-interaction-mode-hook nil
  "Normal hook run when entering `scheme-interaction-mode'.")

(defun scheme-interaction-mode ()
  "Major mode for evaluating Scheme expressions with Guile.

\\{scheme-interaction-mode-map}"
  (interactive)
  (guile-scheme-mode)
  (use-local-map scheme-interaction-mode-map)
  (setq major-mode 'scheme-interaction-mode)
  (setq mode-name "Scheme Interaction")
  (run-hooks 'scheme-interaction-mode-hook))

;;;
;;; Guile Scheme adapter
;;;

(defvar guile-scheme-command "guile")
(defvar guile-scheme-adapter nil)
(defvar guile-scheme-module nil)

(defun guile-scheme-adapter ()
  (if (and (processp guile-scheme-adapter)
	   (eq (process-status guile-scheme-adapter) 'run))
      guile-scheme-adapter
    (setq guile-scheme-module nil)
    (setq guile-scheme-adapter
	  (guile:make-adapter guile-scheme-command 'emacs-scheme-channel))))

(defun guile-scheme-set-module ()
  "Set the current module based on buffer contents.
If there is a (define-module ...) form, evaluate it.
Otherwise, choose module (guile-user)."
  (save-excursion
    (let ((module (if (re-search-backward "^(define-module " nil t)
		      (let ((start (match-beginning 0)))
			(goto-char start)
			(forward-sexp)
			(buffer-substring-no-properties start (point)))
		    "(define-module (emacs-user))")))
      (unless (string= guile-scheme-module module)
	(prog1 (guile:eval module (guile-scheme-adapter))
	  (setq guile-scheme-module module))))))

(defun guile-scheme-eval-string (string)
  (guile-scheme-set-module)
  (guile:eval string (guile-scheme-adapter)))

(defun guile-scheme-display-result (value flag)
  (if (string= value "#<unspecified>")
      (setq value "done"))
  (if flag
      (insert value)
    (message "%s" value)))

;;;
;;; Interactive commands
;;;

(defun guile-scheme-eval-expression (string)
  "Evaluate the expression in STRING and show value in echo area."
  (interactive "SGuile Scheme Eval: ")
  (guile-scheme-display-result (guile-scheme-eval-string string) nil))

(defun guile-scheme-eval-region (start end)
  "Evaluate the region as Guile Scheme code."
  (interactive "r")
  (guile-scheme-eval-expression (buffer-substring-no-properties start end)))

(defun guile-scheme-eval-buffer ()
  "Evaluate the current buffer as Guile Scheme code."
  (interactive)
  (guile-scheme-eval-expression (buffer-string)))

(defun guile-scheme-eval-last-sexp (arg)
  "Evaluate sexp before point; show value in echo area.
With argument, print output into current buffer."
  (interactive "P")
  (guile-scheme-display-result
   (guile-scheme-eval-string
    (buffer-substring-no-properties
     (point) (save-excursion (backward-sexp) (point)))) arg))

(defun guile-scheme-eval-print-last-sexp ()
  "Evaluate sexp before point; print value into current buffer."
  (interactive)
  (let ((start (point)))
    (guile-scheme-eval-last-sexp t)
    (insert "\n")
    (save-excursion (goto-char start) (insert "\n"))))

(defun guile-scheme-eval-define ()
  (interactive)
  (guile-scheme-eval-region (save-excursion (end-of-defun) (point))
			    (save-excursion (beginning-of-defun) (point))))

(defun guile-scheme-load-file (file)
  "Load a Guile Scheme file."
  (interactive "fGuile Scheme load file: ")
  (guile-scheme-eval-string (format "(load %s)" (expand-file-name file)))
  (message "done"))

(guile-import guile-emacs-complete-alist)

(defun guile-scheme-complete-symbol ()
  (interactive)
  (let* ((end (point))
	 (start (save-excursion (skip-syntax-backward "w_") (point)))
	 (pattern (buffer-substring-no-properties start end))
	 (alist (guile-emacs-complete-alist pattern)))
    (goto-char end)
    (let ((completion (try-completion pattern alist)))
      (cond ((eq completion t))
	    ((not completion)
	     (message "Can't find completion for \"%s\"" pattern)
	     (ding))
	    ((not (string= pattern completion))
	     (delete-region start end)
	     (insert completion))
	    (t
	     (message "Making completion list...")
	     (with-output-to-temp-buffer "*Completions*"
	       (display-completion-list alist))
	     (message "Making completion list...done"))))))

(guile-import guile-emacs-apropos)

(defun guile-scheme-apropos (regexp)
  (interactive "sGuile Scheme apropos (regexp): ")
  (guile-scheme-set-module)
  (with-output-to-temp-buffer "*Help*"
    (princ (guile-emacs-apropos regexp))))

(guile-import guile-emacs-describe)

(defun guile-scheme-describe (symbol)
  (interactive (list (guile-scheme-input-symbol "Describe Guile variable")))
  (guile-scheme-set-module)
  (with-output-to-temp-buffer "*Help*"
    (princ (guile-emacs-describe symbol))))

(defun guile-scheme-kill-process ()
  (interactive)
  (if guile-scheme-adapter
      (guile-process-kill guile-scheme-adapter))
  (setq guile-scheme-adapter nil))

;;;
;;; Internal functions
;;;

(guile-import apropos-internal guile-apropos-internal)

(defvar guile-scheme-complete-table (make-vector 151 nil))

(defun guile-scheme-input-symbol (prompt)
  (mapc (lambda (sym)
	  (if (symbolp sym)
	      (intern (symbol-name sym) guile-scheme-complete-table)))
	(guile-apropos-internal ""))
  (let* ((str (thing-at-point 'symbol))
	 (default (if (intern-soft str guile-scheme-complete-table)
		      (concat " (default " str ")")
		    "")))
    (intern (completing-read (concat prompt default ": ")
			     guile-scheme-complete-table nil t nil nil str))))

;;;
;;; Turn on guile-scheme-mode for .scm files by default.
;;;

(setq auto-mode-alist
      (cons '("\\.scm\\'" . guile-scheme-mode) auto-mode-alist))

(provide 'guile-scheme)

;;; guile-scheme.el ends here


code:
;;; guile.el --- Emacs Guile interface

;; Copyright (C) 2001 Keisuke Nishida <kxn30@po.cwru.edu>

;; 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 2, or (at your option)
;; any later version.

;; 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Code:

(require 'cl)

;;;
;;; Low level interface
;;;

(defvar guile-emacs-file
  (catch 'return
    (mapc (lambda (dir)
	    (let ((file (expand-file-name "guile-emacs.scm" dir)))
	      (if (file-exists-p file) (throw 'return file))))
	  load-path)
    (error "Cannot find guile-emacs.scm")))

(defvar guile-channel-file
  (catch 'return
    (mapc (lambda (dir)
	    (let ((file (expand-file-name "channel.scm" dir)))
	      (if (file-exists-p file) (throw 'return file))))
	  load-path)
    (error "Cannot find channel.scm")))

(defvar guile-libs
  (nconc (if guile-channel-file (list "-l" guile-channel-file) '())
	 (list "-l" guile-emacs-file)))

;;;###autoload
(defun guile:make-adapter (command channel)
  (let* ((buff (generate-new-buffer " *guile object channel*"))
	 (libs (if guile-channel-file (list "-l" guile-channel-file) nil))
	 (proc (apply 'start-process "guile-oa" buff command "-q" guile-libs)))
    (process-kill-without-query proc)
    (accept-process-output proc)
    (guile-process-require proc (format "(%s)\n" channel) "channel> ")
    proc))

(put 'guile-error 'error-conditions '(guile-error error))
(put 'guile-error 'error-message "Guile error")

(defvar guile-token-tag "<guile>")

(defun guile-tokenp (x) (and (consp x) (eq (car x) guile-token-tag)))

;;;###autoload
(defun guile:eval (string adapter)
  (condition-case error
      (let ((output (guile-process-require adapter (concat "eval " string "\n")
					   "channel> ")))
	(cond
	 ((string= output "") nil)
	 ((string-match "^\\(\\(value\\)\\|\\(token\\)\\|\\(exception\\)\\) = "
			output)
	  (cond
	   ;; value
	   ((match-beginning 2)
	    (car (read-from-string (substring output (match-end 0)))))
	   ;; token
	   ((match-beginning 3)
	    (cons guile-token-tag
		  (car (read-from-string (substring output (match-end 0))))))
	   ;; exception
	   ((match-beginning 4)
	    (signal 'guile-error
		    (car (read-from-string (substring output (match-end 0))))))))
	 (t
	  (error "Unsupported result" output))))
    (quit
     (signal-process (process-id adapter) 'SIGINT)
     (signal 'quit nil))))

;;;
;;; Guile Lisp adapter
;;;

(defvar guile-lisp-command "guile")
(defvar guile-lisp-adapter nil)

(defvar true "#t")
(defvar false "#f")

(unless (boundp 'keywordp)
  (defun keywordp (x) (and (symbolp x) (eq (aref (symbol-name x) 0) ?:))))

(defun guile-lisp-adapter ()
  (if (and (processp guile-lisp-adapter)
	   (eq (process-status guile-lisp-adapter) 'run))
      guile-lisp-adapter
    (setq guile-lisp-adapter
	  (guile:make-adapter guile-lisp-command 'emacs-lisp-channel))))

(defun guile-lisp-convert (x)
  (cond
   ((or (eq x true) (eq x false)) x)
   ((null x) "'()")
   ((keywordp x) (concat "#" (prin1-to-string x)))
   ((stringp x) (prin1-to-string x))
   ((guile-tokenp x) (cadr x))
   ((consp x)
    (if (null (cdr x))
	(list (guile-lisp-convert (car x)))
      (cons (guile-lisp-convert (car x)) (guile-lisp-convert (cdr x)))))
   (t x)))

;;;###autoload
(defun guile-lisp-eval (form)
  (guile:eval (format "%s" (guile-lisp-convert form)) (guile-lisp-adapter)))

(defun guile-lisp-flat-eval (&rest form)
  (let ((args (mapcar (lambda (x)
			(if (guile-tokenp x) (cadr x) (list 'quote x)))
		      (cdr form))))
    (guile-lisp-eval (cons (car form) args))))

;;;###autoload
(defmacro guile-import (name &optional new-name &rest opts)
  `(guile-process-import ',name ',new-name ',opts))

(defun guile-process-import (name new-name opts)
  (let ((real (or new-name name))
	(docs (if (memq :with-docs opts) true false)))
    (eval (guile-lisp-eval `(guile-emacs-export ',name ',real ,docs)))))

;;;###autoload
(defmacro guile-use-module (name)
  `(guile-lisp-eval '(use-modules ,name)))

;;;###autoload
(defmacro guile-import-module (name &rest opts)
  `(guile-process-import-module ',name ',opts))

(defun guile-process-import-module (name opts)
  (unless (boundp 'guile-emacs-export-procedures)
    (guile-import guile-emacs-export-procedures))
  (let ((docs (if (memq :with-docs opts) true false)))
    (guile-lisp-eval `(use-modules ,name))
    (eval (guile-emacs-export-procedures name docs))
    name))

;;;
;;; Process handling
;;;

(defvar guile-process-output-start nil)
(defvar guile-process-output-value nil)
(defvar guile-process-output-finished nil)
(defvar guile-process-output-separator nil)

(defun guile-process-require (process string separator)
  (setq guile-process-output-value nil)
  (setq guile-process-output-finished nil)
  (setq guile-process-output-separator separator)
  (let (temp-buffer)
    (unless (process-buffer process)
      (setq temp-buffer (guile-temp-buffer))
      (set-process-buffer process temp-buffer))
    (with-current-buffer (process-buffer process)
      (goto-char (point-max))
      (insert string)
      (setq guile-process-output-start (point))
      (set-process-filter process 'guile-process-filter)
      (process-send-string process string)
      (while (not guile-process-output-finished)
	(unless (accept-process-output process 3)
	  (when (> (point) guile-process-output-start)
	    (display-buffer (current-buffer))
	    (error "BUG in Guile object channel!!")))))
    (when temp-buffer
      (set-process-buffer process nil)
      (kill-buffer temp-buffer)))
  guile-process-output-value)

(defun guile-process-filter (process string)
  (with-current-buffer (process-buffer process)
    (insert string)
    (forward-line -1)
    (if (< (point) guile-process-output-start)
	(goto-char guile-process-output-start))
    (when (re-search-forward guile-process-output-separator nil 0)
      (goto-char (match-beginning 0))
      (setq guile-process-output-value
	    (buffer-substring guile-process-output-start (point)))
      (setq guile-process-output-finished t))))

(defun guile-process-kill (process)
  (set-process-filter process nil)
  (delete-process process)
  (if (process-buffer process)
      (kill-buffer (process-buffer process))))

(provide 'guile)

;;; guile.el ends here


code:
;;; multistring.el --- editing multiline strings.

;; Copyright (C) 2000, 2006 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; 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 2, or (at your option)
;; any later version.

;; 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>

;;; Commentary:

;; Commands for editing multiline ANSI C compatible string literals.

;;; Code:

(defun ms-ansify-string (arg)
    "Convert a string literal spanning multiple lines into multiple literals.
With no argument, convert the single string at point to multiple strings.
With an argument, convert multiple strings to a single one.

ANSI C doesn't allow a string literal to span multiple lines.  This
function makes editing of multiline strings easier.

The programmer can edit a string spanning multiple lines and then use
this function to convert it into multiple literals representing the
original string through the ANSI C string concatenation feature:

  \"A string consisting of
  multiple
  lines.\"

is converted into

  \"A string consisting of\n\"
  \"multiple\n\"
  \"lines\""
  (interactive "*P")
  (save-excursion
    (let (beg end)
      (save-restriction
	(ms-narrow-canonicalize-ansi-c-string)
	(if (not arg)
	    (ms-break-string))
	(setq beg (point-min))
	(setq end (point-max)))
      (if (not arg)
	  (c-indent-region beg end)))))

(defun ms-pack-region (from to &optional unpack-flag)
  "Pack paragraphs into single lines and remove one newline after paragraphs.
With no argument, do the conversion.
With an argument, do the reverse.

When doing the reverse conversion, \\[fill-region] is used to break up
the text into multiple lines."
  (interactive "*r\nP")
  (save-excursion
    (save-restriction
      (narrow-to-region from to)
      (if (not unpack-flag)
	  (ms-pack-buffer)
	(ms-unpack-buffer)))))

(defun ms-pack-ansify-string (arg)
  "Pack text in a string literal and convert into multiple literals.
With no argument, do the conversion.
With an argument, do the reverse.

This command has the combined effect of \\[ms-pack-region] and
\\[ms-ansify-string].  It is typically used if you want to store
entire paragraphs without newlines in an ANSI C literal, but want to
split it into multiple literals in order for the program text to look
sensible.  Using the reverse command, you can \"unpack\" the text,
edit it and repack the text using the forward conversion."
  (interactive "*P")
  (save-excursion
    (let (beg end)
      (save-restriction
	(ms-narrow-canonicalize-ansi-c-string)
	(if (not arg)
	    (ms-break-string " " "" "\\n")
	  (ms-unpack-buffer))
	(setq beg (point-min))
	(setq end (point-max)))
      (if (not arg)
	  (c-indent-region beg end)))))

(defun ms-pack-buffer ()
  "Pack paragraphs into single lines and remove one newline after paragraphs."
  (interactive "*")
  (goto-char (point-min))
  (skip-chars-forward "^\n")
  (while (not (eobp))
    (delete-char 1)
    (skip-chars-forward "\n")
    (skip-chars-forward "^\n")))

(defun ms-unpack-buffer ()
  "Break single lines into paragraphs and add an extra newline between each."
  (interactive "*")
  (goto-char (point-min))
  (skip-chars-forward "^\n")
  (while (not (eobp))
    (insert ?\n)
    (skip-chars-forward "\n")
    (skip-chars-forward "^\n"))
  (fill-region (point-min) (point-max) nil t))

(defconst ms-whitespace " \t\n")
(defconst ms-string-beginning "\"")
(defconst ms-string-end "\\(\\\\*\\)\"")
(defconst ms-quoted-newline "\\(\\\\*\\)\\(\\\\n\\)")

(defun ms-in-string-p ()
  (eq (c-in-literal) 'string))

(defun ms-narrow-canonicalize-ansi-c-string ()
  ;; Find and check reference point
  (cond ((ms-in-string-p))
	((eq (char-after) ?\") (forward-char))
	(t (error "Not in string.")))
  (set-mark (point))
  ;; Find beginning
  (ms-beginning-of-string)
  (let ((beg (point)))
    ;; Extend string backwards
    (while (ms-extend-backwards)
      (setq beg (point)))
    (goto-char (mark))
    ;; Find end
    (ms-end-of-string)
    (let ((end (point)))
      ;; Extend string forwards
      (while (ms-extend-forwards)
	(setq end (point)))
      ;; Narrow
      (narrow-to-region beg end)
      ;; Convert \n into explicit newlines
      (ms-convert-quoted-newlines))))

(defun ms-beginning-of-string ()
  (let ((pos (search-backward ms-string-beginning nil t)))
    (while (and pos
		(char-before)
		(eq (char-before) ?\\))
      (setq pos (search-backward ms-string-beginning nil t)))
    (if pos
	(progn
	  (forward-char)
	  (1+ pos)))))

(defun ms-extend-backwards ()
  (let ((end (point)))
    (backward-char)
    (skip-chars-backward ms-whitespace)
    (if (eq (char-before) ?\")
	(progn
	  (backward-char)
	  (delete-region (point) end)
	  (ms-beginning-of-string)))))

(defun ms-end-of-string ()
  (let ((pos (search-forward-regexp ms-string-end nil t)))
    (while (and pos (= (logand (- (match-end 1) (match-beginning 1)) 1) 1))
      (setq pos (search-forward-regexp ms-string-end nil t)))
    (if pos
	(progn
	  (backward-char)
	  (match-end 1)))))

(defun ms-extend-forwards ()
  (let ((start (point)))
    (forward-char)
    (skip-chars-forward ms-whitespace)
    (if (eq (char-after) ?\")
	(progn
	  (forward-char)
	  (delete-region start (point))
	  (ms-end-of-string)))))

(defun ms-convert-quoted-newlines ()
  (goto-char (point-min))
  (while (search-forward-regexp ms-quoted-newline nil t)
    (if (= (logand (- (match-end 1) (match-beginning 1)) 1) 0)
	(replace-match "\n" nil t nil 2))))

(defun ms-break-string (&optional single-term multi-term-1 multi-term-n)
  (let ((single-term (or single-term "\\n"))
	(multi-term-1 (or multi-term-1 "\\n"))
	(multi-term-n (or multi-term-n "\\n")))
    (goto-char (point-min))
    (skip-chars-forward "^\n")
    (while (not (eobp))
      (delete-char 1)
      (if (not (eq (char-after) ?\n))
	  (insert single-term)
	(insert multi-term-1)
	(while (eq (char-after) ?\n)
	  (delete-char 1)
	  (insert multi-term-n)))
      (insert "\"\n\"")
      (skip-chars-forward "^\n"))))

(eval-after-load "cc-mode"
  (progn
    (define-key c-mode-base-map "\C-ca" 'ms-ansify-string)
    (define-key c-mode-base-map "\C-cd" 'ms-pack-ansify-string)
    ))


code:
;;; patch.el --- mail/apply a patch

;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.

;; 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 2, or (at your option)
;; any later version.

;; 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Author: Thien-Thi Nguyen <ttn@gnu.org>
;;; Version: 1
;;; Favorite-Favorite: Favorite-Favorite

;;; Commentary:

;; This file has two symmetrical usage modes, for patch creation and
;; application, respectively.  The details are somewhat tuned for Guile
;; maintenance; probably we should generalize it a bit and add it to
;; Emacs proper at some point in the future.  Long live free software!
;;
;; On the patch creation side of things, there are various version
;; control systems that are happy to write a diff to stdout (and
;; numerous Emacs interfaces to them all).  Thus, we provide only a
;; simple `patch-send' that composes mail from the current buffer;
;; the contents of that buffer are left as an exercise for the patch
;; creator.  When preparing the mail, `patch-send' scans the patch
;; for standard filename headers and sets up a skeleton change log --
;; filling this in is a good way to earn respect from maintainers (hint
;; hint).  Type `C-c C-c' to send the mail when you are done.  (See
;; `compose-mail' for more info.)
;;
;; TODO: Write/document patch-apply side of things.
;; TODO: Integrate w/ `ediff-patch-buffer' et al.

;;; Code:

(require 'cl)
(require 'update-changelog)             ; for stitching

;; outgoing

(defvar patch-greeting "hello guile maintainers,\n\n"
  "*String to insert at beginning of patch mail.")

(defun patch-scan-files ()
  (let (files)
    (save-excursion
      (while (re-search-forward "^[+][+][+] \\(\\S-+\\)" (point-max) t)
        (setq files (cons (cons (match-string 1)
                                (match-beginning 0))
                          files))))
    (reverse files)))

(defun patch-common-prefix (filenames)
  (let* ((first-file (car filenames))
         (prefix (and first-file (file-name-directory first-file))))
    (while (and prefix
                (not (string= "" prefix))
                (not (every (lambda (filename)
                              (string-match (concat "^" prefix) filename))
                            filenames)))
      (setq prefix (file-name-directory (substring prefix 0 -1))))
    prefix))

(defun patch-changelog-skeleton ()
  (let* ((file-info (patch-scan-files))
         (fullpath-files (mapcar 'car file-info))
         (cut (length (patch-common-prefix fullpath-files)))
         (files (mapcar (lambda (fullpath-file)
                          (substring fullpath-file cut))
                        fullpath-files)))
    (mapconcat
     (lambda (file)
       (concat (make-string (length file) ?_) "\n" file "\n[writeme]"))
     files
     "\n")))

(defun patch-send (buffer subject)
  (interactive "bBuffer: \nsSubject: ")
  (when (string= "" subject)
    (error "(empty subject)"))
  (compose-mail "bug-guile@gnu.org" subject)
  (insert (with-current-buffer buffer (buffer-string)))
  (mail-text)
  (insert patch-greeting)
  (save-excursion
    (insert "here is a patch ... [overview/observations/etc]\n\n"
            (patch-changelog-skeleton) "\n\n\n"
            (make-string 72 ?_) "\n")))

;; incoming

;;; patch.el ends here


code:
;;; ppexpand.el --- temporarily expanding macros in a pretty way.

;; Copyright (C) 2000, 2006 Free Software Foundation, Inc.

;; This file is part of GNU Emacs.

;; 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 2, or (at your option)
;; any later version.

;; 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 GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Author: Mikael Djurfeldt <djurfeldt@nada.kth.se>

;;; Commentary:

;; Commands for editing multiline ANSI C compatible string literals.

;;; Code:
(require 'cmacexp)

(defvar if-mark "#if 0 /* PPEXPAND */")
(defvar else-mark "#else /* PPEXPAND */")
(defvar endif-mark "#endif /* PPEXPAND */")

(define-key c-mode-map "\C-ce" 'ppexpand)

(defun ppexpand (start end &optional undo)
  "Expand C macros in the region, using the C preprocessor.
The expanded code is run through the `indent' command and inserted
into the program next to the original code, using an #if/#else/#endif
construct.

Given a prefix argument, it reverts the change, removing the
#if/#else/#endif construct and the expanded code.

`c-macro-preprocessor' specifies the preprocessor to use.
Prompt for arguments to the preprocessor \(e.g. `-DDEBUG -I ./include')
if the user option `c-macro-prompt-flag' is non-nil.

Noninteractive args are START, END, UNDO.
For use inside Lisp programs, see also `c-macro-expansion'."

  (interactive (if current-prefix-arg
		   (list nil nil t)
		 (let ((pos1 (point))
		       (pos2 (mark)))
		   (if (< pos1 pos2)
		       (list pos1 pos2 nil)
		     (list pos2 pos1 nil)))))
  (let ((inbuf (current-buffer)))
    ;; Build the command string.
    (if c-macro-prompt-flag
	(setq c-macro-cppflags
	      (read-string "Preprocessor arguments: "
			   c-macro-cppflags)))
    (if undo
	(let ((pos (point)) if-pos else-pos endif-pos)
	  (save-excursion
	    (end-of-line)
	    (if (not (and (setq if-pos (search-backward if-mark nil t))
			  (setq else-pos (search-forward else-mark nil t))
			  (setq endif-pos (search-forward endif-mark nil t))
			  (<= if-pos pos)
			  (< pos endif-pos)))
		(error "Not in ppexpanded region"))
	    (let ((orig (buffer-substring (+ if-pos (length if-mark) 1)
					  (- else-pos (length else-mark)))))
	      (delete-region if-pos (+ endif-pos 1))
	      (insert orig))))
      ;; Expand the macro.
      (let* ((expansion (c-macro-expansion start end
					   (concat c-macro-preprocessor " "
						   c-macro-cppflags) t))
	     (orig (buffer-substring start end)))
	(setq expansion
	      (with-temp-buffer
		(insert expansion)
		(call-process-region (point-min) (point-max) "indent"
				     t		;delete the text
				     t		;output --> current buffer
				     )
		(buffer-string)))
	(delete-region start end)
	(insert if-mark ?\n orig else-mark ?\n expansion endif-mark ?\n)))))


code:
;;; update-changelog.el --- stitch rcs2log output to ChangeLog

;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc.

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;; Usage: emacs -batch -l update-changelog.el
;;
;; This program is basically a wrapper around rcs2log, and inherits rcs2log's
;; weaknesses, namely, the requirement that there be a checked out (working
;; directory) copy.  It would be nice if rcs2log grokked with the repository
;; directly, but until then, we work around it by requiring the environment
;; var `LOCAL_WORK_ROOT' to be defined.  This should be a directory under
;; which cvs modules are checked out.
;;
;; Flash!  Newer versions of rcs2log do indeed understand the repository,
;; and can be invoked with "-R" therein.  We infer this if `LOCAL_WORK_ROOT'
;; is not set, and use instead `CVSROOT'.  At least one of these must be set.
;;
;; You can pass additional options to rcs2log using env var `RCS2LOG_OPTS'.
;;
;; Usage from a Lisp program:
;;   (ucl-update filename) -- Update FILENAME, a Change Log file

;;; Code:

;;;---------------------------------------------------------------------------
;;; Variables

(defvar ucl-o (or (getenv "RCS2LOG_OPTS") "")
  "Additional options to pass to rcs2log.")

;;;---------------------------------------------------------------------------
;;; Cleanup functions

(defun ucl-stitch-new-old (new-old &rest ignore)
  "In a changelog buffer, remove redundancy around NEW-OLD point.
The new text is before NEW-OLD point, and the old after."
  (goto-char new-old)
  (or (= new-old (point-max))		; no old
      (let ((last-new
	     (save-excursion
	       (buffer-substring (re-search-backward "^[0-9]+") new-old))))
	(let ((has-diff (string-match "\n\tdiff.*-r" last-new))) ; ugh
	  (and has-diff (setq last-new (substring last-new 0 has-diff))))
	(let ((overlap (search-forward last-new (point-max) t)))
	  (and overlap (delete-region new-old overlap))))))

;; Sometimes wannabe developers append diffs to their log entries.
(defun ucl-omit-diffs (&rest ignore)
  "In a changelog buffer, delete diffs (assumed at end of entry)."
  (goto-char (point-min))
  (while (re-search-forward "^\tdiff .*-r" (point-max) t)
    (beginning-of-line)
    (delete-region (point)
		   (save-excursion
		     (if (re-search-forward "^[0-9]+" (point-max))
			 (- (point) 4)
		       (point-max))))))

(defun ucl-space-out-entries (&rest ignore)
  "In a changelog buffer, ensure proper spacing between entries."
  (goto-char (point-max))
  (while (re-search-backward "^[0-9]+" (point-min) t)
    (unless (= (point) (point-min))
      (open-line 3)			; yuk
      (delete-blank-lines))))

(defun ucl-kill-eol-white-space (&rest ignore)
  "In a changelog buffer, delete end-of-line white space."
  (goto-char (point-min))
  (while (re-search-forward "[ \t]+$" (point-max) t)
    (delete-region
     (match-beginning 0) (match-end 0))))

(defvar ucl-cleanup-hook '(ucl-stitch-new-old
			   ucl-omit-diffs
			   ucl-space-out-entries
			   ucl-kill-eol-white-space)
  "Hook run after combining the new fragment with the old changelog.  These
are called with the argument NEW-OLD, which is the buffer position at the
boundary of the two pieces of text.  This is suboptimal; we should use a
marker so that munges on the text do not lose this position.  The result is
that currently, `ucl-stitch-new-old' must be called first because it depends
on NEW-OLD, while the other cleanup funcs ignore it.  (Sigh.)")

;;;---------------------------------------------------------------------------
;;; Update functions

(defun ucl-root ()
  (let ((lwr (getenv "LOCAL_WORK_ROOT"))
	(cr  (getenv "CVSROOT")))
    (concat (or lwr
		(and cr (progn
			  (setq ucl-o (concat "-R " ucl-o))	; hmm
			  cr))
		(error "Must set env var LOCAL_WORK_ROOT or CVSROOT"))
	    "/")))

(defun ucl-update (filename)
  (interactive "fChangeLog: ")
  (let* ((ofile (expand-file-name filename))
         (cmd   (concat "rcs2log " ucl-o " -c " ofile))
         (obuf  "*ucl-work*"))
    (when (and (file-exists-p ofile)
	       (progn
		 (shell-command cmd obuf)
		 (get-buffer obuf)))
      (save-excursion			; prevent default-directory hosing
	(set-buffer obuf)
	(unless (= 0 (buffer-size))
	  (let ((new-old-boundary (point-max)))
	    (goto-char new-old-boundary)
	    (insert-file ofile)
	    (run-hook-with-args 'ucl-cleanup-hook new-old-boundary))
	  (or (= (buffer-size) (nth 7 (file-attributes ofile)))
	      (let (make-backup-files)	; less clutter
		(write-file ofile))))
	(kill-buffer (current-buffer))))))

;;;---------------------------------------------------------------------------
;;; Load-time actions

(when noninteractive			; only when `-batch'
  (or (ucl-update "ChangeLog")
      (message "Sorry, could not update ChangeLog in %s" default-directory)))

(provide 'update-changelog)

;;; update-changelog.el ends here