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

Last change on this file since 12235 was 12235, checked in by gb, 11 years ago

Meta-.: handle errors, report via EDITOR-ERROR. Screw: still need
to handle errors when invoked via dialogs,etc.
MATCH-DEFINITION-CONTEXT-FOR-METHOD: if specializer is T, match
a symbol or (symbol T).

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 14.3 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            (when (valid-spot point t)
56              (move-mark mark1 point)
57              (form-offset mark1 -1)
58              (move-mark mark2 mark1)
59              (form-offset mark2 1)))))
60    (unless (mark= mark1 mark2)
61      (region-to-string (region mark1 mark2)))))
62
63(defcommand "Goto Definition" (p)
64  "Go to the current function/macro's definition.  With a numarg, prompts for name to go to."
65  "Go to the current function/macro's definition."
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 (format nil "~a" c)))))))
95     
96
97#|
98;;; "Edit Command Definition" is a hack due to creeping evolution in
99;;; GO-TO-DEFINITION.  We specify :function type and a name with "-COMMAND"
100;;; instead of :command type and the real command name because this causes
101;;; the right pattern to be created for searching.  We could either specify
102;;; that you always edit command definitions with this command (breaking
103;;; "Go to Definition" for commands called as functions), fixing the code,
104;;; or we can hack this command so everything works.
105;;;
106(defcommand "Edit Command Definition" (p)
107  "Prompts for command definition name and goes to it for editing."
108  "Prompts for command definition name and goes to it for editing."
109  (multiple-value-bind
110      (name command)
111      (if p
112        (multiple-value-bind (key cmd)
113                             (prompt-for-key :prompt "Edit command bound to: "
114                                             :must-exist t)
115          (declare (ignore key))
116          (values (command-name cmd) cmd))
117        (prompt-for-keyword :tables (list *command-names*)
118                            :prompt "Command to edit: "))
119    (go-to-definition (fun-defined-from-pathname (command-function command))
120                      :function
121                      (concatenate 'simple-string name "-COMMAND"))))
122
123;;; FUN-DEFINED-FROM-PATHNAME takes a symbol or function object.  It
124;;; returns a pathname for the file the function was defined in.  If it was
125;;; not defined in some file, then nil is returned.
126;;;
127(defun fun-defined-from-pathname (function)
128  "Takes a symbol or function and returns the pathname for the file the
129   function was defined in.  If it was not defined in some file, nil is
130   returned."
131  (flet ((true-namestring (path) (namestring (truename path))))
132    (typecase function
133      (function (fun-defined-from-pathname (ccl:function-name function)))
134      (symbol (let* ((info (ccl::%source-files function)))
135                (if (atom info)
136                  (true-namestring info)
137                  (let* ((finfo (assq 'function info)))
138                    (when finfo
139                      (true-namestring
140                       (if (atom finfo)
141                         finfo
142                         (car finfo)))))))))))
143
144;;; GO-TO-DEFINITION tries to find name in file with a search pattern based
145;;; on type (defun or defmacro).  File may be translated to another source
146;;; file, and if type is a function that cannot be found, we try to find a
147;;; command by an appropriate name.
148;;;
149(defun go-to-definition (file type name)
150  (let ((pattern (get-definition-pattern type name)))
151    (cond
152     (file
153      (setf file (go-to-definition-file file))
154      (let* ((buffer (old-find-file-command nil file))
155             (point (buffer-point buffer))
156             (name-len (length name)))
157        (declare (fixnum name-len))
158        (with-mark ((def-mark point))
159          (buffer-start def-mark)
160          (unless (find-pattern def-mark pattern)
161            (if (and (or (eq type :function) (eq type :unknown-function))
162                     (> name-len 7)
163                     (string= name "COMMAND" :start1 (- name-len 7)))
164                (let ((prev-search-str *last-go-to-def-string*))
165                  (unless (find-pattern def-mark
166                                        (get-definition-pattern :command name))
167                    (editor-error "~A is not defined with ~S or ~S, ~
168                                   but this is the defined-in file."
169                                  (string-upcase name) prev-search-str
170                                  *last-go-to-def-string*)))
171                (editor-error "~A is not defined with ~S, ~
172                               but this is the defined-in file."
173                              (string-upcase name) *last-go-to-def-string*)))
174          (if (eq buffer (current-buffer))
175              (push-new-buffer-mark point))
176          (move-mark point def-mark))))
177     (t
178      (when (or (eq type :unknown-function) (eq type :unknown-macro))
179        (with-mark ((m (buffer-start-mark (current-buffer))))
180          (unless (find-pattern m pattern)
181            (editor-error
182             "~A is not compiled and not defined in current buffer with ~S"
183             (string-upcase name) *last-go-to-def-string*))
184          (let ((point (current-point)))
185            (push-new-buffer-mark point)
186            (move-mark point m))))))))
187|#
188
189(defparameter *source-file-indicator-defining-operators* ())
190
191(defun define-source-file-indicator-defining-operators (name &rest operators)
192  (setf (getf *source-file-indicator-defining-operators* name) operators))
193
194(defun get-source-file-indicator-defining-operators (thing)
195  (if (typep thing 'method)
196    '(defmethod)
197    (getf *source-file-indicator-defining-operators* thing)))
198
199(define-source-file-indicator-defining-operators 'class 'defclass)
200(define-source-file-indicator-defining-operators 'type 'deftype)
201(define-source-file-indicator-defining-operators 'function 'defun 'defmacro 'defgeneric #+x8664-target 'ccl::defx86lapfunction #+ppc-target 'ccl::defppclapfunction)
202(define-source-file-indicator-defining-operators 'ccl::constant 'defconstant)
203(define-source-file-indicator-defining-operators 'variable 'defvar 'defparameter 'ccl::defstatic 'ccl::defglobal)
204(define-source-file-indicator-defining-operators 'method-combination 'define-method-combination)
205(define-source-file-indicator-defining-operators 'ccl::method-combination-evaluator 'ccl::define-method-combination-evaluator)
206(define-source-file-indicator-defining-operators 'compiler-macro 'define-compiler-macro)
207#+ppc32-target
208(define-source-file-indicator-defining-operators 'ccl::ppc32-vinsn 'ccl::define-ppc32-vinsn)
209#+ppc64-target
210(define-source-file-indicator-defining-operators 'ccl::ppc64-vinsn 'ccl::define-ppc64-vinsn)
211#+x8664-target
212(define-source-file-indicator-defining-operators 'ccl::x8664-vinsn 'ccl::define-x8664-vinsn)
213
214
215(defun match-definition-context-for-method (end-mark package indicator)
216  (let* ((specializers (openmcl-mop:method-specializers indicator))
217         (qualifiers (openmcl-mop:method-qualifiers indicator)))
218    (block win
219      (with-mark ((work end-mark))
220        (when qualifiers
221          (dotimes (i (length qualifiers))
222            (unless (and (form-offset end-mark 1)
223                         (progn
224                           (move-mark work end-mark)
225                           (form-offset work -1)))
226              (return-from win nil))
227            (let* ((qualifier (ignore-errors
228                                (let* ((*package* package))
229                                  (values
230                                   (read-from-string (region-to-string
231                                                      (region
232                                                       work
233                                                       end-mark))))))))
234              (unless (member qualifier qualifiers)
235                (return-from win nil)))))
236        ;; end-mark is now either at end of last qualifier or
237        ;; after method name.  Try to read the lambda list and
238        ;; match specializers.
239        (unless (and (form-offset end-mark 1)
240                     (progn
241                       (move-mark work end-mark)
242                       (form-offset work -1)))
243          (return-from win nil))
244        (multiple-value-bind (lambda-list error)
245            (ignore-errors
246              (let* ((*package* package))
247                (values
248                 (read-from-string (region-to-string
249                                    (region
250                                     work
251                                     end-mark))))))
252          (unless (and (null error)
253                       (consp lambda-list)
254                       (ccl::proper-list-p lambda-list))
255            (return-from win nil))
256          (flet ((match-specializer (spec)
257                   (when lambda-list
258                     (let* ((arg (pop lambda-list)))
259                       (typecase spec
260                         (ccl::eql-specializer
261                          (let* ((obj (openmcl-mop:eql-specializer-object spec)))
262                            (and (ccl::proper-list-p arg)
263                                 (= 2 (length arg))
264                                 (symbolp (pop arg))
265                                 (ccl::proper-list-p (setq arg (car arg)))
266                                 (= (length arg) 2)
267                                 (eq (car arg) 'eql)
268                                 (eql (cadr arg) obj))))
269                         (class
270                          (let* ((name (class-name spec)))
271                            (or (and (eq name t) (symbolp arg))
272                                (and (consp arg)
273                                     (symbolp (car arg))
274                                     (consp (cdr arg))
275                                     (null (cddr arg))
276                                     (eq name (cadr arg)))))))))))
277            (dolist (spec specializers t)
278              (unless (match-specializer spec)
279                (return nil)))))))))
280                                 
281                       
282       
283;;; START and END delimit a function name that matches what we're looking
284;;; for, PACKAGE is the buffer's package (or *PACKAGE*), and INDICATOR
285;;; is either a symbol (FUNCTION, MACRO, etc) or a METHOD object.
286(defun match-context-for-indicator (start end package indicator)
287  (declare (ignorable end))
288  (with-mark ((op-start start)
289              (op-end start))
290    (and (form-offset op-start -1)
291         (progn
292           (move-mark op-end op-start)
293           (form-offset op-end 1))
294         (let* ((defining-operator
295                    (ignore-errors
296                      (let* ((*package* package))
297                        (values (read-from-string (region-to-string (region op-start op-end))))))))
298           (memq
299            defining-operator
300            (get-source-file-indicator-defining-operators indicator)))
301         (or (not (typep indicator 'method))
302             (match-definition-context-for-method end package indicator)))))
303
304
305(defun match-definition-context (mark name indicator package)
306  (pre-command-parse-check mark)
307  (when (valid-spot mark t)
308    (with-mark ((start mark)
309                (end mark))
310      (and (form-offset end 1)
311           (progn
312             (move-mark start end)
313             (form-offset start -1))
314           (eq name (ignore-errors
315                      (let* ((*package* package))
316                        (values (read-from-string (region-to-string (region start end)))))))
317           (match-context-for-indicator start end package indicator)))))
318
319(defun find-definition-in-buffer (name indicator)
320  (let ((buffer (current-buffer)))
321    (setf (hi::buffer-region-active buffer) nil)
322    (when (symbolp name)
323      (let* ((string (string name))
324             (len (length string))
325             (pattern (get-search-pattern string :forward))
326             (mark (copy-mark (buffer-start-mark buffer)))
327             (package (or
328                       (find-package
329                        (variable-value 'current-package :buffer buffer))
330                       *package*)))
331        (or
332         (loop
333           (let* ((won (find-pattern mark pattern)))
334             (unless won
335               (return))
336             (when (match-definition-context mark name indicator package)
337               (backward-up-list mark)
338               (move-mark (buffer-point buffer) mark)
339               (return t))
340             (unless (character-offset mark len)
341               (return))))
342         (editor-error "Couldn't find definition for ~s" name))))))
Note: See TracBrowser for help on using the repository browser.