[slime-cvs] CVS update: slime/present.lisp

[Matthias Koeppe]

Update of /project/slime/cvsroot/slime
In directory common-lisp.net:/tmp/cvs-serv6654

Modified Files:
	present.lisp 
Log Message:
Move presentation menu protocol to swank.lisp.

Date: Sun Sep 18 16:35:02 2005
Author: mkoeppe

Index: slime/present.lisp
diff -u slime/present.lisp:1.15 slime/present.lisp:1.16
--- slime/present.lisp:1.15	Tue Sep 13 01:07:21 2005
+++ slime/present.lisp	Sun Sep 18 16:35:02 2005
@@ -145,116 +145,6 @@
       (funcall continue)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; menu protocol
-;;
-;; To define a menu for a type of object, define a method
-;; menu-choices-for-presentation on that object type.  This function
-;; should return a list of two element lists where the first element is
-;; The name of the menu action and the second is a function that will be
-;; called if the menu is chosen. The function will be called with 3
-;; arguments:
-;;
-;; choice: The string naming the action from above
-;;
-;; object: The object 
-;;
-;; id: The presentation id of the object
-;;
-;; You might want append (when (next-method-p) (call-next-method)) to
-;; pick up the Menu actions of superclasses.
-;;
-
-(defvar *presentation-active-menu* nil)
-
-(defun menu-choices-for-presentation-id (id)
-  (multiple-value-bind (ob presentp) (lookup-presented-object id)
-    (cond ((not presentp) 'not-present)
-	  (t
-	   (let ((menu-and-actions (menu-choices-for-presentation ob)))
-	     (setq *presentation-active-menu* (cons id menu-and-actions))
-	     (mapcar 'car menu-and-actions))))))
-
-(defun swank-ioify (thing)
-  (cond ((keywordp thing) thing)
-	((and (symbolp thing)(not (find #\: (symbol-name thing))))
-	 (intern (symbol-name thing) 'swank-io-package))
-	((consp thing) (cons (swank-ioify (car thing)) (swank-ioify (cdr thing))))
-	(t thing)))
-
-(defun execute-menu-choice-for-presentation-id (id count item)
-  (let ((ob (lookup-presented-object id)))
-    (assert (equal id (car *presentation-active-menu*)) () 
-	    "Bug: Execute menu call for id ~a  but menu has id ~a"
-	    id (car *presentation-active-menu*))
-    (let ((action (second (nth (1- count) (cdr *presentation-active-menu*)))))
-      (swank-ioify (funcall action item ob id)))))
-
-;; Default method
-(defmethod menu-choices-for-presentation (ob)
-  (declare (ignore ob))
-  nil)
-
-;; Pathname
-(defmethod menu-choices-for-presentation ((ob pathname))
-  (let* ((file-exists (ignore-errors (probe-file ob)))
-	 (lisp-type (make-pathname :type "lisp"))
-	 (source-file (and (not (member (pathname-type ob) '("lisp" "cl") :test 'equal))
-			   (let ((source (merge-pathnames lisp-type ob)))
-			     (and (ignore-errors (probe-file source))
-				  source))))
-	 (fasl-file (and file-exists 
-			 (equal (ignore-errors
-				  (namestring
-				   (truename
-				    (compile-file-pathname
-				     (merge-pathnames lisp-type ob)))))
-				(namestring (truename ob))))))
-    (remove nil 
-	    (list*
-	     (and (and file-exists (not fasl-file))
-		  (list "Edit this file" 
-			(lambda(choice object id) 
-			  (declare (ignore choice id))
-			  (ed-in-emacs (namestring (truename object)))
-			  nil)))
-	     (and file-exists
-		  (list "Dired containing directory"
-			(lambda (choice object id)
-			  (declare (ignore choice id))
-			  (ed-in-emacs (namestring 
-					(truename
-					 (merge-pathnames
-					  (make-pathname :name "" :type "") object))))
-			  nil)))
-	     (and fasl-file
-		  (list "Load this fasl file"
-			(lambda (choice object id)
-			  (declare (ignore choice id object)) 
-			  (load ob)
-			  nil)))
-	     (and fasl-file
-		  (list "Delete this fasl file"
-			(lambda (choice object id)
-			  (declare (ignore choice id object)) 
-			  (let ((nt (namestring (truename ob))))
-			    (when (y-or-n-p-in-emacs "Delete ~a? " nt)
-			      (delete-file nt)))
-			  nil)))
-	     (and source-file 
-		  (list "Edit lisp source file" 
-			(lambda (choice object id) 
-			  (declare (ignore choice id object)) 
-			  (ed-in-emacs (namestring (truename source-file)))
-			  nil)))
-	     (and source-file 
-		  (list "Load lisp source file" 
-			(lambda(choice object id) 
-			  (declare (ignore choice id object)) 
-			  (load source-file)
-			  nil)))
-	     (and (next-method-p) (call-next-method))))))
-  
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;; Example: Tell openmcl and cmucl to always present unreadable objects. try (describe 'class) 
 #+openmcl