Index: /branches/ide-1.0/ccl/hemlock/src/edit-defs.lisp =================================================================== --- /branches/ide-1.0/ccl/hemlock/src/edit-defs.lisp (revision 6699) +++ /branches/ide-1.0/ccl/hemlock/src/edit-defs.lisp (revision 6700) @@ -31,59 +31,34 @@ (declaim (simple-string *last-go-to-def-string*)) -;;; GET-DEFINITION-PATTERN takes a type and a name. It returns a search -;;; pattern for finding the defining form for name using -;;; *go-to-def-pattern* and *last-go-to-def-string* destructively. The -;;; pattern contains a trailing space to avoid finding functions earlier -;;; in the file with the function's name as a prefix. This is not necessary -;;; with type :command since the name is terminated with a ". -;;; -(defun get-definition-pattern (type name) - (declare (simple-string name)) - (let ((string (ecase type - ((:function :unknown-function) - (concatenate 'simple-string "(defun " name " ")) - ((:macro :unknown-macro) - (concatenate 'simple-string "(defmacro " name " ")) - (:command - (concatenate 'simple-string - "(defcommand \"" - (nsubstitute #\space #\- - (subseq name 0 (- (length name) 8)) - :test #'char=) - "\""))))) - (declare (simple-string string)) - (cond ((string= string *last-go-to-def-string*) - *go-to-def-pattern*) - (t (setf *last-go-to-def-string* string) - (new-search-pattern :string-insensitive :forward - string *go-to-def-pattern*))))) - -(defhvar "Editor Definition Info" - "When this is non-nil, the editor Lisp is used to determine definition - editing information; otherwise, the slave Lisp is used." - :value nil) - -;;; JDz: Brought here from eval-server.lisp, because this is used in -;;; GET-DEF-INFO-AND-GO-TO-IT. Should bring it back onec the file is -;;; included in build. -(defhvar "Current Eval Server" - "The Server-Info object for the server currently used for evaluation and - compilation." - :value nil) + + + + + (defcommand "Goto Definition" (p) - "Go to the current function/macro's definition. If it isn't defined by a - DEFUN or DEFMACRO form, then the defining file is simply found. If the - function is not compiled, then it is looked for in the current buffer." + "Go to the current function/macro's definition." "Go to the current function/macro's definition." (declare (ignore p)) - (let ((point (current-point))) + (let* ((point (current-point)) + (buffer (current-buffer))) (pre-command-parse-check point) - (with-mark ((mark1 point) - (mark2 point)) - (unless (backward-up-list mark1) (editor-error)) - (form-offset (move-mark mark2 (mark-after mark1)) 1) - (let ((fun-name (region-to-string (region mark1 mark2)))) - (get-def-info-and-go-to-it fun-name))))) + (when (valid-spot point t) + (with-mark ((mark1 point) + (mark2 point)) + (if (hi::%buffer-current-region-p buffer) + (let* ((mark (hi::buffer-%mark buffer))) + (if (mark< mark point) + (move-mark mark1 mark) + (move-mark mark2 mark))) + (progn + (form-offset mark1 -1) + (form-offset (move-mark mark2 mark1) 1))) + (unless (mark= mark1 mark2) + (let ((fun-name (region-to-string (region mark1 mark2)))) + (get-def-info-and-go-to-it fun-name (or + (find-package + (variable-value 'current-package :buffer (current-buffer))) + *package*)))))))) (defcommand "Edit Definition" (p) @@ -94,26 +69,9 @@ :prompt "Name: " :help "Symbol name of function."))) - (get-def-info-and-go-to-it fun-name))) - -(defun get-def-info-and-go-to-it (fun-name) - (format t "~& fun-name = ~s" fun-name) - #+no - (let ((in-editor-p (value editor-definition-info)) - (info (value current-eval-server))) - (if (or in-editor-p - (not info)) - (multiple-value-bind (pathname type name) - (in-lisp - (definition-editing-info fun-name)) - (unless in-editor-p - (message "Editing definition from editor Lisp ...")) - (go-to-definition pathname type name)) - (let ((results (eval-form-in-server - info - (format nil "(hemlock::definition-editing-info ~S)" - fun-name)))) - (go-to-definition (read-from-string (first results)) ;file - (read-from-string (second results)) ;type - (read-from-string (third results))))))) ;name + (get-def-info-and-go-to-it fun-name (or + (find-package + (variable-value 'current-package :buffer (current-buffer))) + *package*)))) + ;;; "Edit Command Definition" is a hack due to creeping evolution in @@ -185,78 +143,156 @@ (move-mark point m)))))))) -;;; GO-TO-DEFINITION-FILE takes a pathname and translates it to another -;;; according to "Add Definition Directory Translation". Take the first -;;; probe-able translation, or probe file if no translations are found. -;;; If no existing file is found, an editor error is signaled. -;;; -(defun go-to-definition-file (file) - (multiple-value-bind (unmatched-dir new-dirs file-name) - (maybe-translate-definition-file file) - (loop - (when (null new-dirs) - (unless (probe-file file) - (if unmatched-dir - (editor-error "Cannot find file ~S or any of its translations." - file) - (editor-error "Cannot find file ~S." file))) - (return file)) - (let ((f (translate-definition-file unmatched-dir (pop new-dirs) - file-name))) - (when (probe-file f) - (setf file f) - (return f)))))) - -;;; MAYBE-TRANSLATE-DEFINITION-FILE tries each directory subsequence from -;;; the most specific to the least looking a user defined translation. -;;; This returns the portion of the input directory sequence that was not -;;; matched (to be merged with the mapping of the matched portion), the -;;; list of post image directories, and the file name. -;;; -(defun maybe-translate-definition-file (file) - (let* ((pathname (pathname file)) - (maybe-truename (or (probe-file pathname) pathname)) - (dirs (pathname-directory maybe-truename)) - (len (length dirs)) - (i len)) - (declare (fixnum len i)) - (loop - (when (<= i 1) (return nil)) - (let ((new-dirs (getstring (directory-namestring - (make-pathname :defaults "/" - :directory (subseq dirs 0 i))) - *definition-directory-translation-table*))) - (when new-dirs - (return (values (subseq dirs i len) new-dirs - (file-namestring maybe-truename))))) - (decf i)))) - -;;; TRANSLATE-DEFINITION-FILE creates a directory sequence from unmatched-dir -;;; and new-dir, creating a translated pathname for GO-TO-DEFINITION. -;;; -(defun translate-definition-file (unmatched-dir new-dir file-name) - (make-pathname :defaults "/" - :directory (append (pathname-directory new-dir) - unmatched-dir) - :name file-name)) - - -;;; DEFINITION-EDITING-INFO runs in a slave Lisp and returns the pathname -;;; that the global definition of the symbol whose name is string is defined -;;; in. -;;; -(defun definition-editing-info (string) - (let ((symbol (read-from-string string))) - (check-type symbol symbol) - (let ((macro (macro-function symbol)) - (name (symbol-name symbol))) - (if macro - (let ((file (fun-defined-from-pathname macro))) - (if file - (values file :macro name) - (values nil :unknown-macro name))) - (if (fboundp symbol) - (let ((file (fun-defined-from-pathname symbol))) - (if file - (values file :function name) - (values nil :unknown-function name))) - (error "~S is not a function." symbol)))))) +(defparameter *source-file-indicator-defining-operators* ()) + +(defun define-source-file-indicator-defining-operators (name &rest operators) + (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 'defmacro 'defgeneric #+x8664-target 'ccl::defx86lapfunction #+ppc-target 'ccl::defppclapfunction) +(define-source-file-indicator-defining-operators 'ccl::constant 'defconstant) +(define-source-file-indicator-defining-operators 'variable 'defvar 'defparameter 'ccl::defstatic 'ccl::defglobal) +(define-source-file-indicator-defining-operators 'method-combination 'define-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-compiler-macro) +#+ppc32-target +(define-source-file-indicator-defining-operators 'ccl::ppc32-vinsn 'ccl::define-ppc32-vinsn) +#+ppc64-target +(define-source-file-indicator-defining-operators 'ccl::ppc64-vinsn 'ccl::define-ppc64-vinsn) +#+x8664-target +(define-source-file-indicator-defining-operators 'ccl::x8664-vinsn 'ccl::define-x8664-vinsn) + + +(defun match-definition-context-for-method (end-mark package indicator) + (let* ((specializers (openmcl-mop:method-specializers indicator)) + (qualifiers (openmcl-mop:method-qualifiers indicator))) + (block win + (with-mark ((work end-mark)) + (when qualifiers + (dotimes (i (length qualifiers)) + (unless (and (form-offset end-mark 1) + (progn + (move-mark work end-mark) + (form-offset work -1))) + (return-from win nil)) + (let* ((qualifier (ignore-errors + (let* ((*package* package)) + (values + (read-from-string (region-to-string + (region + work + end-mark)))))))) + (unless (member qualifier qualifiers) + (return-from win nil))))) + ;; end-mark is now either at end of last qualifier or + ;; after method name. Try to read the lambda list and + ;; match specializers. + (unless (and (form-offset end-mark 1) + (progn + (move-mark work end-mark) + (form-offset work -1))) + (return-from win nil)) + (multiple-value-bind (lambda-list error) + (ignore-errors + (let* ((*package* package)) + (values + (read-from-string (region-to-string + (region + work + end-mark)))))) + (unless (and (null error) + (consp lambda-list) + (ccl::proper-list-p lambda-list)) + (return-from win nil)) + (flet ((match-specializer (spec) + (when lambda-list + (let* ((arg (pop lambda-list))) + (typecase spec + (ccl::eql-specializer + (let* ((obj (openmcl-mop:eql-specializer-object spec))) + (and (ccl::proper-list-p arg) + (= 2 (length arg)) + (symbolp (pop arg)) + (ccl::proper-list-p (setq arg (car arg))) + (= (length arg) 2) + (eq (car arg) 'eql) + (eql (cadr arg) obj)))) + (class + (let* ((name (class-name spec))) + (or (if (eq name t) (eq arg t)) + (and (consp arg) + (symbolp (car arg)) + (consp (cdr arg)) + (null (cddr arg)) + (eq name (cadr arg))))))))))) + (dolist (spec specializers t) + (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)) + (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 + (ignore-errors + (let* ((*package* package)) + (values (read-from-string (region-to-string (region 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) + (declare (ignorable name indicator)) + (pre-command-parse-check mark) + (when (valid-spot mark t) + (with-mark ((start mark) + (end mark)) + (and (form-offset end 1) + (progn + (move-mark start end) + (form-offset start -1)) + (eq name (ignore-errors + (let* ((*package* package)) + (values (read-from-string (region-to-string (region start end))))))) + (match-context-for-indicator start end package indicator))))) + +(defun find-definition-in-buffer (buffer name indicator) + (setf (hi::buffer-region-active buffer) nil) + (when (symbolp name) + (let* ((string (string name)) + (len (length string)) + (pattern (get-search-pattern (string name) :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)))) + (beep)))))