lisp-lib.lisp 7.08 KB
Newer Older
ram's avatar
ram committed
1 2 3
;;; -*- Log: hemlock.log; Package: Hemlock -*-
;;;
;;; **********************************************************************
4 5 6 7
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
8
  "$Header: src/hemlock/lisp-lib.lisp $")
9
;;;
ram's avatar
ram committed
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46
;;; **********************************************************************
;;;
;;; This file contains code to peruse the CMU Common Lisp library of hacks.
;;;
;;; Written by Blaine Burks.
;;;

(in-package "HEMLOCK")


(defmode "Lisp-Lib" :major-p t)

;;; The library should be in *lisp-library-directory*

(defvar *lisp-library-directory*  "/afs/cs.cmu.edu/project/clisp/library/")

(defvar *selected-library-buffer* nil)


;;;; Commands.

(defcommand "Lisp Library" (p)
  "Goto buffer in 'Lisp-Lib' mode, creating one if necessary."
  "Goto buffer in 'Lisp-Lib' mode, creating one if necessary."
  (declare (ignore p))
  (when (not (and *selected-library-buffer*
		  (member *selected-library-buffer* *buffer-list*)))
    (when (getstring "Lisp Library" *buffer-names*)
      (editor-error "There is already a buffer named \"Lisp Library\"."))
    (setf *selected-library-buffer*
	  (make-buffer "Lisp Library" :modes '("Lisp-Lib")))
    (message "Groveling library ...")
    (let ((lib-directory (directory *lisp-library-directory*))
	  (lib-entries ()))
      (with-output-to-mark (s (buffer-point *selected-library-buffer*))
	(dolist (lib-spec lib-directory)
	  (let* ((path-parts (pathname-directory lib-spec))
ram's avatar
ram committed
47
		 (last (elt path-parts (1- (length path-parts))))
ram's avatar
ram committed
48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
		 (raw-pathname (merge-pathnames last lib-spec)))
	    (when (and (directoryp lib-spec)
		       (probe-file (merge-pathnames
				    (make-pathname :type "catalog")
				    raw-pathname)))
	      (push raw-pathname lib-entries)
	      (format s "~d~%" last)))))
      (defhvar "Library Entries"
	"Holds a list of library entries for the 'Lisp Library' buffer"
	:buffer *selected-library-buffer*
	:value (coerce (nreverse lib-entries) 'simple-vector))))
  (setf (buffer-writable *selected-library-buffer*) nil)
  (setf (buffer-modified *selected-library-buffer*) nil)
  (change-to-buffer *selected-library-buffer*)
  (buffer-start (current-point)))

(defcommand "Describe Pointer Library Entry" (p)
  "Finds the file that describes the lisp library entry indicated by the
   pointer."
  "Finds the file that describes the lisp library entry indicated by the
   pointer."
  (declare (ignore p))
  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
    (editor-error "Not in a Lisp Library buffer."))
  (describe-library-entry (array-element-from-pointer-pos
			   (value library-entries) "No entry on current line")))

(defcommand "Describe Library Entry" (p)
  "Find the file that describes the lisp library entry on the current line."
  "Find the file that describes the lisp library entry on the current line."
  (declare (ignore p))
  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
    (editor-error "Not in a Lisp Library buffer."))
  (describe-library-entry (array-element-from-mark (current-point)
			   (value library-entries) "No entry on current line")))

(defun describe-library-entry (pathname)
  (let ((lisp-buf (current-buffer))
	(buffer (view-file-command
		 nil
		 (merge-pathnames (make-pathname :type "catalog") pathname))))
    (push #'(lambda (buffer)
	      (declare (ignore buffer))
	      (setf lisp-buf nil))
	  (buffer-delete-hook lisp-buf))
    (setf (variable-value 'view-return-function :buffer buffer)
	  #'(lambda () (if lisp-buf
			   (change-to-buffer lisp-buf)
			   (lisp-library-command nil))))))

(defcommand "Load Library Entry" (p)
  "Loads the current library entry into the current slave."
  "Loads the current library entry into the current slave."
  (declare (ignore p))
  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
    (editor-error "Not in a Lisp Library buffer."))
  (string-eval (format nil "(load ~S)"
		       (namestring (library-entry-load-file nil)))))

(defcommand "Load Pointer Library Entry" (p)
  "Loads the library entry indicated by the mouse into the current slave."
  "Loads the library entry indicated by the mouse into the current slave."
  (declare (ignore p))
  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
    (editor-error "Not in a Lisp Library buffer."))
  (string-eval (format nil "(load ~S)"
		       (namestring (library-entry-load-file t)))))

(defcommand "Editor Load Library Entry" (p)
  "Loads the current library entry into the editor Lisp."
  "Loads the current library entry into the editor Lisp."
  (declare (ignore p))
  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
    (editor-error "Not in a Lisp Library buffer."))
  (in-lisp (load (library-entry-load-file nil))))

(defcommand "Editor Load Pointer Library Entry" (p)
  "Loads the library entry indicated by the mouse into the editor Lisp."
  "Loads the library entry indicated by the mouse into the editor Lisp."
  (declare (ignore p))
  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
    (editor-error "Not in a Lisp Library buffer."))
  (in-lisp (load (library-entry-load-file t))))

;;; LIBRARY-ENTRY-LOAD-FILE uses the mouse's position or the current point,
;;; depending on pointerp, to return a file that will load that library entry.
;;;
(defun library-entry-load-file (pointerp)
  (let* ((lib-entries (value library-entries))
	 (error-msg "No entry on current-line")
	 (base-name (if pointerp
			(array-element-from-pointer-pos lib-entries error-msg)
			(array-element-from-mark (current-point) lib-entries
						 error-msg)))
	 (parts (pathname-directory base-name))
	 (load-name (concatenate 'simple-string
ram's avatar
ram committed
144
				 "load-" (elt parts (1- (length parts)))))
ram's avatar
ram committed
145 146
	 (load-pathname (merge-pathnames load-name base-name))
	 (file-to-load
ram's avatar
ram committed
147 148 149 150 151 152 153 154 155 156 157
	  (or
	   (probe-file (compile-file-pathname load-pathname))
	   (probe-file (merge-pathnames (make-pathname :type "fasl")
					load-pathname))
	   (probe-file (merge-pathnames (make-pathname :type "lisp")
					load-pathname))
	   (probe-file (compile-file-pathname base-name))
	   (probe-file (merge-pathnames (make-pathname :type "fasl")
					base-name))
	   (probe-file (merge-pathnames (make-pathname :type "lisp")
					base-name)))))
ram's avatar
ram committed
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184
    (unless file-to-load (editor-error "You'll have to load it yourself."))
    file-to-load))

(defcommand "Exit Lisp Library" (p)
  "Exit Lisp-Lib Mode, deleting the buffer when possible."
  "Exit Lisp-Lib Mode, deleting the buffer when possible."
  (declare (ignore p))
  (unless (hemlock-bound-p 'library-entries :buffer (current-buffer))
    (editor-error "Not in a Lisp Library buffer."))
  (delete-buffer-if-possible (getstring "Lisp Library" *buffer-names*)))

(defcommand "Lisp Library Help" (p)
  "Show this help."
  "Show this help."
  (declare (ignore p))
  (describe-mode-command nil "Lisp-Lib"))


;;;; Utilities

(defun array-element-from-pointer-pos (vector &optional
					      (error-msg "Invalid line."))
  (multiple-value-bind (x y window) (last-key-event-cursorpos)
    (declare (ignore x window))
    (when (>= y (length vector))
      (editor-error error-msg))
    (svref vector y)))