| [6] | 1 | ;;; -*- Log: hemlock.log; Package: hemlock -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; **********************************************************************
|
|---|
| 4 | ;;; This code was written as part of the CMU Common Lisp project at
|
|---|
| 5 | ;;; Carnegie Mellon University, and has been placed in the public domain.
|
|---|
| 6 | ;;;
|
|---|
| 7 | #+CMU (ext:file-comment
|
|---|
| 8 | "$Header$")
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; **********************************************************************
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; Editing DEFMACRO and DEFUN definitions. Also, has directory translation
|
|---|
| 13 | ;;; code for moved and/or different sources.
|
|---|
| 14 | ;;;
|
|---|
| 15 |
|
|---|
| 16 | (in-package :hemlock)
|
|---|
| 17 |
|
|---|
| 18 |
|
|---|
| 19 | ;;; Definition Editing Commands.
|
|---|
| 20 |
|
|---|
| 21 |
|
|---|
| 22 |
|
|---|
| 23 | ;;; For the "Go to Definition" search pattern, we just use " " as the initial
|
|---|
| 24 | ;;; pattern, so we can make a search pattern. Invocation of the command alters
|
|---|
| 25 | ;;; the search pattern.
|
|---|
| 26 |
|
|---|
| 27 | (defvar *go-to-def-pattern*
|
|---|
| 28 | (new-search-pattern :string-insensitive :forward " "))
|
|---|
| 29 |
|
|---|
| 30 | (defvar *last-go-to-def-string* "")
|
|---|
| 31 | (declaim (simple-string *last-go-to-def-string*))
|
|---|
| 32 |
|
|---|
| [16082] | 33 | (defun symbol-at-point (buffer)
|
|---|
| [7129] | 34 | "Returns symbol at point, or contents of selection if there is one"
|
|---|
| [16082] | 35 | (let ((point (buffer-point buffer))
|
|---|
| 36 | (mark (buffer-mark buffer)))
|
|---|
| 37 | (if (and (hi::%buffer-current-region-p buffer)
|
|---|
| 38 | (not (mark= mark point)))
|
|---|
| 39 | (string-trim '(#\space #\tab)
|
|---|
| 40 | (region-to-string (if (mark< mark point)
|
|---|
| 41 | (region mark point)
|
|---|
| 42 | (region point mark))))
|
|---|
| 43 | (symbol-at-mark point))))
|
|---|
| 44 |
|
|---|
| 45 | (defun symbol-at-mark (mark)
|
|---|
| 46 | (with-mark ((mark1 mark)
|
|---|
| 47 | (mark2 mark))
|
|---|
| 48 | ;; This doesn't handle embedded #'s or escaped chars in names.
|
|---|
| 49 | ;; So let them report it as a bug...
|
|---|
| 50 | (when (test-char (previous-character mark) :lisp-syntax :constituent)
|
|---|
| 51 | (or (rev-scan-char mark1 :lisp-syntax (not :constituent))
|
|---|
| 52 | (buffer-start mark1))
|
|---|
| 53 | (scan-char mark1 :lisp-syntax :constituent))
|
|---|
| 54 | (when (test-char (next-character mark) :lisp-syntax :constituent)
|
|---|
| 55 | (or (scan-char mark2 :lisp-syntax (not :constituent))
|
|---|
| 56 | (buffer-end mark2)))
|
|---|
| 57 | (when (mark= mark1 mark2)
|
|---|
| 58 | ;; Try to get whole form
|
|---|
| 59 | (pre-command-parse-check mark)
|
|---|
| 60 | (move-mark mark1 mark)
|
|---|
| 61 | (form-offset mark1 -1)
|
|---|
| 62 | (move-mark mark2 mark1)
|
|---|
| 63 | (form-offset mark2 1))
|
|---|
| [13427] | 64 | (loop until (or (mark= mark1 mark2) (not (eql (previous-character mark2) #\:)))
|
|---|
| [16082] | 65 | do (mark-before mark2))
|
|---|
| 66 | (when (and (eql (previous-character mark1) #\#) (eql (next-character mark1) #\<))
|
|---|
| 67 | (mark-after mark1))
|
|---|
| [7129] | 68 | (unless (mark= mark1 mark2)
|
|---|
| 69 | (region-to-string (region mark1 mark2)))))
|
|---|
| [6] | 70 |
|
|---|
| 71 | (defcommand "Goto Definition" (p)
|
|---|
| [7129] | 72 | "Go to the current function/macro's definition. With a numarg, prompts for name to go to."
|
|---|
| 73 | (if p
|
|---|
| 74 | (edit-definition-command nil)
|
|---|
| [16082] | 75 | (let* ((buffer (current-buffer))
|
|---|
| 76 | (fun-name (symbol-at-point buffer)))
|
|---|
| [7129] | 77 | (if fun-name
|
|---|
| 78 | (get-def-info-and-go-to-it fun-name (or
|
|---|
| [16082] | 79 | (buffer-package buffer)
|
|---|
| [7129] | 80 | *package*))
|
|---|
| 81 | (beep)))))
|
|---|
| [6] | 82 |
|
|---|
| 83 | (defcommand "Edit Definition" (p)
|
|---|
| 84 | "Prompts for function/macro's definition name and goes to it for editing."
|
|---|
| 85 | (declare (ignore p))
|
|---|
| 86 | (let ((fun-name (prompt-for-string
|
|---|
| 87 | :prompt "Name: "
|
|---|
| 88 | :help "Symbol name of function.")))
|
|---|
| [6700] | 89 | (get-def-info-and-go-to-it fun-name (or
|
|---|
| [8464] | 90 | (buffer-package (current-buffer))
|
|---|
| 91 | *package*))))
|
|---|
| [6] | 92 |
|
|---|
| [8428] | 93 | (defun get-def-info-and-go-to-it (string package)
|
|---|
| 94 | (multiple-value-bind (fun-name error)
|
|---|
| 95 | (let* ((*package* (ccl:require-type package 'package)))
|
|---|
| 96 | (ignore-errors (values (read-from-string string))))
|
|---|
| 97 | (if error
|
|---|
| 98 | (editor-error "unreadable name: ~s" string)
|
|---|
| [12235] | 99 | (handler-case (edit-definition fun-name)
|
|---|
| [13186] | 100 | (error (c) (editor-error "~a" c))))))
|
|---|
| 101 |
|
|---|
| [6] | 102 | (defcommand "Edit Command Definition" (p)
|
|---|
| 103 | "Prompts for command definition name and goes to it for editing."
|
|---|
| 104 | (multiple-value-bind
|
|---|
| 105 | (name command)
|
|---|
| 106 | (if p
|
|---|
| [8428] | 107 | (multiple-value-bind (key cmd)
|
|---|
| 108 | (prompt-for-key :prompt "Edit command bound to: "
|
|---|
| 109 | :must-exist t)
|
|---|
| 110 | (declare (ignore key))
|
|---|
| 111 | (values (command-name cmd) cmd))
|
|---|
| 112 | (prompt-for-keyword :tables (list *command-names*)
|
|---|
| 113 | :prompt "Command to edit: "))
|
|---|
| [12878] | 114 | (declare (ignore name))
|
|---|
| 115 | (handler-case (edit-definition (command-function command))
|
|---|
| [13186] | 116 | (error (c) (editor-error "~a" c)))))
|
|---|
| [6] | 117 |
|
|---|
| [12878] | 118 | #|
|
|---|
| [8428] | 119 | ;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object. It
|
|---|
| 120 | ;;; returns a pathname for the file the function was defined in. If it was
|
|---|
| 121 | ;;; not defined in some file, then nil is returned.
|
|---|
| 122 | ;;;
|
|---|
| 123 | (defun fun-defined-from-pathname (function)
|
|---|
| 124 | "Takes a symbol or function and returns the pathname for the file the
|
|---|
| 125 | function was defined in. If it was not defined in some file, nil is
|
|---|
| 126 | returned."
|
|---|
| 127 | (flet ((true-namestring (path) (namestring (truename path))))
|
|---|
| 128 | (typecase function
|
|---|
| 129 | (function (fun-defined-from-pathname (ccl:function-name function)))
|
|---|
| 130 | (symbol (let* ((info (ccl::%source-files function)))
|
|---|
| 131 | (if (atom info)
|
|---|
| 132 | (true-namestring info)
|
|---|
| 133 | (let* ((finfo (assq 'function info)))
|
|---|
| 134 | (when finfo
|
|---|
| 135 | (true-namestring
|
|---|
| 136 | (if (atom finfo)
|
|---|
| 137 | finfo
|
|---|
| 138 | (car finfo)))))))))))
|
|---|
| 139 |
|
|---|
| [6] | 140 | ;;; GO-TO-DEFINITION tries to find name in file with a search pattern based
|
|---|
| 141 | ;;; on type (defun or defmacro). File may be translated to another source
|
|---|
| 142 | ;;; file, and if type is a function that cannot be found, we try to find a
|
|---|
| 143 | ;;; command by an appropriate name.
|
|---|
| 144 | ;;;
|
|---|
| 145 | (defun go-to-definition (file type name)
|
|---|
| 146 | (let ((pattern (get-definition-pattern type name)))
|
|---|
| 147 | (cond
|
|---|
| 148 | (file
|
|---|
| 149 | (setf file (go-to-definition-file file))
|
|---|
| [8428] | 150 | (let* ((buffer (old-find-file-command nil file))
|
|---|
| [6] | 151 | (point (buffer-point buffer))
|
|---|
| 152 | (name-len (length name)))
|
|---|
| 153 | (declare (fixnum name-len))
|
|---|
| 154 | (with-mark ((def-mark point))
|
|---|
| 155 | (buffer-start def-mark)
|
|---|
| 156 | (unless (find-pattern def-mark pattern)
|
|---|
| 157 | (if (and (or (eq type :function) (eq type :unknown-function))
|
|---|
| 158 | (> name-len 7)
|
|---|
| 159 | (string= name "COMMAND" :start1 (- name-len 7)))
|
|---|
| 160 | (let ((prev-search-str *last-go-to-def-string*))
|
|---|
| 161 | (unless (find-pattern def-mark
|
|---|
| 162 | (get-definition-pattern :command name))
|
|---|
| 163 | (editor-error "~A is not defined with ~S or ~S, ~
|
|---|
| 164 | but this is the defined-in file."
|
|---|
| 165 | (string-upcase name) prev-search-str
|
|---|
| 166 | *last-go-to-def-string*)))
|
|---|
| 167 | (editor-error "~A is not defined with ~S, ~
|
|---|
| 168 | but this is the defined-in file."
|
|---|
| 169 | (string-upcase name) *last-go-to-def-string*)))
|
|---|
| 170 | (if (eq buffer (current-buffer))
|
|---|
| [8428] | 171 | (push-new-buffer-mark point))
|
|---|
| [6] | 172 | (move-mark point def-mark))))
|
|---|
| 173 | (t
|
|---|
| 174 | (when (or (eq type :unknown-function) (eq type :unknown-macro))
|
|---|
| 175 | (with-mark ((m (buffer-start-mark (current-buffer))))
|
|---|
| 176 | (unless (find-pattern m pattern)
|
|---|
| 177 | (editor-error
|
|---|
| 178 | "~A is not compiled and not defined in current buffer with ~S"
|
|---|
| 179 | (string-upcase name) *last-go-to-def-string*))
|
|---|
| 180 | (let ((point (current-point)))
|
|---|
| [8428] | 181 | (push-new-buffer-mark point)
|
|---|
| [6] | 182 | (move-mark point m))))))))
|
|---|
| [8428] | 183 | |#
|
|---|
| [6] | 184 |
|
|---|
| [12635] | 185 | (defparameter *type-defining-operators* ())
|
|---|
| [6] | 186 |
|
|---|
| [12635] | 187 | (defun define-type-defining-operators (name &rest operators)
|
|---|
| 188 | (assert (subtypep name 'ccl::definition-type))
|
|---|
| 189 | (let ((a (assoc name *type-defining-operators*)))
|
|---|
| 190 | (when (null a)
|
|---|
| 191 | (push (setq a (cons name nil)) *type-defining-operators*))
|
|---|
| 192 | (loop for op in operators do (pushnew op (cdr a)))
|
|---|
| 193 | name))
|
|---|
| [6] | 194 |
|
|---|
| [12635] | 195 | (defun type-defining-operator-p (def-type operator)
|
|---|
| 196 | (loop for (type . ops) in *type-defining-operators*
|
|---|
| 197 | thereis (and (typep def-type type) (memq operator ops))))
|
|---|
| [6] | 198 |
|
|---|
| [12635] | 199 | (define-type-defining-operators 'ccl::class-definition-type 'defclass)
|
|---|
| 200 | (define-type-defining-operators 'ccl::type-definition-type 'deftype)
|
|---|
| 201 | (define-type-defining-operators 'ccl::function-definition-type 'defun 'defmacro 'defgeneric #+x8664-target 'ccl::defx86lapfunction #+ppc-target 'ccl::defppclapfunction)
|
|---|
| 202 | (define-type-defining-operators 'ccl::constant-definition-type 'defconstant)
|
|---|
| 203 | (define-type-defining-operators 'ccl::variable-definition-type 'defvar 'defparameter 'ccl::defstatic 'ccl::defglobal)
|
|---|
| 204 | (define-type-defining-operators 'ccl::method-combination-definition-type 'define-method-combination)
|
|---|
| 205 | (define-type-defining-operators 'ccl::compiler-macro-definition-type 'define-compiler-macro)
|
|---|
| [6] | 206 |
|
|---|
| [6700] | 207 |
|
|---|
| 208 | (defun match-definition-context-for-method (end-mark package indicator)
|
|---|
| 209 | (let* ((specializers (openmcl-mop:method-specializers indicator))
|
|---|
| 210 | (qualifiers (openmcl-mop:method-qualifiers indicator)))
|
|---|
| 211 | (block win
|
|---|
| 212 | (with-mark ((work end-mark))
|
|---|
| 213 | (when qualifiers
|
|---|
| 214 | (dotimes (i (length qualifiers))
|
|---|
| 215 | (unless (and (form-offset end-mark 1)
|
|---|
| 216 | (progn
|
|---|
| 217 | (move-mark work end-mark)
|
|---|
| 218 | (form-offset work -1)))
|
|---|
| 219 | (return-from win nil))
|
|---|
| 220 | (let* ((qualifier (ignore-errors
|
|---|
| 221 | (let* ((*package* package))
|
|---|
| 222 | (values
|
|---|
| 223 | (read-from-string (region-to-string
|
|---|
| 224 | (region
|
|---|
| 225 | work
|
|---|
| 226 | end-mark))))))))
|
|---|
| 227 | (unless (member qualifier qualifiers)
|
|---|
| 228 | (return-from win nil)))))
|
|---|
| 229 | ;; end-mark is now either at end of last qualifier or
|
|---|
| 230 | ;; after method name. Try to read the lambda list and
|
|---|
| 231 | ;; match specializers.
|
|---|
| 232 | (unless (and (form-offset end-mark 1)
|
|---|
| 233 | (progn
|
|---|
| 234 | (move-mark work end-mark)
|
|---|
| 235 | (form-offset work -1)))
|
|---|
| 236 | (return-from win nil))
|
|---|
| 237 | (multiple-value-bind (lambda-list error)
|
|---|
| 238 | (ignore-errors
|
|---|
| 239 | (let* ((*package* package))
|
|---|
| 240 | (values
|
|---|
| 241 | (read-from-string (region-to-string
|
|---|
| 242 | (region
|
|---|
| 243 | work
|
|---|
| 244 | end-mark))))))
|
|---|
| 245 | (unless (and (null error)
|
|---|
| 246 | (consp lambda-list)
|
|---|
| 247 | (ccl::proper-list-p lambda-list))
|
|---|
| 248 | (return-from win nil))
|
|---|
| 249 | (flet ((match-specializer (spec)
|
|---|
| 250 | (when lambda-list
|
|---|
| 251 | (let* ((arg (pop lambda-list)))
|
|---|
| 252 | (typecase spec
|
|---|
| 253 | (ccl::eql-specializer
|
|---|
| 254 | (let* ((obj (openmcl-mop:eql-specializer-object spec)))
|
|---|
| 255 | (and (ccl::proper-list-p arg)
|
|---|
| 256 | (= 2 (length arg))
|
|---|
| 257 | (symbolp (pop arg))
|
|---|
| 258 | (ccl::proper-list-p (setq arg (car arg)))
|
|---|
| 259 | (= (length arg) 2)
|
|---|
| 260 | (eq (car arg) 'eql)
|
|---|
| 261 | (eql (cadr arg) obj))))
|
|---|
| 262 | (class
|
|---|
| 263 | (let* ((name (class-name spec)))
|
|---|
| [12235] | 264 | (or (and (eq name t) (symbolp arg))
|
|---|
| [6700] | 265 | (and (consp arg)
|
|---|
| 266 | (symbolp (car arg))
|
|---|
| 267 | (consp (cdr arg))
|
|---|
| 268 | (null (cddr arg))
|
|---|
| 269 | (eq name (cadr arg)))))))))))
|
|---|
| 270 | (dolist (spec specializers t)
|
|---|
| 271 | (unless (match-specializer spec)
|
|---|
| 272 | (return nil)))))))))
|
|---|
| 273 |
|
|---|
| [12635] | 274 | ;;; START and END delimit a function name that matches what we're looking for
|
|---|
| 275 | (defun match-context-for-indicator (start end def-type full-name)
|
|---|
| [6700] | 276 | (with-mark ((op-start start)
|
|---|
| 277 | (op-end start))
|
|---|
| 278 | (and (form-offset op-start -1)
|
|---|
| 279 | (progn
|
|---|
| 280 | (move-mark op-end op-start)
|
|---|
| 281 | (form-offset op-end 1))
|
|---|
| [12635] | 282 | (let* ((package (or (find-package (variable-value 'current-package :buffer (current-buffer)))
|
|---|
| 283 | *package*))
|
|---|
| 284 | (defining-operator
|
|---|
| [6700] | 285 | (ignore-errors
|
|---|
| 286 | (let* ((*package* package))
|
|---|
| 287 | (values (read-from-string (region-to-string (region op-start op-end))))))))
|
|---|
| [12635] | 288 | (and (type-defining-operator-p def-type defining-operator)
|
|---|
| 289 | (or (not (typep full-name 'method))
|
|---|
| 290 | (match-definition-context-for-method end package full-name)))))))
|
|---|
| [6700] | 291 |
|
|---|
| [12635] | 292 | (defun match-definition-context (mark def-type full-name)
|
|---|
| [6700] | 293 | (pre-command-parse-check mark)
|
|---|
| 294 | (when (valid-spot mark t)
|
|---|
| 295 | (with-mark ((start mark)
|
|---|
| 296 | (end mark))
|
|---|
| 297 | (and (form-offset end 1)
|
|---|
| 298 | (progn
|
|---|
| 299 | (move-mark start end)
|
|---|
| 300 | (form-offset start -1))
|
|---|
| [12635] | 301 | (let ((package (or (find-package (variable-value 'current-package :buffer (current-buffer)))
|
|---|
| 302 | *package*)))
|
|---|
| 303 | (eq (ccl::definition-base-name def-type full-name)
|
|---|
| 304 | (ignore-errors
|
|---|
| 305 | (let* ((*package* package))
|
|---|
| 306 | (values (read-from-string (region-to-string (region start end))))))))
|
|---|
| 307 | (match-context-for-indicator start end def-type full-name)))))
|
|---|
| [8428] | 308 |
|
|---|
| [12635] | 309 | (defun find-definition-by-context (def-type full-name)
|
|---|
| 310 | (let* ((base-name (ccl::definition-base-name def-type full-name))
|
|---|
| 311 | (string (string base-name))
|
|---|
| [12651] | 312 | (pattern (new-search-pattern :string-insensitive :forward string))
|
|---|
| 313 | (found 0))
|
|---|
| 314 | (with-mark ((mark (buffer-start-mark (current-buffer))))
|
|---|
| 315 | (when (or (loop
|
|---|
| 316 | while (and (find-pattern mark pattern) (incf found))
|
|---|
| 317 | thereis (and (match-definition-context mark def-type full-name)
|
|---|
| 318 | (backward-up-list mark))
|
|---|
| 319 | do (character-offset mark 1))
|
|---|
| 320 | ;; if there is only one instance, just go there
|
|---|
| 321 | (and (eql found 1) (find-pattern (buffer-start mark) pattern))
|
|---|
| 322 | ;; Else should try again, being less strict...
|
|---|
| 323 | )
|
|---|
| [12635] | 324 | (move-point-leaving-mark mark)))))
|
|---|
| 325 |
|
|---|
| 326 | (defun move-point-leaving-mark (target)
|
|---|
| [12651] | 327 | (let ((point (current-point-collapsing-selection)))
|
|---|
| [12635] | 328 | (push-new-buffer-mark point)
|
|---|
| 329 | (move-mark point target)
|
|---|
| 330 | point))
|
|---|
| 331 |
|
|---|
| [14480] | 332 | ;;; Adjust for CRLF line termination. Multibyte character encodings
|
|---|
| 333 | ;;; can also cause discrepancies between physical/logical positions.
|
|---|
| 334 | ;;; Handling that would require making the source location stuff
|
|---|
| 335 | ;;; aware of that newfangled Unicode thing ...
|
|---|
| 336 | (defun byte-position-to-character-position (pos &optional (buffer (current-buffer)))
|
|---|
| 337 | (let* ((line-termination (hi::buffer-line-termination buffer)))
|
|---|
| 338 | (if (eq line-termination :crlf)
|
|---|
| 339 | (- pos (hi::buffer-lines-before-absolute-position buffer pos))
|
|---|
| 340 | pos)))
|
|---|
| 341 |
|
|---|
| [12635] | 342 | (defun move-to-source-note (source)
|
|---|
| 343 | (let ((start-pos (ccl:source-note-start-pos source)))
|
|---|
| 344 | (when start-pos
|
|---|
| [14480] | 345 | (setq start-pos (byte-position-to-character-position start-pos))
|
|---|
| [12635] | 346 | (let ((full-text (ccl:source-note-text source))
|
|---|
| 347 | (pattern nil)
|
|---|
| 348 | (offset 0))
|
|---|
| [15315] | 349 | (flet ((ssearch (mark string direction)
|
|---|
| [12635] | 350 | (find-pattern mark
|
|---|
| 351 | (setq pattern (new-search-pattern :string-insensitive
|
|---|
| 352 | direction
|
|---|
| 353 | string
|
|---|
| 354 | pattern)))))
|
|---|
| [15315] | 355 | (declare (inline ssearch))
|
|---|
| [12635] | 356 | (with-mark ((temp-mark (current-point)))
|
|---|
| 357 | (unless full-text
|
|---|
| 358 | ;; Someday, might only store a snippet for toplevel, so inner notes
|
|---|
| 359 | ;; might not have text, but can still find them through the toplevel.
|
|---|
| 360 | (let* ((toplevel (ccl::source-note-toplevel-note source))
|
|---|
| 361 | (toplevel-start-pos (and (not (eq toplevel source))
|
|---|
| [12651] | 362 | (ccl:source-note-start-pos toplevel)))
|
|---|
| 363 | (text (and toplevel-start-pos (ccl:source-note-text toplevel))))
|
|---|
| 364 | (when text
|
|---|
| [14480] | 365 | (setq toplevel-start-pos (byte-position-to-character-position toplevel-start-pos))
|
|---|
| [12635] | 366 | (setq offset (- start-pos toplevel-start-pos))
|
|---|
| 367 | (setq start-pos toplevel-start-pos)
|
|---|
| [12651] | 368 | (setq full-text text)
|
|---|
| 369 | (character-offset temp-mark (- offset)))))
|
|---|
| 370 | (unless (move-to-absolute-position temp-mark start-pos)
|
|---|
| 371 | (buffer-end temp-mark))
|
|---|
| 372 |
|
|---|
| [12635] | 373 | (when (or (null full-text)
|
|---|
| [15315] | 374 | (or (ssearch temp-mark full-text :forward)
|
|---|
| 375 | (ssearch temp-mark full-text :backward))
|
|---|
| [12635] | 376 | ;; Maybe body changed, try at least to match the start of it
|
|---|
| 377 | (let ((snippet (and (> (length full-text) 60) (subseq full-text 0 60))))
|
|---|
| 378 | (and snippet
|
|---|
| [15315] | 379 | (or (ssearch temp-mark snippet :forward)
|
|---|
| 380 | (ssearch temp-mark snippet :backward)))))
|
|---|
| [12635] | 381 | (let ((point (move-point-leaving-mark temp-mark)))
|
|---|
| 382 | (or (character-offset point offset)
|
|---|
| 383 | (buffer-end point))))))))))
|
|---|
| 384 |
|
|---|
| 385 | (defun find-definition-in-buffer (def-type full-name source)
|
|---|
| 386 | (or (and (ccl:source-note-p source)
|
|---|
| 387 | (move-to-source-note source))
|
|---|
| 388 | (find-definition-by-context def-type full-name)
|
|---|
| 389 | (editor-error "Couldn't find definition for ~s" full-name)))
|
|---|
| 390 |
|
|---|
| 391 | ;; Note this isn't necessarily called from hemlock, e.g. it might be called by cl:ed,
|
|---|
| 392 | ;; from any thread, or it might be called from a sequence dialog, etc.
|
|---|
| 393 | (defun edit-definition (name)
|
|---|
| 394 | (flet ((get-source-alist (name)
|
|---|
| 395 | (let ((list (ccl:find-definition-sources name t)))
|
|---|
| 396 | ;; filter interactive-only defs
|
|---|
| 397 | (loop for (id . sources) in list as source = (find-if-not #'null sources)
|
|---|
| 398 | when source collect (cons id source))))
|
|---|
| 399 | (defn-name (defn stream)
|
|---|
| 400 | (destructuring-bind (dt . full-name) (car defn)
|
|---|
| 401 | (format stream "~s ~s" (ccl:definition-type-name dt) (ccl:name-of full-name))))
|
|---|
| 402 | (defn-action (defn &optional msg)
|
|---|
| 403 | (destructuring-bind ((def-type . full-name) . source) defn
|
|---|
| 404 | (hemlock-ext:execute-in-file-view
|
|---|
| 405 | (ccl:source-note-filename source)
|
|---|
| 406 | (lambda ()
|
|---|
| 407 | (when msg (loud-message msg))
|
|---|
| 408 | (find-definition-in-buffer def-type full-name source))))))
|
|---|
| 409 | (let* ((info (get-source-alist name))
|
|---|
| 410 | (msg nil))
|
|---|
| [13186] | 411 | (when (and (null info) (symbolp name))
|
|---|
| [12635] | 412 | (let* ((seen (list name))
|
|---|
| 413 | (found ())
|
|---|
| 414 | (pname (symbol-name name)))
|
|---|
| 415 | (dolist (pkg (list-all-packages))
|
|---|
| 416 | (let ((sym (find-symbol pname pkg)))
|
|---|
| 417 | (when (and sym (not (member sym seen :test 'eq)))
|
|---|
| 418 | (let ((new (get-source-alist sym)))
|
|---|
| 419 | (when new
|
|---|
| 420 | (setq info (nconc new info))
|
|---|
| 421 | (push sym found)))
|
|---|
| 422 | (push sym seen))))
|
|---|
| 423 | (when found
|
|---|
| 424 | (setq msg (format nil "No definitions for ~s, found ~s instead"
|
|---|
| 425 | name (if (cdr found) found (car found)))))))
|
|---|
| 426 | (if info
|
|---|
| 427 | (if (cdr info)
|
|---|
| 428 | (progn
|
|---|
| 429 | (when msg (loud-message msg))
|
|---|
| 430 | (hemlock-ext:open-sequence-dialog
|
|---|
| 431 | :title (format nil "Definitions of ~s" name)
|
|---|
| 432 | :sequence info
|
|---|
| 433 | :action #'defn-action
|
|---|
| 434 | :printer #'defn-name))
|
|---|
| 435 | (defn-action (car info) msg))
|
|---|
| 436 | (editor-error "No known definitions for ~s" name)))))
|
|---|
| 437 |
|
|---|
