[Openmcl-cvs-notifications] r12635 - in /trunk/source/cocoa-ide: cocoa-editor.lisp hemlock/src/edit-defs.lisp hemlock/src/lispmode.lisp hemlock/src/package.lisp hemlock/src/search1.lisp
gz at clozure.com
gz at clozure.com
Wed Aug 19 22:59:37 EDT 2009
Author: gz
Date: Wed Aug 19 22:59:37 2009
New Revision: 12635
Log:
move edit-definition from lispmode.lisp to edit-defs.lisp. Change it to us=
e source locations when available: if there is no source text info, just go=
to the saved source position. If text is available, use it to attempt to =
find the definition even if something else in the file has changed. If can'=
t find the definition using source location info, punt to the old code.
Make meta-. set mark before moving point to the definition, so can get back.
Make the warning message about using a different package show in the target=
buffer echo area, not the one left behind.
Replace hemlock-ext:edit-single-definition with a more general hemlock-ext:=
execute-in-file-view.
Modified:
trunk/source/cocoa-ide/cocoa-editor.lisp
trunk/source/cocoa-ide/hemlock/src/edit-defs.lisp
trunk/source/cocoa-ide/hemlock/src/lispmode.lisp
trunk/source/cocoa-ide/hemlock/src/package.lisp
trunk/source/cocoa-ide/hemlock/src/search1.lisp
Modified: trunk/source/cocoa-ide/cocoa-editor.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/cocoa-editor.lisp (original)
+++ trunk/source/cocoa-ide/cocoa-editor.lisp Wed Aug 19 22:59:37 2009
@@ -3223,16 +3223,12 @@
(lisp-string-from-nsstring (#/localizedDescription erro=
r))))))
(front-view-for-buffer (hemlock-buffer doc)))))
=
-(defun cocoa-edit-single-definition (name info)
- (assume-cocoa-thread)
- (destructuring-bind (indicator . pathname) info
- (let ((view (find-or-make-hemlock-view pathname)))
- (hi::handle-hemlock-event view
- #'(lambda ()
- (hemlock::find-definition-in-buffer na=
me indicator))))))
-
-(defun hemlock-ext:edit-single-definition (name info)
- (execute-in-gui #'(lambda () (cocoa-edit-single-definition name info))))
+(defun hemlock-ext:execute-in-file-view (pathname thunk)
+ (execute-in-gui #'(lambda ()
+ (assume-cocoa-thread)
+ (let ((view (find-or-make-hemlock-view pathname)))
+ (hi::handle-hemlock-event view thunk)))))
+
=
(defun hemlock-ext:open-sequence-dialog (&key title sequence action (print=
er #'prin1))
(make-instance 'sequence-window-controller
Modified: trunk/source/cocoa-ide/hemlock/src/edit-defs.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/hemlock/src/edit-defs.lisp (original)
+++ trunk/source/cocoa-ide/hemlock/src/edit-defs.lisp Wed Aug 19 22:59:37 2=
009
@@ -62,7 +62,6 @@
=
(defcommand "Goto Definition" (p)
"Go to the current function/macro's definition. With a numarg, prompts =
for name to go to."
- "Go to the current function/macro's definition."
(if p
(edit-definition-command nil)
(let* ((point (current-point))
@@ -186,30 +185,27 @@
(move-mark point m))))))))
|#
=
-(defparameter *source-file-indicator-defining-operators* ())
-
-(defun define-source-file-indicator-defining-operators (name &rest operato=
rs)
- (setf (getf *source-file-indicator-defining-operators* name) operators))
-
-(defun get-source-file-indicator-defining-operators (thing)
- (if (typep thing 'method)
- '(defmethod)
- (getf *source-file-indicator-defining-operators* thing)))
-
-(define-source-file-indicator-defining-operators 'class 'defclass)
-(define-source-file-indicator-defining-operators 'type 'deftype)
-(define-source-file-indicator-defining-operators 'function 'defun 'defmacr=
o 'defgeneric #+x8664-target 'ccl::defx86lapfunction #+ppc-target 'ccl::def=
ppclapfunction)
-(define-source-file-indicator-defining-operators 'ccl::constant 'defconsta=
nt)
-(define-source-file-indicator-defining-operators 'variable 'defvar 'defpar=
ameter 'ccl::defstatic 'ccl::defglobal)
-(define-source-file-indicator-defining-operators 'method-combination 'defi=
ne-method-combination)
-(define-source-file-indicator-defining-operators 'ccl::method-combination-=
evaluator 'ccl::define-method-combination-evaluator)
-(define-source-file-indicator-defining-operators 'compiler-macro 'define-c=
ompiler-macro)
-#+ppc32-target
-(define-source-file-indicator-defining-operators 'ccl::ppc32-vinsn 'ccl::d=
efine-ppc32-vinsn)
-#+ppc64-target
-(define-source-file-indicator-defining-operators 'ccl::ppc64-vinsn 'ccl::d=
efine-ppc64-vinsn)
-#+x8664-target
-(define-source-file-indicator-defining-operators 'ccl::x8664-vinsn 'ccl::d=
efine-x8664-vinsn)
+(defparameter *type-defining-operators* ())
+
+(defun define-type-defining-operators (name &rest operators)
+ (assert (subtypep name 'ccl::definition-type))
+ (let ((a (assoc name *type-defining-operators*)))
+ (when (null a)
+ (push (setq a (cons name nil)) *type-defining-operators*))
+ (loop for op in operators do (pushnew op (cdr a)))
+ name))
+
+(defun type-defining-operator-p (def-type operator)
+ (loop for (type . ops) in *type-defining-operators*
+ thereis (and (typep def-type type) (memq operator ops))))
+
+(define-type-defining-operators 'ccl::class-definition-type 'defclass)
+(define-type-defining-operators 'ccl::type-definition-type 'deftype)
+(define-type-defining-operators 'ccl::function-definition-type 'defun 'def=
macro 'defgeneric #+x8664-target 'ccl::defx86lapfunction #+ppc-target 'ccl:=
:defppclapfunction)
+(define-type-defining-operators 'ccl::constant-definition-type 'defconstan=
t)
+(define-type-defining-operators 'ccl::variable-definition-type 'defvar 'de=
fparameter 'ccl::defstatic 'ccl::defglobal)
+(define-type-defining-operators 'ccl::method-combination-definition-type '=
define-method-combination)
+(define-type-defining-operators 'ccl::compiler-macro-definition-type 'defi=
ne-compiler-macro)
=
=
(defun match-definition-context-for-method (end-mark package indicator)
@@ -278,31 +274,25 @@
(unless (match-specializer spec)
(return nil)))))))))
=
- =
- =
-;;; START and END delimit a function name that matches what we're looking
-;;; for, PACKAGE is the buffer's package (or *PACKAGE*), and INDICATOR
-;;; is either a symbol (FUNCTION, MACRO, etc) or a METHOD object.
-(defun match-context-for-indicator (start end package indicator)
- (declare (ignorable end))
+;;; START and END delimit a function name that matches what we're looking =
for
+(defun match-context-for-indicator (start end def-type full-name)
(with-mark ((op-start start)
(op-end start))
(and (form-offset op-start -1)
(progn
(move-mark op-end op-start)
(form-offset op-end 1))
- (let* ((defining-operator
+ (let* ((package (or (find-package (variable-value 'current-packag=
e :buffer (current-buffer)))
+ *package*))
+ (defining-operator
(ignore-errors
(let* ((*package* package))
(values (read-from-string (region-to-string (regio=
n op-start op-end))))))))
- (memq
- defining-operator
- (get-source-file-indicator-defining-operators indicator)))
- (or (not (typep indicator 'method))
- (match-definition-context-for-method end package indicator)))=
))
-
-
-(defun match-definition-context (mark name indicator package)
+ (and (type-defining-operator-p def-type defining-operator)
+ (or (not (typep full-name 'method))
+ (match-definition-context-for-method end package full-=
name)))))))
+
+(defun match-definition-context (mark def-type full-name)
(pre-command-parse-check mark)
(when (valid-spot mark t)
(with-mark ((start mark)
@@ -311,32 +301,121 @@
(progn
(move-mark start end)
(form-offset start -1))
- (eq name (ignore-errors
- (let* ((*package* package))
- (values (read-from-string (region-to-string (regio=
n start end)))))))
- (match-context-for-indicator start end package indicator)))))
-
-(defun find-definition-in-buffer (name indicator)
- (let ((buffer (current-buffer)))
- (setf (hi::buffer-region-active buffer) nil)
- (when (symbolp name)
- (let* ((string (string name))
- (len (length string))
- (pattern (get-search-pattern string :forward))
- (mark (copy-mark (buffer-start-mark buffer)))
- (package (or
- (find-package
- (variable-value 'current-package :buffer buffer))
- *package*)))
- (or
- (loop
- (let* ((won (find-pattern mark pattern)))
- (unless won
- (return))
- (when (match-definition-context mark name indicator package)
- (backward-up-list mark)
- (move-mark (buffer-point buffer) mark)
- (return t))
- (unless (character-offset mark len)
- (return))))
- (editor-error "Couldn't find definition for ~s" name))))))
+ (let ((package (or (find-package (variable-value 'current-packa=
ge :buffer (current-buffer)))
+ *package*)))
+ (eq (ccl::definition-base-name def-type full-name)
+ (ignore-errors
+ (let* ((*package* package))
+ (values (read-from-string (region-to-string (region st=
art end))))))))
+ (match-context-for-indicator start end def-type full-name)))))
+
+(defun find-definition-by-context (def-type full-name)
+ (let* ((base-name (ccl::definition-base-name def-type full-name))
+ (string (string base-name))
+ (pattern (new-search-pattern :string-insensitive :forward string)=
))
+ (with-mark ((mark (current-point)))
+ (when (loop
+ while (find-pattern mark pattern)
+ thereis (and (match-definition-context mark def-type full-name)
+ (backward-up-list mark))
+ do (character-offset mark 1))
+ (move-point-leaving-mark mark)))))
+
+(defun move-point-leaving-mark (target)
+ (let ((point (current-point)))
+ (push-new-buffer-mark point)
+ (move-mark point target)
+ point))
+
+(defun move-to-source-note (source)
+ (let ((start-pos (ccl:source-note-start-pos source)))
+ (when start-pos
+ (let ((full-text (ccl:source-note-text source))
+ (pattern nil)
+ (offset 0))
+ (flet ((search (mark string direction)
+ (find-pattern mark
+ (setq pattern (new-search-pattern :string-i=
nsensitive
+ direction
+ string
+ pattern))=
)))
+ (declare (inline search))
+ (with-mark ((temp-mark (current-point)))
+ (unless (move-to-absolute-position temp-mark start-pos)
+ (buffer-end temp-mark))
+ (unless full-text
+ ;; Someday, might only store a snippet for toplevel, so inne=
r notes
+ ;; might not have text, but can still find them through the =
toplevel.
+ (let* ((toplevel (ccl::source-note-toplevel-note source))
+ (toplevel-start-pos (and (not (eq toplevel source))
+ (ccl:source-note-start-pos t=
oplevel))))
+ (when toplevel-start-pos
+ (setq offset (- start-pos toplevel-start-pos))
+ (setq start-pos toplevel-start-pos)
+ (setq full-text (ccl:source-note-text toplevel)))))
+ (when (or (null full-text)
+ (or (search temp-mark full-text :forward)
+ (search temp-mark full-text :backward))
+ ;; Maybe body changed, try at least to match the sta=
rt of it
+ (let ((snippet (and (> (length full-text) 60) (subse=
q full-text 0 60))))
+ (and snippet
+ (or (search temp-mark snippet :forward)
+ (search temp-mark snippet :backward)))))
+ (let ((point (move-point-leaving-mark temp-mark)))
+ (or (character-offset point offset)
+ (buffer-end point))))))))))
+
+(defun find-definition-in-buffer (def-type full-name source)
+ (current-point-collapsing-selection)
+ (or (and (ccl:source-note-p source)
+ (move-to-source-note source))
+ (find-definition-by-context def-type full-name)
+ (editor-error "Couldn't find definition for ~s" full-name)))
+
+;; Note this isn't necessarily called from hemlock, e.g. it might be calle=
d by cl:ed,
+;; from any thread, or it might be called from a sequence dialog, etc.
+(defun edit-definition (name)
+ (flet ((get-source-alist (name)
+ (let ((list (ccl:find-definition-sources name t)))
+ ;; filter interactive-only defs
+ (loop for (id . sources) in list as source =3D (find-if-not #=
'null sources)
+ when source collect (cons id source))))
+ (defn-name (defn stream)
+ (destructuring-bind (dt . full-name) (car defn)
+ (format stream "~s ~s" (ccl:definition-type-name dt) (ccl:nam=
e-of full-name))))
+ (defn-action (defn &optional msg)
+ (destructuring-bind ((def-type . full-name) . source) defn
+ (hemlock-ext:execute-in-file-view
+ (ccl:source-note-filename source)
+ (lambda ()
+ (when msg (loud-message msg))
+ (find-definition-in-buffer def-type full-name source))))))
+ (let* ((info (get-source-alist name))
+ (msg nil))
+ (when (null info)
+ (let* ((seen (list name))
+ (found ())
+ (pname (symbol-name name)))
+ (dolist (pkg (list-all-packages))
+ (let ((sym (find-symbol pname pkg)))
+ (when (and sym (not (member sym seen :test 'eq)))
+ (let ((new (get-source-alist sym)))
+ (when new
+ (setq info (nconc new info))
+ (push sym found)))
+ (push sym seen))))
+ (when found
+ (setq msg (format nil "No definitions for ~s, found ~s instead"
+ name (if (cdr found) found (car found)))))))
+ (if info
+ (if (cdr info)
+ (progn
+ (when msg (loud-message msg))
+ (hemlock-ext:open-sequence-dialog
+ :title (format nil "Definitions of ~s" name)
+ :sequence info
+ :action #'defn-action
+ :printer #'defn-name))
+ (defn-action (car info) msg))
+ (editor-error "No known definitions for ~s" name)))))
+
Modified: trunk/source/cocoa-ide/hemlock/src/lispmode.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/hemlock/src/lispmode.lisp (original)
+++ trunk/source/cocoa-ide/hemlock/src/lispmode.lisp Wed Aug 19 22:59:37 20=
09
@@ -1966,39 +1966,6 @@
:sequence (ccl::callers symbol)
:action #'edit-definition)))))
=
-;; Note this isn't necessarily called from hemlock, e.g. it might be calle=
d by cl:ed,
-;; from any thread, or it might be called from a sequence dialog, etc.
-(defun edit-definition (name)
- (flet ((get-source-alist (name)
- (mapcar #'(lambda (item) (cons name item))
- (ccl::get-source-files-with-types&classes name))))
- (let* ((info (get-source-alist name)))
- (when (null info)
- (let* ((seen (list name))
- (found ())
- (pname (symbol-name name)))
- (dolist (pkg (list-all-packages))
- (let ((sym (find-symbol pname pkg)))
- (when (and sym (not (member sym seen)))
- (let ((new (get-source-alist sym)))
- (when new
- (setq info (nconc new info))
- (push sym found)))
- (push sym seen))))
- (when found
- ;; Unfortunately, this puts the message in the wrong buffer (w=
ould be better in the destination buffer).
- (loud-message "No definitions for ~s, using ~s instead"
- name (if (cdr found) found (car found))))))
- (if info
- (if (cdr info)
- (hemlock-ext:open-sequence-dialog
- :title (format nil "Definitions of ~s" name)
- :sequence info
- :action #'(lambda (item) (hemlock-ext:edit-single-definition (c=
ar item) (cdr item)))
- :printer #'(lambda (item stream) (prin1 (cadr item) stream)))
- (hemlock-ext:edit-single-definition (caar info) (cdar info)))
- (editor-error "No known definitions for ~s" name)))))
-
#||
(defcommand "Set Package Name" (p)
(variable-value 'current-package :buffer buffer)
Modified: trunk/source/cocoa-ide/hemlock/src/package.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/hemlock/src/package.lisp (original)
+++ trunk/source/cocoa-ide/hemlock/src/package.lisp Wed Aug 19 22:59:37 2009
@@ -373,7 +373,7 @@
#:read-only-listener-p
#:all-hemlock-views
#:open-sequence-dialog
- #:edit-single-definition
+ #:execute-in-file-view
#:change-active-pane
#:send-string-to-listener
#:buffer-process-description
Modified: trunk/source/cocoa-ide/hemlock/src/search1.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/cocoa-ide/hemlock/src/search1.lisp (original)
+++ trunk/source/cocoa-ide/hemlock/src/search1.lisp Wed Aug 19 22:59:37 2009
@@ -61,13 +61,10 @@
;;; keyword.
;;;
(defmacro define-search-kind (kind lambda-list documentation &body forms)
- (let ((dummy #-CLISP (gensym) #+CLISP (gentemp (format nil ".search-kind=
.~A" kind))))
- `(progn
- (push ,documentation *search-pattern-documentation*)
- (defun ,dummy ()
- (setf (gethash ,kind *search-pattern-experts*)
- #'(lambda ,lambda-list , at forms)))
- (,dummy))))
+ `(progn
+ (push ,documentation *search-pattern-documentation*)
+ (setf (gethash ,kind *search-pattern-experts*)
+ #'(lambda ,lambda-list , at forms))))
=0C
;;; new-search-pattern -- Public
;;;
@@ -630,7 +627,8 @@
If there is no match for the pattern then Mark is not modified and NIL
is returned.
If stop-mark is specified, NIL is returned and mark is not moved if
- the point before the match is after stop-mark"
+ the point before the match is after stop-mark for forward search or
+ before stop-mark for backward search"
(close-line)
(multiple-value-bind (line start matched)
(funcall (search-pattern-search-function search-pattern)
@@ -638,9 +636,13 @@
(mark-charpos mark))
(when (and matched
(or (null stop-mark)
- (< (line-number line) (line-number (mark-line stop-mark)))
- (and (=3D (line-number line) (line-number (mark-line stop-mark)))
- (<=3D start (mark-charpos stop-mark)))))
+ (if (eq (search-pattern-direction search-pattern) :forw=
ard)
+ (or (< (line-number line) (line-number (mark-line sto=
p-mark)))
+ (and (eq line (mark-line stop-mark))
+ (<=3D start (mark-charpos stop-mark))))
+ (or (< (line-number (mark-line stop-mark)) (line-numb=
er line))
+ (and (eq (mark-line stop-mark) line)
+ (<=3D (mark-charpos stop-mark) start))))))
(move-to-position mark start line)
matched)))
=
More information about the Openmcl-cvs-notifications
mailing list