Re: Undefining

[liberte@cs.uiuc.edu (Daniel LaLiberte)]

Thanks to the contributions of Carl L. Gay and Steve Miner, I can offer
the following PD undefine.lisp.  (Carl is planning to include his version
of the same along with his package of other fred enhancements.)

Dan LaLiberte
liberte@cs.uiuc.edu
(Join the League for Programming Freedom: league@prep.ai.mit.edu)
-------------------------------------------------------------------
;;; -*- Package: CL-USER -*-

(in-package "CL-USER")

#|
undefine.lisp
Commands for undefining variables, functions, and methods 
defined at the top level.

Please send improvements.

Daniel LaLiberte
NCSA
liberte@ncsa.uiuc.edu
|#

(defparameter *prompt-to-undefine* nil)
(defparameter *offer-to-delete-definition* nil)


;;#################################################################
;; Some general utilities extracted from Carl's code.  liberte

(defun buffer-top-level-sexp-bounds (buffer)
  "Return the top-level sexp bounds, or nil if there is none.
The top level sexp starts with left paren in the first column.
The current position may be just before the left paren, 
or before the next top-level sexp."
  (let* ((sexp-start-string #.(format nil "~%("))
         (top-level-sexp-start
          (if (and (= (buffer-column buffer) 0)
                     (char-equal (buffer-char buffer) #\()) ;; looking at \(            (buffer-position buffer)
            (buffer-position buffer)
            (let ((foo (buffer-string-pos buffer sexp-start-string :from-end t)))
              (and foo (+ foo 1))))))
    (if (null top-level-sexp-start)
      nil
      (multiple-value-bind (sexp-start sexp-end)
                           (buffer-current-sexp-bounds buffer top-level-sexp-start)
        (if (null sexp-start)
          nil
          (values sexp-start sexp-end))
        ))))

(defun buffer-top-level-sexp (buffer)
  "Return the top-level sexp or nil if none."
  (let ((start (buffer-top-level-sexp-bounds buffer)))
    (if start
      (buffer-current-sexp buffer start)
      nil)))

#|#################################################################
From: "Carl L. Gay" <cgay@skinner.cs.uoregon.edu>

[Modified to:
  - use buffer-top-level-sexp-bounds
  - call Steve Miner's undefmethod
 liberte]

|#
;;; ________________________________________
;;; Kill Definition 

;;; Find the definition under the cursor, determine if it's killable, if so
;;; prompt the user, kill the definition, and then optionally remove the
;;; definition from the buffer (or comment it out?)

(defmethod ed-undefine ((w fred-window))
  (flet ((set-minibuffer (&rest args) (ed-beep) (apply 'set-mini-buffer w args)))
    ;; error exit might be better
    (let* ((buffer (fred-buffer w))
           (sexp-start (buffer-top-level-sexp-bounds buffer))
           (sexp (buffer-current-sexp buffer sexp-start))
           (defining-form nil)
           (undefine-fun nil))
      (if (or (atom sexp)
              (not (atom (setq defining-form (car sexp))))
              (not (setq undefine-fun (get (car sexp) 'undefine))))
        (set-minibuffer "Don't know how to undefine ~A."
                        (if defining-form (format nil "a ~A" defining-form) sexp))
        (let ((definition-name (second sexp)))
          (catch-cancel
            (when (or (null *prompt-to-undefine*)
                      (y-or-n-dialog (format nil "Undefine ~S ~S?"
                                             defining-form definition-name)))
              (format t "un-~s: ~A~%" defining-form 
                      (apply undefine-fun (cdr sexp))))
            (when (and *offer-to-delete-definition*
                       (y-or-n-dialog (format nil "Remove definition of ~S ~S from buffer?"
                                              defining-form definition-name)))
              (multiple-value-bind (sexp-start sexp-end)
                                   (buffer-current-sexp-bounds buffer sexp-start)
                (buffer-delete buffer sexp-start sexp-end))
              )))))))

;;(comtab-set-key *control-x-comtab* '(:control :meta #\d) 'ed-undefine)
  (def-fred-command (:control #\z) ed-undefine)

(defun undefine-variable (symbol &rest qlb)
  (declare (ignore qlb))
  (if (boundp symbol)
    (makunbound symbol)))

(defun undefine-defun (symbol &rest qlb)
  (declare (ignore qlb))
  (if (fboundp symbol)
    (fmakunbound symbol)))

(defun undefine-defmethod (symbol &rest qlb)
  (eval `(undefmethod ,symbol ,@qlb)))

(dolist (foo '(defvar defparameter defconstant))
  (setf (get foo 'undefine) 'undefine-variable))

(setf (get 'defun 'undefine) 'undefine-defun)
(setf (get 'defmacro 'undefine) 'undefine-defun)
(setf (get 'defmethod 'undefine) 'undefine-defmethod)


#|
The following is for undefining methods only.
From: Steve Miner
 PW Tech Centre
 miner@tc.pw.com
[Modified ed-undefmethod to look for top-level sexp. - liberte]
|#

(defun remove-lambda-keywords (lambda-list)
  (cond ((endp lambda-list) nil)
        ((member (car lambda-list) lambda-list-keywords :test #'eq)
	 nil)
        (t (cons (car lambda-list) (remove-lambda-keywords 
                                    (cdr lambda-list))))))


(defun class-list-spec (lambda-list)
  (mapcar #'(lambda (arg) (cond ((symbolp arg) '(find-class 't))
                                ((symbolp (cadr arg)) `(find-class
							',(cadr arg)))
                                ((eq (caadr arg) 'eql) `(list 'eql
							 ,(cadadr
							   arg)))
                                (t (error "Malformed lambda-list ~S."
					  lambda-list))))
          (remove-lambda-keywords lambda-list)))

;;; NOTE: the order of the method qualifiers is significant so the
;;; NREVERSE is necessary.
(defun get-lambda-and-quals (qlb)
  "Returns multiple values, the lambda-list and the list of method
qualifiers, from the QLB which is a list of method qualifiers, a
lambda list and a body (essentially the method definition without the 
DEFMETHOD or the method name -- the CDDR of the method definition if
you will.)"
  (let ((quals nil))
    (dolist (x qlb)
      (if (listp x)
	  (return (values x (nreverse quals)))
	  (push x quals)))))



(defmacro undefmethod (name &rest qlb)
  "Removes method that is specified using the same syntax as
DEFMETHOD.  The body is ignored.
With this macro, you could just change your defmethod to undefmethod, 
and evaluate it to undefine it."
  ;; QLB could be qualifier, lambda list, and body.  We'll end up
  ;; ignoring the body
  (multiple-value-bind (lambda-list quals) (get-lambda-and-quals qlb)
    `(let* ((func (symbol-function ',name))
            (meth (find-method func ',quals 
                               (list ,@(class-list-spec lambda-list))
			       nil)))
       (when meth
         (remove-method func meth)
         (values meth :undefmethod)))))


(defmacro find-defmethod (name &rest qlb)
  "Finds method that is specified using the same syntax as DEFMETHOD.
The body is ignored."
  ;; QLB could be qualifier, lambda list, and body.  We'll end up
  ;; ignoring the body
  (multiple-value-bind (lambda-list quals) (get-lambda-and-quals qlb)
    `(find-method (symbol-function ',name) ',quals 
                  (list ,@(class-list-spec lambda-list)) nil)))


;;; Bind this to a Fred Key
(defmethod ed-undefmethod ((w fred-window))
  "Undefine the method defined by the surrounding defmethod."
  (let ((sexp (buffer-top-level-sexp (fred-buffer w))))
    (if (and sexp (eq (car sexp) 'defmethod))
      (format t "undefmethod ~A~%" (eval (cons 'undefmethod (cdr sexp))))
      (ed-beep))))

;For example,
;  (def-fred-command (:control #\z) ed-undefmethod)