source: trunk/source/cocoa-ide/hemlock/src/edit-defs.lisp @ 15315

Last change on this file since 15315 was 15315, checked in by gz, 7 years ago

Fix compiler warning

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