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

Last change on this file since 8464 was 8464, checked in by gz, 12 years ago

Fix ticket #237: keep line's ignored-region within the line

Move double-%-in to cocoa-utils, use it in log-debug

user buffer-package fn in edit definition

Fix the last compiler warning...

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