home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #16 / NN_1992_16.iso / spool / comp / lang / lisp / mcl / 1094 < prev    next >
Encoding:
Text File  |  1992-07-29  |  1.9 KB  |  46 lines
  1. Path: sparky!uunet!sun-barr!olivea!apple!cambridge.apple.com!cornell@freya.cs.umass.edu
  2. From: cornell@freya.cs.umass.edu
  3. Newsgroups: comp.lang.lisp.mcl
  4. Subject: Bug and fix to mouse-copy.lisp (menu-of-defs-dialog's give-text)
  5. Message-ID: <9207291154.AA05828@giane.cs.umass.edu>
  6. Date: 29 Jul 92 11:54:33 GMT
  7. Sender: info-mcl-request@cambridge.apple.com
  8. Lines: 34
  9. Approved: comp.lang.lisp.mcl@Cambridge.Apple.C0M
  10. Original-To: info-mcl@cambridge.apple.com, bug-mcl@cambridge.apple.com
  11.  
  12. Following two changes are from my fixed version of mouse-copy.lisp.
  13.  
  14. matt
  15.  
  16.  
  17. #### From Change log ####
  18. ;; 07/29/92 mc  Fixed menu-of-defs-dialog's give-text to handle null
  19. ;;               packages. (mc = Matt Cornell, cornell@cs.umass.edu)
  20.  
  21. #### Replacement method ####
  22. (defmethod give-text ((w menu-of-defs-dialog))
  23.   (let* ((v (do-subviews (sv w 'sequence-dialog-item) (return sv)))
  24.          (cell (point-to-cell v (view-mouse-position w)))
  25.          ;; Below package was bound to (window-package (slot-value w 'my-window))
  26.          ;;  which caused an error in read-from-string when package was
  27.          ;;  nil. (Window-package is nil, for example, in "New" FRED
  28.          ;;  windows).
  29.          (package (or (window-package (slot-value w 'my-window)) *package*))
  30.          (contents (let ((*package* package))
  31.                      (read-from-string (car (cell-contents v cell))))))
  32.     (when cell
  33.       (let ((function (if (consp contents) (car contents) contents)))
  34.         (when (fboundp function)
  35.           (setq function (symbol-function function))
  36.           (setq * function)
  37.           (if (consp contents)
  38.             (let ((method (ignore-errors
  39.                            (nth-value 
  40.                             1 (%trace-function-spec-p
  41.                                (cons :method contents))))))
  42.               (when method (setq * method)))))))
  43.     (when (consp contents) (setq contents (car contents)))
  44.     (when cell
  45.       (format nil "~a" contents))))
  46.