Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv14319
Modified Files: swine.lisp swine-cmds.lisp Log Message: Improved the arglist lookup code with hints about which argument point is at.
--- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/01/06 03:15:45 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/03/30 14:38:19 1.2 @@ -45,7 +45,6 @@ (backward-expression m syntax) (buffer-substring (buffer mark) (offset m) end))))
- (defun symbol-name-at-mark (mark syntax) "Return the text of the symbol at mark." (let ((potential-form (or (form-around syntax (offset mark)) @@ -95,16 +94,10 @@ (setf (offset mark) (start-offset parent)))))))
(defun enclosing-list-first-word (mark syntax) - "Return the text of the expression at mark." - (cond - ((in-type-p mark syntax 'list-form) - (let ((m (clone-mark mark))) - (when (backward-up-list-no-error m syntax) - (let ((begin (offset m))) - (re-search-forward m " | -") - (buffer-substring (buffer mark) (1+ begin) (1- (offset m))))))) - (t nil))) + "Return the text of the expression at mark. Mark need not be in +a complete list form." + ;; This is not very fast, but fast enough. + (first (reverse (enclosing-operator-names-at-mark mark syntax))))
(defun macroexpand-with-swank (mark syntax &optional (all nil)) (with-slots (package) syntax @@ -426,6 +419,129 @@ (show-swine-note-counts notes (second result)) (when notes (show-swine-notes notes (name buffer) "")))))
+(defun split-lambda-list-on-keywords (lambda-list) + "Return an alist keying lambda list keywords of `lambda-list' +to the symbols affected by the keywords." + (let ((sing-result '()) + (env (position '&environment lambda-list))) + (when env + (push (list '&environment (elt lambda-list (1+ env))) sing-result) + (setf lambda-list (remove-if (constantly t) lambda-list :start env :end (+ env 2)))) + (when (eq '&whole (first lambda-list)) + (push (subseq lambda-list 0 2) sing-result) + (setf lambda-list (cddr lambda-list))) + (do ((llk '(&mandatory &optional &key &allow-other-keys &aux &rest &body)) + (args (if (member (first lambda-list) +cl-lambda-list-keywords+) + lambda-list + (cons '&mandatory lambda-list)) + (cdr args)) + (chunk '()) + (result '())) + ((null args) + (when chunk (push (nreverse chunk) result)) + (nreverse (nconc sing-result result))) + (if (member (car args) llk) + (progn + (when chunk (push (nreverse chunk) result)) + (setf chunk (list (car args)))) + (push (car args) chunk))))) + +(defparameter +cl-lambda-list-keywords+ + '(&whole &optional &rest &key &allow-other-keys &aux &body &environment)) + +(defun affected-symbols-in-arglist (arglist index &optional preceeding-arg) + "Return a list of the symbols of `arglist' that would be + affected by entering a new argument at position `index'. Index + 0 is just after the operator and before any + arguments. `Preceeding-arg' is either nil or a symbol of the + argument preceeding the one about to be written. Only + mandatory, &optional, &rest, &body and &key-arguments are + supported, and complex argument lists from macros may not be + interpreted correctly." + (let ((split-arglist (split-lambda-list-on-keywords arglist))) + (flet ((get-args (keyword) + (rest (assoc keyword split-arglist)))) + (cond ((> (length (get-args '&mandatory)) + index) + ;; We are in the main, mandatory, positional arguments. + (list (elt (get-args '&mandatory) index))) + ((> (+ (length (get-args '&optional)) + (length (get-args '&mandatory))) + index) + ;; We are in the &optional arguments. + (list (elt (get-args '&optional) + (- index + (length (get-args '&mandatory)))))) + ((let ((body-or-rest-args (or (get-args '&rest) + (get-args '&body))) + (key-arg (find (symbol-name preceeding-arg) + (get-args '&key) + :test #'string= + :key #'(lambda (arg) + (symbol-name (if (listp arg) + (first arg) + arg)))))) + ;; We are in the &body, &rest or &key arguments. + (append (list key-arg) + body-or-rest-args + ;; Only highlight the &key + ;; symbol if we are in a position to add a new + ;; keyword-value pair, and not just in a position to + ;; specify a value for a keyword. + (when (and (null key-arg) + (get-args '&key)) + '(&key))))))))) + +(defun show-arglist-silent (symbol &optional provided-args-count preceeding-arg) + (when (fboundp symbol) + (let* ((arglist (swank::arglist symbol)) + (affected-symbols (when provided-args-count + (affected-symbols-in-arglist + arglist + provided-args-count + preceeding-arg))) + (arglist-display (apply #'concatenate 'string + (format nil"(~A" symbol) + (append (loop for arg in arglist + for argno from 1 + if (member arg affected-symbols) + collect (format nil " >~A<" arg) + else + collect (format nil " ~A" arg)) + (list ")"))))) + (esa:display-message arglist-display)))) + +(defun show-arglist (symbol name) + (unless (show-arglist-silent symbol) + (esa:display-message "Function ~a not found." name))) + +;; This is a generic function in order to facilitate different +;; argument list types for different form types (I'm not yet sure when +;; this would be useful). +(defgeneric show-arglist-for-form (mark syntax form) + (:documentation "Display the argument list for the operator of +`form'. The list need not be complete. If an argument list cannot +be retrieved for the operator, nothing will be displayed.")) + +(defmethod show-arglist-for-form (mark syntax form) + (let* ((operator-token (second (children form))) + (function-symbol (when operator-token + (token-to-symbol syntax operator-token)))) + (if (fboundp function-symbol) + (let* ((mark-form (form-before syntax (offset mark))) + (argument-elt-position (position mark-form + (children form))) + (argument-position (when argument-elt-position + (1- argument-elt-position))) + (preceding-symbol (token-to-symbol syntax mark-form))) + (show-arglist-silent function-symbol + argument-position + preceding-symbol)) + ;; If the symbol is not bound to a function, we move up + ;; a level and try that lists operator. + (when (parent form) + (show-arglist-for-form mark syntax (parent form)))))) + (defparameter *swine-find-definition-stack* '())
(defun pop-find-definition-stack () --- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/03/17 23:54:04 1.6 +++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/03/30 14:38:19 1.7 @@ -141,25 +141,17 @@ (closure:visit url))))
(esa:set-key 'com-hyperspec-lookup - 'lisp-table - '((#\c :control) (#\d :control) (#\h))) + 'lisp-table + '((#\c :control) (#\d :control) (#\h)))
- -(defun show-arglist-silent (symbol) - (if (fboundp symbol) - (let ((arglist (swank::arglist symbol))) - (esa:display-message (format nil "(~A~{ ~A~})" symbol arglist)) - t) - nil)) - -(defun show-arglist (symbol name) - (unless (show-arglist-silent symbol) - (esa:display-message "Function ~a not found." name))) - -(define-command (com-arglist-lookup :name t :command-table lisp-table) () - (let* ((name (string-upcase (or (symbol-name-at-mark (point (current-window)) +(define-command (com-arglist-lookup :name t :command-table lisp-table) + ((symbol 'symbol :prompt "Symbol")) + "Show argument list for given symbol. If the provided argument +is nil, this command will attempt to find a token at point." + (let* ((name (string-upcase (or symbol + (symbol-name-at-mark (point (current-window)) (syntax (buffer (current-window)))) - (accept 'string :prompt "Arglist lookup for symbol"))))) + (accept 'symbol :prompt "Symbol"))))) (with-slots (package) (syntax (buffer (current-window))) (let ((function-symbol (let* ((pos2 (position #: name :from-end t)) (pos1 (if (and pos2 (char= (elt name (1- pos2)) #:)) (1- pos2) pos2) )) @@ -167,49 +159,25 @@ (find-symbol name (or package *package*)))))) (show-arglist function-symbol (string-upcase name))))))
-(esa:set-key 'com-arglist-lookup - 'lisp-table - '((#\c :control) (#\d :control) (#\a))) - - +(esa:set-key '(com-arglist-lookup nil) + 'lisp-table + '((#\c :control) (#\d :control) (#\a)))
(define-command (com-swine-space :name t :command-table lisp-table) () - (let ((mark (point (current-window)))) + (let* ((window (current-window)) + (mark (point window)) + (syntax (syntax (buffer window)))) ;; It is important that the space is inserted before we look up ;; any symbols, but at the same time, there must not be a space ;; between the mark and the symbol. (insert-character #\Space) (backward-object mark) - (let* ((name (string-upcase (or (enclosing-list-first-word - mark - (syntax (buffer (current-window)))) - (symbol-name-at-mark - mark - (syntax (buffer (current-window)))))))) - (when name - (with-slots (package) (syntax (buffer (current-window))) - (let ((function-symbol (let* ((pos2 (position #: name :from-end t)) - (pos1 (if (and pos2 - ;; If the first - ;; element of - ;; the list is - ;; a keyword - ;; symbol, pos2 - ;; might be 0. - (plusp pos2) - (char= (elt name (1- pos2)) #:)) - (1- pos2) pos2))) - (handler-case (if pos1 (find-symbol (subseq name (1+ pos2)) (subseq name 0 pos1)) - (find-symbol name (or package *package*))) - (package-error (e) - ;; The specified symbol is in - ;; an invalid package. - (declare (ignore e)) - nil))))) - (show-arglist-silent function-symbol)))) - (forward-object mark) - (clear-completions)))) + (let ((form (form-before syntax (offset mark)))) + (when form + (show-arglist-for-form mark syntax form))) + (forward-object mark) + (clear-completions)))
(esa:set-key 'com-swine-space 'lisp-table