editor.lisp

;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: LW-ADD-ONS; Base: 10 -*-
;;; $Header: /usr/local/cvsrep/lw-add-ons/editor.lisp,v 1.47 2015/03/06 12:54:25 edi Exp $

;;; Copyright (c) 2005-2015, Dr. Edmund Weitz.  All rights reserved. 

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:

;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.

;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :lw-add-ons)

(defun symbol-string-at-point (&key (point (current-point)) previous)
  "Returns two values - a string denoting the symbol at POINT and
the package to use at that POINT if the symbol isn't
package-qualified.  PREVIOUS controls whether to look at the
previous symbol if POINT is between two symbols."
  (ignore-errors*
    (let ((string (editor::read-symbol-from-point :point point
                                                  :read-package-name t
                                                  :previous previous))
          (package (editor::buffer-package-to-use point)))
      (values string package))))

(defun symbol-at-point (&key (point (current-point)) previous)
  "Returns the symbol at POINT.  PREVIOUS controls whether to
look at the previous symbol if POINT is between two symbols."
  (ignore-errors*
    (multiple-value-bind (string package)
        (symbol-string-at-point :point point :previous previous)
      (let* ((*package* package)
             (candidate (read-from-string string)))
        (and (symbolp candidate)
             candidate)))))

(defun enclosing-operators ()
  "Returns a list of potential operators \(symbols behind an
opening parenthesis) starting from point and going up backwards."
  (save-excursion
    (loop while (ignore-errors*
                  (backward-up-list-command 1) t)
          when (when (looking-at "\(")
                 (forward-character-command 1)
                 (prog1
                   (symbol-at-point)
                   (forward-character-command -1)))
          collect it)))

(defun show-info (info &key full-length-p)
  "Shows the string INFO in the echo area.  Shows no more than
*MAX-INFO-LENGTH* unless FULL-LENGHT-P is true."
  (apply #'message
         (if (and (not full-length-p)
                  (> (length info) *max-info-length*))
           (list "~A [...]" (subseq info 0 *max-info-length*))
           (list "~A" info))))

(defun show-arglist ()
  "Shows the argument list of the nearest enclosing operator that
has a function definition in the echo arrea.  Shows the doc
string as well unless *SHOW-DOC-STRING-WHEN-SHOWING-ARGLIST* is
NIL."
  (when-let (object
             (loop for operator in (enclosing-operators)
                   when (and (symbolp operator)
                             (fboundp operator))
                   do (return operator)))
    (show-info (format nil "~A~@[~%~A~]"
                       (cons object (function-lambda-list object))
                       (and *show-doc-string-when-showing-arglist*
                            (documentation object 'function))))))

(defun completions-for-echo-area (completions)
  "Returns a string which shows a two-column list of the elements
\(which should be strings) in COMPLETIONS but no more than
*MAX-COMPLETIONS-TO-SHOW* of them."
  (let ((max-left-width
         (loop for completion in completions
               for i from 1 to *max-completions-to-show*
               when (oddp i)
               maximize (length completion))))
    (with-output-to-string (out)
      (format out "~&Possible completions:~%~%")
      (loop for (completion-1 completion-2 . rest) on completions by #'cddr
            for i from 1 to *max-completions-to-show* by 2
            do (format out "~&~VA  ~A" max-left-width
                       completion-1
                       (cond ((and rest
                                   (>= (1+ i) *max-completions-to-show*))
                              "[...]")
                             (completion-2)
                             (t "")))))))

(defun char-before ()
  "Returns the character before the current point."
  (character-at (current-point) -1))

(defun maybe-insert-right-parenthesis ()
  "If the symbol at or before point is in function position and
denotes a function with an empty lambda list inserts a right
parenthesis, otherwise inserts a space and show the argument list
in the echo area."
  (when-let (symbol (symbol-at-point :previous t))
    (when (and (save-excursion
                 (backward-form-command 1)
                 (eql (char-before) #\())
               (symbolp symbol)
               (fboundp symbol))
      (cond ((null (function-lambda-list symbol))
             (self-insert-command 1 #\)))
            ((not (looking-at " "))
             (insert-space-and-show-arglist-command nil))))))

#-:editor-has-dont-undo
(defmacro without-undo-with-cleanups (buffer form &body cleanups)
  "Editor utility macro.  See source code for LW editor."
  (lw:rebinding (buffer)
    (lw:with-unique-names (was-recording)
      `(let ((,was-recording (editor::check-set-buffer-without-undo ,buffer)))
         (unwind-protect
             ,form
           (when ,was-recording
             (editor::set-buffer-flag-bit ,buffer editor::*buffer-flag-dont-record-undo* nil))
           ,@cleanups)))))

#-:editor-has-dont-undo
(defmacro recording-for-undo-internal (point1 point2 line-start-p &body body)
  "Does the whole work for RECORDING-FOR-UNDO.  See source code for LW editor."
  (lw:with-unique-names (old-string start end want-undo before-modified buffer-sym)
    (lw:rebinding (point1 point2)
      `(let* ((,buffer-sym (point-buffer ,point1))
              (,want-undo (editor::check-want-to-record-undo-p ,buffer-sym nil))
              (,before-modified (editor::buffer-modified-tick ,buffer-sym))
              (,start (when ,want-undo 
                         (let ((lsp ,line-start-p)
                               (sp (copy-i-point ,point1 :before-insert)))
                           (if lsp 
                             (line-start sp))
                           sp)))
              (,end (when ,want-undo (copy-i-point ,point2 :after-insert)))
              (,old-string (when ,want-undo
                             (editor::points-to-buffer-string ,start ,end))))
         (without-undo-with-cleanups ,buffer-sym
             (progn ,@body)
           (when ,want-undo
             (editor::record-replace-region ,start ,end ,old-string ,before-modified)
             (editor::delete-it ,start)
             (editor::delete-it ,end)))))))

#-:editor-has-dont-undo
(defmacro recording-for-undo (point1 point2 &body body)
  "Performs code in BODY and records changes between POINT1 and
POINT2 for undo operation.  See source code for LW editor."
  `(recording-for-undo-internal ,point1 ,point2 nil ,@body))

#-:editor-has-dont-undo
(defmacro recording-for-undo-locking (point1 point2 &body body)
  "Like RECORDING-FOR-UNDO, but with lock.  See source code for LW editor."
  (lw:rebinding (point1)
    #-:editor-does-not-have-with-buffer-locked
    `(with-buffer-locked ((point-buffer ,point1))
       (recording-for-undo ,point1 ,point2 ,@body))
    #+:editor-does-not-have-with-buffer-locked
    `(editor::with-locked-buffer (point-buffer ,point1)
       (recording-for-undo ,point1 ,point2 ,@body))))

#+:editor-has-dont-undo
(defmacro recording-for-undo (point1 point2 &body body)
  "Performs code in BODY and records changes between POINT1 and
POINT2 for undo operation.  See source code for LW editor."
  (lw:with-unique-names (old-string start end dont changed)
    (lw:rebinding (point1 point2)
      `(let* ((,dont editor::*dont-undo*)
              (,changed (buffer-modified (point-buffer ,point1)))
              (,start (unless ,dont (copy-i-point ,point1 :before-insert)))
              (,end (unless ,dont (copy-i-point ,point2 :after-insert)))
              (,old-string (unless ,dont (editor::points-to-buffer-string ,point1 ,point2))))
         (unwind-protect
             (let ((editor::*dont-undo* t))
               ,@body)
           (progn
             (unless ,dont
               (editor::record-replace-region ,start ,end ,old-string ,changed)
               (editor::delete-it ,start)
               (editor::delete-it ,end))))))))

(defmacro recording-for-undo% (point1 point2 &body body)
  "Helper macro which dispatches to RECORDING-FOR-UNDO or
RECORDING-FOR-UNDO-LOCKING depending on the LispWorks release."
  #-:editor-has-dont-undo
  `(recording-for-undo-locking ,point1 ,point2
     ,@body)
  #+:editor-has-dont-undo
  `(recording-for-undo ,point1 ,point2
     ,@body))

(defun current-line ()
  "Returns the line the point is currently on as a string."
  (line-string (current-point)))

(defun can-move-upwards-p ()
  "Returns true if it is possible to move backward up from the
current point."
  (save-excursion
    (with-point ((point (current-point)))
      (backward-up-list-command 1)
      (point< (current-point) point))))

(defadvice (editor:find-alternate-file-command change-prompt :around
                                               :documentation "Makes
sure FIND-ALTERNATE-FILE-COMMAND provides the full pathname of the
current buffer as the default when prompting.")
    (p &optional pathname (buffer (current-buffer)))
  (let ((*change-default-for-file-prompt* t))
    (call-next-advice p pathname buffer)))

(defadvice (editor:find-alternate-file-command refresh :after
                                               :documentation "After
FIND-ALTERNATE-COMMAND has run makes sure the contents of the buffer
are consistent with the file on disk.")
    (p &optional pathname (buffer (current-buffer)))
  (declare (ignore p pathname))
  (let ((pathname (buffer-pathname buffer)))
    (unless (check-disk-version-consistent pathname buffer)
      (let* ((tn (probe-file pathname))
             (pn (or tn (editor::canonical-pathname pathname))))
        (editor::read-da-file pn tn buffer)))))

(defadvice (editor:prompt-for-file change-prompt :around
                                   :documentation "When DEFAULT-STRING
is NIL, DEFAULT is a pathname, and *CHANGE-DEFAULT-FOR-FILE-PROMPT* is
true sets the full namestring of DEFAULT to be the default string.")
    (&rest rest &key default default-string &allow-other-keys)
  (let ((default-string (cond (default-string)
                              ((and *change-default-for-file-prompt*
                                    (pathnamep default))
                               (namestring default))
                              ((pathnamep default)
                               (namestring (pathname-location default)))
                              (t default))))
    (apply #'call-next-advice
           :default-string default-string
           rest)))
                                        
(defadvice (editor::find-pattern region-only :around
                                 :documentation "Searches only up
until *SEARCH-END* unless the value of this variable is NIL.")
    (point pattern &optional limit)
  (cond ((and (null limit)
              *search-end*)
         (call-next-advice point pattern *search-end*))
        (t (call-next-advice point pattern limit))))

#-:editor-does-not-have-i-find-pattern
(defadvice (editor::i-find-pattern region-only :around
                                   :documentation "Searches only up
until *SEARCH-END* unless the value of this variable is NIL.")
    (point pattern &optional limit)
  (cond ((and (null limit)
              *search-end*)
         (call-next-advice point pattern *search-end*))
        (t (call-next-advice point pattern limit))))


(defadvice (editor::query-replace-string region-only :around
            :documentation "Performs
operation only up until *SEARCH-END* unless the value of this variable
is NIL.  Also makes sure that all replacements can be undone with one
undo command.")
           (&rest rest &key (point (current-point)) &allow-other-keys)
  (let* ((current-mark (and (variable-value-if-bound 'editor::active-region-overlay
                                                     :buffer (current-buffer))
                            (current-mark nil t)))
         (switch-p (and current-mark
                        (point< current-mark (current-point))))
         (*search-end* (and current-mark
                            (copy-point (cond (switch-p (current-point))
                                              (t current-mark)))))
         (start (cond ((and current-mark switch-p)
                       current-mark)
                      (current-mark (current-point))
                      (t point))))
    (unwind-protect
         (with-point ((%start start)
                      (%end (or *search-end*
                                (current-point))))
           (unless *search-end*
             (editor:buffer-end %end))
           #+:editor-has-dont-undo
           (recording-for-undo %start %end
             (apply #'call-next-advice :point start rest))
           ;; in new LispWorks versions it is no longer necessary to
           ;; record for undo here
           #-:editor-has-dont-undo          
           (apply #'call-next-advice :point start rest))
      (when *search-end*
        (delete-point *search-end*)))))

(defadvice (editor::find-next-ordinary-window allow-listener :around
                                              :documentation "Allows
the \"Next Ordinary Window\" command to switch to a listener window.")
    (current-window)
  (let ((*forbidden-buffers* (remove :listener *forbidden-buffers*)))
    (call-next-advice current-window)))

#+:editor-does-not-have-go-back
(defun push-onto-definitions-stack ()
  "Pushes current point onto *FIND-DEFINITIONS-STACK* unless the
buffer isn't selectable."
  (unless (editor::forbidden-buffer-p (current-buffer))
    (push (copy-point (current-point))
          *find-definitions-stack*)))

#+:editor-does-not-have-go-back
(defadvice (find-source-command push-onto-definitions-stack :around
                                :documentation "Pushes current point
onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))

#+:editor-does-not-have-go-back
(defadvice (find-source-for-dspec-command push-onto-definitions-stack :around
                                          :documentation "Pushes
current point onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))

#+:editor-does-not-have-go-back
(defadvice (find-command-definition-command push-onto-definitions-stack :around
                                            :documentation "Pushes
current point onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))

#+:editor-does-not-have-go-back
(defadvice (editor::edit-callers-command push-onto-definitions-stack :around
                                         :documentation "Pushes
current point onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))

#+:editor-does-not-have-go-back
(defadvice (editor::edit-callees-command push-onto-definitions-stack :around
                                         :documentation "Pushes
current point onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))

#+:editor-does-not-have-go-back
(defadvice (find-tag-command push-onto-definitions-stack :around
                             :documentation "Pushes current point onto
*FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))

#+:editor-does-not-have-go-back
(defadvice (tags-search-command push-onto-definitions-stack :around
                                :documentation "Pushes current point
onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (push-onto-definitions-stack)
  (apply #'call-next-advice args))

#+:editor-does-not-have-go-back
(defadvice (continue-tags-search-command push-onto-definitions-stack :around
                                         :documentation "Pushes
current point onto *FIND-DEFINITIONS-STACK*.")
    (&rest args)
  (when editor::*meta-comma-action*
    (push-onto-definitions-stack))
  (apply #'call-next-advice args))

(defun complete-system (string parse-inf)
  "Completion function used by PROMPT-FOR-ASDF-SYSTEM."
  (declare (ignore parse-inf))
  (editor::complete-string string *all-asdf-systems*
                           :ignore-case t))

(defun prompt-for-asdf-system (string &optional prompt help no-check)
  "Prompts for an ASDF system name with STRING being the default."
  (let ((*all-asdf-systems* (list-asdf-systems)))
    (editor::parse-for-something
     :prompt (or prompt "ASDF system: ")
     :must-exist t
     :help (or help "Type a name of an ASDF system.")
     :default (or string "")
     :default-string (or string "")
     :verify-func (if no-check
                    (lambda (string parse-inf)
                      (declare (ignore parse-inf))
                      string)
                    (lambda (string parse-inf)
                      (declare (ignore parse-inf))
                      (and (find string *all-asdf-systems* :test #'string-equal)
                           string)))
     :type :string
     :default-in-prompt nil
     :complete-func 'complete-system)))

(defun prompt-for-asdf-system-with-default (&optional prompt help no-check)
  "Prompts for an ASDF system name and tries to find a default in the
default directory of the current buffer."
  (let* ((directory (editor::buffer-default-directory (editor:current-buffer)))
         (candidate (first (directory (make-pathname :name nil
                                                     :type "asd"
                                                     :defaults directory))))
         (default (and candidate
                       (pathname-name candidate))))
    (prompt-for-asdf-system default prompt help no-check)))

(defun complete-shortcut (string parse-inf)
  "Completion function used by PROMPT-FOR-LISTENER-SHORTCUT."
  (declare (ignore parse-inf))
  (editor::complete-string string (mapcar #'cdr *listener-shortcuts*)
                           :ignore-case t))

(defun find-full-name (abbrev)
  "Given an abbreviation finds the first item in *LISTENER-SHORTCUTS*
that is named by this abbreviation."
  (or (loop for (short . long) in *listener-shortcuts*
            when (string-equal short abbrev)
            do (return long))
      (loop for (nil . long) in *listener-shortcuts*
            when (starts-with-p long abbrev)
              do (return long))))


(40ants-doc:defsection @listener-shortcuts (:title "Listener shortcuts"
                                            :ignore-words ("F1"))
  "
Similar to SLIME's slime-handle-repl-shortcut you can press `,`
(comma, for `Maybe Invoke Listener Shortcut`) in the listener and then
choose from a couple of shortcuts (see *LISTENER-SHORTCUTS*) to perform
administrative tasks like loading a system via ASDF or changing the current directory.

Type `F1` when prompted for a shortcut to see a list of what's available.

Currently there are shortcuts for:

- `Load ASDF System` (l),
- `Test ASDF System` (t),
- `Compile ASDF System` (c),
- `Change Package` (p),
- `Change Directory` (cd),
- `Show Directory` (pwd), and
- `Quit` (q or s)

See the documentation strings of these commands for details.

If Quicklisp is used, the first is changed to

- `Quickload Library` (l),

and loading with ASDF is changed to:

- `Load ASDF System` (a),

If you don't like this change and want the old behavior while using
Quicklisp simply switch *USE-QUICKLISP-FOR-SHORTCUT-L* to NIL.

"
  (:|Maybe Invoke Listener Shortcut| command)
  (:|Change Package| command)
  (:|Change Directory| command)
  (:|Show Directory| command)
  (:|Quit| command)
  (*listener-shortcuts* variable)
  (*use-quicklisp-for-shortcut-l* variable))


(defun prompt-for-listener-shortcut ()
  "Prompts for a listener shortcut."
  (let ((input
          (editor::parse-for-something
           :prompt (format nil "Shortcut [~{~A~^,~}] or Command: "
                           (sort (mapcar #'car *listener-shortcuts*) #'string-lessp))
           :must-exist t
           :help (format nil "Type the name or abbreviation of a listener shortcut:~%~%~{~A: ~A~%~}"
                         (loop for (short . long) in *listener-shortcuts*
                               collect short
                               collect long))
           :default ""
           :default-string ""
           :verify-func (lambda (string parse-inf)
                          (declare (ignore parse-inf))
                          (and (find-full-name string)
                               string))
           :type :string
           :default-in-prompt nil
           :complete-func 'complete-shortcut)))
    (find-full-name input)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (let ((*handle-warn-on-redefinition* :quiet))
    (defmacro with-input-from-region ((var start end) &body body &environment env)
      "During the evaluation of BODY, VAR is bound to a stream which
returns input from the region denoted by START and END."
      (multiple-value-bind (forms decls)
          (dspec:separate-declarations body env)
        `(let ((,var (pop editor::*free-editor-region-streams*)))
           ,@decls
           (setq ,var 
                 (if ,var
                   (editor::modify-editor-region-stream ,var ,start ,end)
                   (editor::make-editor-region-stream ,start ,end)))
           (unwind-protect
               (progn ,@forms)
             (editor::free-region-stream ,var)))))))

(defmacro with-compilation-environment-at-point ((point &key (compilep nil)
                                                             start-message
                                                             end-message)
                                                        &body body)
  (with-unique-names (buffer)
    `(editor::with-compilation-environment-at-point-fn
      ,point ,start-message ,end-message
      #'(lambda (,buffer)
          (let* ((,(if compilep '*compile-file-pathname* '*load-pathname*)
                  (buffer-pathname ,buffer))
                 (,(if compilep '*compile-file-truename* '*load-truename*)
                  (buffer-pathname ,buffer)) ; buffer-pathname _is_ a truename
                 )
            ,@body)))))

(defun returning-lisp-eval (buffer start end print)
  "Evaluates the region in the buffer BUFFER which is denoted by
START and END and returns the result."
  (with-compilation-environment-at-point (start :start-message "Evaluating..."
                                                :end-message (and (not (editor::windowp print))
                                                                  "Finished evaluating"))
    (with-input-from-region (stream start end)
      (let ((out-stream (if (streamp print)
                          print
                          (editor::buffer-stream buffer)))
            return-value)
        (handler-case
            (progn
              (common-utilities:load-text-stream
               stream
               :exit-load-p t
               :eval-function #'(lambda (form)
                                  (multiple-value-list
                                    (editor::editor-eval buffer form)))
               :print-function #'(lambda (result)
                                   (setq return-value result)
                                   (and print
                                        (if (editor::windowp print)
                                          (process-character
                                           `(message ,editor::*values-format-string* ,result)
                                           print)
                                          (editor::in-output-eval-results out-stream result)))))
              return-value)
          (end-of-file (x)
            (editor::report-region-lisp-eval-error "Incomplete S-expression in region " x)
            (return-from returning-lisp-eval nil))
          (reader-error (x)
            (editor::report-region-lisp-eval-error "Error while reading: ~a " x)
            (return-from returning-lisp-eval nil)))))))

(defmacro with-output-to-help-window ((stream &rest options) &body body)
  "Executes BODY with output that goes to STREAM redirected to an
IDE help window."
  `(editor::with-output-to-help-window-1
       #'(lambda (,stream) ,@body)
     ,@options))

(defun complete-package-name (string parse-inf)
  "Like the function of the same name in the EDITOR package, but
case-insensitive."
  (declare (ignore parse-inf))
  (editor::complete-string
   string
   (sort (loop for pkg in (list-all-packages)
               append (cons (package-name pkg) (package-nicknames pkg)))
         'string<)
   :ignore-case t))


(defun verify-package-func (string parse-inf)
  "Like the function of the same name in the EDITOR package, but
case-insensitive."
  (declare (type editor::parse-inf parse-inf))
  (or (find-package (ignore-errors* (read-from-string (string-upcase string))))
      (if (and (parse-inf-must-exist parse-inf)
	       (not (editor::recursive-parse 'prompt-for-y-or-n
                                             :prompt 
                                             "No such package.  Create it?")))
	  (values nil :no-value)
	(make-package string))))

(defun prompt-for-package* (&key (must-exist  t)
                                 (default *package*)
                                 (prompt  "package: ")
                                 (help  "Type a package name.")
                                 &allow-other-keys)
  "Like EDITOR:PROMPT-FOR-PACKAGE, but case-insensitive."
  (editor::parse-for-something :prompt prompt
                               :must-exist must-exist
                               :help help
                               :default default
                               :verify-func  'verify-package-func
                               :type :keyword
                               :complete-func 'complete-package-name
                               :default default))

(defun clean-namestring (namestring)
  "Replaces characters in NAMESTRING which are illegal for a filename
with underlines.  This function is aimed at Microsoft Windows but
shouldn't do any harm on OS X or Linux."
  (regex-replace-all "[\\\\/?*:<>|\"\\000-\\037]" namestring "_"))

(defun normalize-pathname-for-backup (pathname)
  "Converts the full form of the pathname designator PATHNAME to a
string that is suitable \(modulo illegal characters) as the NAME
component of a filename.  This is a simplified form of what GNU Emacs
does."
  (regex-replace-all "[/\\\\]" 
                     (regex-replace "^([a-zA-Z]):[/\\\\]"
                                    (namestring pathname)
                                    "!drive_\\1!")
                     "!"))


(40ants-doc:defsection @alternative-backups (:title "Alternative editor backups")
  "
LW-ADD-ONS can alter the way the IDE editor creates pathnames for backups. This might come in handy if you don't want your code directories to be cluttered with files like `foo.lisp~`. Read about *MAKE-BACKUP-FILENAME-FUNCTION*, MAKE-BACKUP-FILENAME-USING-BACKUP-DIRECTORY, and *BACKUP-DIRECTORY* and set these to values suiting your needs.

"
  (*make-backup-filename-function* variable)
  (*backup-directory* variable)
  (make-backup-filename-using-backup-directory function))


(defun make-backup-filename-using-backup-directory (pathname)
  "Creates and returns a backup pathname for PATHNAME.  Assumes that
*BACKUP-DIRECTORY* denotes a directory.  Note that due to the way the
backup pathname is constructed it is possible that two different files
end up with the same backup filename!"
  (ensure-directories-exist
   (make-pathname :name (clean-namestring
                         (normalize-pathname-for-backup pathname))
                  :type nil
                  :version nil
                  :defaults *backup-directory*)))

(defadvice (editor::make-backup-filename alternative-location :around
                                         :documentation "Circumvents
the original function if the variable *MAKE-BACKUP-FILENAME-FUNCTION*
specifies another function to be used instead.")
    (pathname)
  (cond (*make-backup-filename-function*
         (funcall *make-backup-filename-function* pathname))
        (t (call-next-advice pathname))))