source: tags/pre_1_0_pre_hash_modifications/ccl/hemlock/src/edit-defs.lisp @ 2475

Last change on this file since 2475 was 2475, checked in by anonymous, 14 years ago

This commit was manufactured by cvs2svn to create tag
'pre_1_0_pre_hash_modifications'.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 9.8 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;;; GET-DEFINITION-PATTERN takes a type and a name.  It returns a search
34;;; pattern for finding the defining form for name using
35;;; *go-to-def-pattern* and *last-go-to-def-string* destructively.  The
36;;; pattern contains a trailing space to avoid finding functions earlier
37;;; in the file with the function's name as a prefix.  This is not necessary
38;;; with type :command since the name is terminated with a ".
39;;;
40(defun get-definition-pattern (type name)
41  (declare (simple-string name))
42  (let ((string (ecase type
43                  ((:function :unknown-function)
44                   (concatenate 'simple-string "(defun " name " "))
45                  ((:macro :unknown-macro)
46                   (concatenate 'simple-string "(defmacro " name " "))
47                  (:command
48                   (concatenate 'simple-string
49                                "(defcommand \""
50                                (nsubstitute #\space #\-
51                                             (subseq name 0 (- (length name) 8))
52                                             :test #'char=)
53                                "\"")))))
54    (declare (simple-string string))
55    (cond ((string= string *last-go-to-def-string*)
56           *go-to-def-pattern*)
57          (t (setf *last-go-to-def-string* string)
58             (new-search-pattern :string-insensitive :forward
59                                 string *go-to-def-pattern*)))))
60
61(defhvar "Editor Definition Info"
62  "When this is non-nil, the editor Lisp is used to determine definition
63   editing information; otherwise, the slave Lisp is used."
64  :value nil)
65
66;;; JDz: Brought here from eval-server.lisp, because this is used in
67;;; GET-DEF-INFO-AND-GO-TO-IT.  Should bring it back onec the file is
68;;; included in build.
69(defhvar "Current Eval Server"
70  "The Server-Info object for the server currently used for evaluation and
71   compilation."
72  :value nil)
73
74(defcommand "Goto Definition" (p)
75  "Go to the current function/macro's definition.  If it isn't defined by a
76   DEFUN or DEFMACRO form, then the defining file is simply found.  If the
77   function is not compiled, then it is looked for in the current buffer."
78  "Go to the current function/macro's definition."
79  (declare (ignore p))
80  (let ((point (current-point)))
81    (pre-command-parse-check point)
82    (with-mark ((mark1 point)
83                (mark2 point))
84      (unless (backward-up-list mark1) (editor-error))
85      (form-offset (move-mark mark2 (mark-after mark1)) 1)
86      (let ((fun-name (region-to-string (region mark1 mark2))))
87        (get-def-info-and-go-to-it fun-name)))))
88
89(defcommand "Edit Definition" (p)
90  "Prompts for function/macro's definition name and goes to it for editing."
91  "Prompts for function/macro's definition name and goes to it for editing."
92  (declare (ignore p))
93  (let ((fun-name (prompt-for-string
94                   :prompt "Name: "
95                   :help "Symbol name of function.")))
96    (get-def-info-and-go-to-it fun-name)))
97
98(defun get-def-info-and-go-to-it (fun-name)
99  (format t "~& fun-name = ~s" fun-name)
100  #+no
101  (let ((in-editor-p (value editor-definition-info))
102        (info (value current-eval-server)))
103    (if (or in-editor-p
104            (not info))
105        (multiple-value-bind (pathname type name)
106                             (in-lisp
107                              (definition-editing-info fun-name))
108          (unless in-editor-p
109            (message "Editing definition from editor Lisp ..."))
110          (go-to-definition pathname type name))
111        (let ((results (eval-form-in-server
112                        info
113                        (format nil "(hemlock::definition-editing-info ~S)"
114                                fun-name))))
115          (go-to-definition (read-from-string (first results)) ;file
116                            (read-from-string (second results)) ;type
117                            (read-from-string (third results))))))) ;name
118
119;;; "Edit Command Definition" is a hack due to creeping evolution in
120;;; GO-TO-DEFINITION.  We specify :function type and a name with "-COMMAND"
121;;; instead of :command type and the real command name because this causes
122;;; the right pattern to be created for searching.  We could either specify
123;;; that you always edit command definitions with this command (breaking
124;;; "Go to Definition" for commands called as functions), fixing the code,
125;;; or we can hack this command so everything works.
126;;;
127(defcommand "Edit Command Definition" (p)
128  "Prompts for command definition name and goes to it for editing."
129  "Prompts for command definition name and goes to it for editing."
130  (multiple-value-bind
131      (name command)
132      (if p
133          (multiple-value-bind (key cmd)
134                               (prompt-for-key :prompt "Edit command bound to: ")
135            (declare (ignore key))
136            (values (command-name cmd) cmd))
137          (prompt-for-keyword (list *command-names*)
138                              :prompt "Command to edit: "))
139    (go-to-definition (fun-defined-from-pathname (command-function command))
140                      :function
141                      (concatenate 'simple-string name "-COMMAND"))))
142
143;;; GO-TO-DEFINITION tries to find name in file with a search pattern based
144;;; on type (defun or defmacro).  File may be translated to another source
145;;; file, and if type is a function that cannot be found, we try to find a
146;;; command by an appropriate name.
147;;;
148(defun go-to-definition (file type name)
149  (let ((pattern (get-definition-pattern type name)))
150    (cond
151     (file
152      (setf file (go-to-definition-file file))
153      (let* ((buffer (find-file-command nil file))
154             (point (buffer-point buffer))
155             (name-len (length name)))
156        (declare (fixnum name-len))
157        (with-mark ((def-mark point))
158          (buffer-start def-mark)
159          (unless (find-pattern def-mark pattern)
160            (if (and (or (eq type :function) (eq type :unknown-function))
161                     (> name-len 7)
162                     (string= name "COMMAND" :start1 (- name-len 7)))
163                (let ((prev-search-str *last-go-to-def-string*))
164                  (unless (find-pattern def-mark
165                                        (get-definition-pattern :command name))
166                    (editor-error "~A is not defined with ~S or ~S, ~
167                                   but this is the defined-in file."
168                                  (string-upcase name) prev-search-str
169                                  *last-go-to-def-string*)))
170                (editor-error "~A is not defined with ~S, ~
171                               but this is the defined-in file."
172                              (string-upcase name) *last-go-to-def-string*)))
173          (if (eq buffer (current-buffer))
174              (push-buffer-mark (copy-mark point)))
175          (move-mark point def-mark))))
176     (t
177      (when (or (eq type :unknown-function) (eq type :unknown-macro))
178        (with-mark ((m (buffer-start-mark (current-buffer))))
179          (unless (find-pattern m pattern)
180            (editor-error
181             "~A is not compiled and not defined in current buffer with ~S"
182             (string-upcase name) *last-go-to-def-string*))
183          (let ((point (current-point)))
184            (push-buffer-mark (copy-mark point))
185            (move-mark point m))))))))
186
187;;; GO-TO-DEFINITION-FILE takes a pathname and translates it to another
188;;; according to "Add Definition Directory Translation".  Take the first
189;;; probe-able translation, or probe file if no translations are found.
190;;; If no existing file is found, an editor error is signaled.
191;;;
192(defun go-to-definition-file (file)
193  (multiple-value-bind (unmatched-dir new-dirs file-name)
194                       (maybe-translate-definition-file file)
195    (loop
196      (when (null new-dirs)
197        (unless (probe-file file)
198          (if unmatched-dir
199              (editor-error "Cannot find file ~S or any of its translations."
200                            file)
201              (editor-error "Cannot find file ~S." file)))
202        (return file))
203      (let ((f (translate-definition-file unmatched-dir (pop new-dirs)
204                                          file-name)))
205        (when (probe-file f)
206          (setf file f)
207          (return f))))))
208
209;;; MAYBE-TRANSLATE-DEFINITION-FILE tries each directory subsequence from
210;;; the most specific to the least looking a user defined translation.
211;;; This returns the portion of the input directory sequence that was not
212;;; matched (to be merged with the mapping of the matched portion), the
213;;; list of post image directories, and the file name.
214;;;
215(defun maybe-translate-definition-file (file)
216  (let* ((pathname (pathname file))
217         (maybe-truename (or (probe-file pathname) pathname))
218         (dirs (pathname-directory maybe-truename))
219         (len (length dirs))
220         (i len))
221    (declare (fixnum len i))
222    (loop
223      (when (<= i 1) (return nil))
224      (let ((new-dirs (getstring (directory-namestring
225                                 (make-pathname :defaults "/"
226                                                :directory (subseq dirs 0 i)))
227                                *definition-directory-translation-table*)))
228        (when new-dirs
229          (return (values (subseq dirs i len) new-dirs
230                          (file-namestring maybe-truename)))))
231      (decf i))))
232
233;;; TRANSLATE-DEFINITION-FILE creates a directory sequence from unmatched-dir
234;;; and new-dir, creating a translated pathname for GO-TO-DEFINITION.
235;;;
236(defun translate-definition-file (unmatched-dir new-dir file-name)
237  (make-pathname :defaults "/"
238                 :directory (append (pathname-directory new-dir)
239                                    unmatched-dir)
240                 :name file-name))
241
242
243;;; DEFINITION-EDITING-INFO runs in a slave Lisp and returns the pathname
244;;; that the global definition of the symbol whose name is string is defined
245;;; in.
246;;;
247(defun definition-editing-info (string)
248  (let ((symbol (read-from-string string)))
249    (check-type symbol symbol)
250    (let ((macro (macro-function symbol))
251          (name (symbol-name symbol)))
252      (if macro
253          (let ((file (fun-defined-from-pathname macro)))
254            (if file
255                (values file :macro name)
256                (values nil :unknown-macro name)))
257          (if (fboundp symbol)
258              (let ((file (fun-defined-from-pathname symbol)))
259                (if file
260                    (values file :function name)
261                    (values nil :unknown-function name)))
262              (error "~S is not a function." symbol))))))
Note: See TracBrowser for help on using the repository browser.