From thenriksen at common-lisp.net Wed Mar 15 10:53:40 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 15 Mar 2006 05:53:40 -0500 (EST) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060315105340.547EB4610B@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv14050 Modified Files: swine-cmds.lisp Log Message: Fixed bug where having a keyword symbol as the first element of a list would cause an error when trying to look up its arglist. --- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/02/22 10:47:29 1.3 +++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/03/15 10:53:40 1.4 @@ -177,8 +177,17 @@ (when name (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) )) - (handler-case (if pos2 (find-symbol (subseq name (1+ pos2)) (subseq name 0 pos1)) + (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 From thenriksen at common-lisp.net Wed Mar 15 15:32:26 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 15 Mar 2006 10:32:26 -0500 (EST) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060315153226.6937845058@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv18162 Modified Files: swine-cmds.lisp Log Message: Added esa package qualifier to function call. --- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/03/15 10:53:40 1.4 +++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/03/15 15:32:26 1.5 @@ -124,7 +124,7 @@ (accept 'string :prompt "Hyperspec lookup for symbol"))) (*standard-output* *debug-io*) (url (clhs-lookup:spec-lookup name))) - (if (null url) (display-message "Symbol not found.") + (if (null url) (esa:display-message "Symbol not found.") (closure:visit url)))) (esa:set-key 'com-hyperspec-lookup From thenriksen at common-lisp.net Fri Mar 17 23:54:04 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 17 Mar 2006 18:54:04 -0500 (EST) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060317235404.446F92500F@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv30113 Modified Files: swine-cmds.lisp Log Message: Updated Edit Definition command to be more presentation translator-friendly. --- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/03/15 15:32:26 1.5 +++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/03/17 23:54:04 1.6 @@ -101,13 +101,26 @@ (presentation) (list (presentation-object presentation))) -(define-command (com-edit-definition :name t :command-table lisp-table) () - (let ((name (or (symbol-name-at-mark (point (current-window)) - (syntax (buffer (current-window)))) - (accept 'symbol :prompt "Edit symbol")))) - (edit-definition name (syntax (buffer (current-window)))))) +;; This command is a bit convoluted because we want to invoke it as a +;; normal command, by a keystroke (where it automatically picks up a +;; symbol name from the buffer) and by presentation translators. If +;; NIL is passed as the symbol, the command will try looking up a +;; symbol at the current point in the buffer. +(define-command (com-edit-definition :name t :command-table lisp-table) + ((symbol 'symbol :prompt "Edit symbol")) + (flet ((fully-qualified-symbol-name (symbol) + (let ((*package* (find-package :keyword))) + (format nil "~S" symbol)))) + (let ((name (or (when symbol + (if (symbolp symbol) + (fully-qualified-symbol-name symbol) + symbol)) + (symbol-name-at-mark (point (current-window)) + (syntax (buffer (current-window)))) + (fully-qualified-symbol-name (accept 'symbol :prompt "Edit symbol"))))) + (edit-definition name (syntax (buffer (current-window))))))) -(esa:set-key 'com-edit-definition +(esa:set-key '(com-edit-definition nil) 'lisp-table '((#\. :meta))) From thenriksen at common-lisp.net Sat Mar 18 00:09:19 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 17 Mar 2006 19:09:19 -0500 (EST) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060318000919.16DFB2D025@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv31764 Modified Files: misc.lisp clim-desktop.asd clhs-lookup.lisp EDITME.lisp Log Message: EDITME.lisp is now the only file that has to be edited when installing CLIM-desktop. --- /project/clim-desktop/cvsroot/clim-desktop/misc.lisp 2006/01/06 03:15:45 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/misc.lisp 2006/03/18 00:09:18 1.2 @@ -1,3 +1,3 @@ ;;; What now? (in-package :climacs-gui) -(defvar *hyperspec-base-url* "file:///home/pimaniac/lisp/common/Hyperspec/") + --- /project/clim-desktop/cvsroot/clim-desktop/clim-desktop.asd 2006/01/06 03:15:45 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/clim-desktop.asd 2006/03/18 00:09:18 1.2 @@ -21,12 +21,13 @@ :author "Dwight Holman" :licence "" :components ((:file "package") + (:file "EDITME") (:file "abbrev") (:file "clhs-lookup" :depends-on ("abbrev")) (:file "misc") (:file "beirc") (:file "climacs") - (:file "debugger") + (:file "debugger" :depends-on ("EDITME")) (:file "listener") (:file "clim-launcher") (:file "swine") --- /project/clim-desktop/cvsroot/clim-desktop/clhs-lookup.lisp 2006/01/06 03:15:46 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/clhs-lookup.lisp 2006/03/18 00:09:18 1.2 @@ -37,15 +37,11 @@ (defparameter *hyperspec-map-file* (merge-pathnames "Map_Sym.txt" (or #.*compile-file-truename* *default-pathname-defaults*))) -(defparameter *hyperspec-root* "http://www.lispworks.com/reference/HyperSpec/") - ;;; AMOP. (defparameter *mop-map-file* (merge-pathnames "Mop_Sym.txt" (or #.*compile-file-truename* *default-pathname-defaults*))) -(defparameter *mop-root* "http://www.alu.org/mop/") - (defvar *symbol-table* (make-hash-table :test 'equalp)) (defvar *abbrev-table* (make-hash-table :test 'equalp)) --- /project/clim-desktop/cvsroot/clim-desktop/EDITME.lisp 2006/01/23 10:58:16 1.3 +++ /project/clim-desktop/cvsroot/clim-desktop/EDITME.lisp 2006/03/18 00:09:18 1.4 @@ -1,8 +1,13 @@ (in-package :common-lisp-user) -;;; EDIT ME +;;; EDIT THESE (defparameter *mcclim-directory* - (asdf:component-pathname (asdf:find-system "mcclim"))) + (asdf:component-pathname (asdf:find-system "mcclim"))) + +(defparameter *hyperspec-root* + "http://www.lispworks.com/reference/HyperSpec/") + +(defparameter *mop-root* "http://www.alu.org/mop/") ;;; LOAD THE CLIM DEBUGGER (load (merge-pathnames "Apps/Debugger/clim-debugger.lisp" *mcclim-directory*)) From thenriksen at common-lisp.net Thu Mar 30 10:33:55 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 30 Mar 2006 05:33:55 -0500 (EST) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060330103355.B51BB5903A@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv14409 Modified Files: debugger.lisp climfigurator.lisp clim-lookup.lisp clim-launcher.lisp clim-desktop.asd clhs-lookup.lisp class-browser.lisp abbrev.lisp EDITME.lisp Added Files: packages.lisp Log Message: Changed package-specific stuff to use packages.lisp. --- /project/clim-desktop/cvsroot/clim-desktop/debugger.lisp 2006/01/06 03:15:46 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/debugger.lisp 2006/03/30 10:33:55 1.2 @@ -1,5 +1,4 @@ (in-package :common-lisp-user) -(load "/home/pimaniac/lisp/common/cvs/mcclim/Apps/Debugger/clim-debugger.lisp") #+sbcl (setf *debugger-hook* #'clim-debugger:debugger) #+cmucl (setf *debug-hook* #'clim-debugger:debugger) --- /project/clim-desktop/cvsroot/clim-desktop/climfigurator.lisp 2006/01/06 03:15:46 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/climfigurator.lisp 2006/03/30 10:33:55 1.2 @@ -4,12 +4,6 @@ ;;(asdf:oos 'asdf:load-op :clim-listener) ;;(asdf:oos 'asdf:load-op :climacs) - -(in-package :common-lisp-user) -(defpackage :climfigurator - (:use :common-lisp :clim) - (:shadowing-import-from :clim-lisp-patch :interactive-stream-p)) - (in-package :climfigurator) (define-application-frame config () --- /project/clim-desktop/cvsroot/clim-desktop/clim-lookup.lisp 2006/01/06 03:15:46 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/clim-lookup.lisp 2006/03/30 10:33:55 1.2 @@ -29,8 +29,6 @@ ;; Brian Mastenbrook, bmastenb at indiana.edu -(defpackage :clim-lookup (:use :common-lisp :split-sequence) - (:export :term-lookup :populate-table)) (in-package :clim-lookup) (defvar *clim-table*) --- /project/clim-desktop/cvsroot/clim-desktop/clim-launcher.lisp 2006/01/06 03:15:45 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/clim-launcher.lisp 2006/03/30 10:33:55 1.2 @@ -5,10 +5,6 @@ ;;(asdf:oos 'asdf:load-op :climacs) -(in-package :common-lisp-user) -(defpackage :clim-launcher - (:use :common-lisp :clim) - (:shadowing-import-from :clim-lisp-patch :interactive-stream-p)) (in-package :clim-launcher) @@ -21,40 +17,67 @@ (:layouts (defaults application))) -(defvar *apps* '()) +(defvar *apps* (make-hash-table :test 'equal)) (defclass clim-app () ((name :initarg :name :accessor name :initform "") (entry :initarg :entry :accessor entry :initform (lambda (x) (format t "~A was called~%" x))))) (defmethod display-commands ((frame launcher) stream) - (loop for app in *apps* + (loop for app being the hash-values of *apps* do (present app 'clim-app :stream stream))) (define-presentation-method present (app (type clim-app) stream (view textual-view) &key) (format stream "~A~%" (name app))) +(define-launcher-command (com-refresh-list + :menu t) + () + (redisplay-frame-panes *application-frame*)) + (define-launcher-command com-launch-app ((appl 'clim-app)) - (funcall (entry appl))) + ;; SBCL doesn't keep dynamic bindings from the parent thread when + ;; invoking a new thread, so we'll have to create the threads and + ;; the bindings ourselves. + (flet ((run () + (let #+sbcl ((sb-ext:*invoke-debugger-hook* #'clim-debugger:debugger) + (*debugger-hook* #'clim-debugger:debugger)) + #-sbcl nil + (funcall (entry appl))))) + (clim-sys:make-process #'run :name (name appl)))) + +(define-launcher-command (com-remove-app) + ((appl 'clim-app)) + ;; Remove from list. + (remhash (name appl) *apps*) + (redisplay-frame-panes *application-frame*)) (defun add-app (name entry) - (push (make-instance 'clim-app :name name :entry entry) *apps*)) + (setf (gethash name *apps*) + (make-instance 'clim-app :name name :entry entry))) (define-presentation-to-command-translator launch-app (clim-app com-launch-app launcher - :gesture :select) + :gesture :select + :documentation "Launch application") (object) (list object)) -(add-app "listener" (lambda () (clim-listener:run-listener :new-process t))) -(add-app "closure" #'closure:start) -(add-app "beirc" #'beirc:beirc) -(add-app "climacs" (lambda () (climacs-gui::climacs :new-process t))) +(define-presentation-to-command-translator remove-app + (clim-app com-remove-app launcher + :gesture :delete + :documentation "Remove application") + (object) (list object)) +(add-app "Listener" (lambda () (clim-listener:run-listener))) +(add-app "Closure" 'closure:start) +(add-app "Beirc" 'beirc:beirc) +(add-app "Climacs" (lambda () (climacs-gui::climacs))) +(add-app "Climacs (RV)" (lambda () (climacs-gui::climacs-rv))) (defun start () + "Start the CLIM Launcher program." #+:cmucl (multiprocessing::startup-idle-and-top-level-loops) - (run-frame-top-level (make-application-frame 'clim-launcher::launcher))) - + (run-frame-top-level (make-application-frame 'clim-launcher::launcher))) \ No newline at end of file --- /project/clim-desktop/cvsroot/clim-desktop/clim-desktop.asd 2006/03/18 00:09:18 1.2 +++ /project/clim-desktop/cvsroot/clim-desktop/clim-desktop.asd 2006/03/30 10:33:55 1.3 @@ -1,6 +1,6 @@ ;; -*- Mode: Lisp -*- -(defpackage :clim-desktop-system +(cl:defpackage :clim-desktop-system (:use :common-lisp :asdf)) @@ -20,15 +20,15 @@ :version "0" :author "Dwight Holman" :licence "" - :components ((:file "package") - (:file "EDITME") - (:file "abbrev") + :components ((:file "packages") + (:file "EDITME" :depends-on ("packages")) + (:file "abbrev" :depends-on ("packages")) (:file "clhs-lookup" :depends-on ("abbrev")) (:file "misc") (:file "beirc") (:file "climacs") (:file "debugger" :depends-on ("EDITME")) (:file "listener") - (:file "clim-launcher") + (:file "clim-launcher" :depends-on ("packages")) (:file "swine") - (:file "swine-cmds" :depends-on ("clhs-lookup" "debugger")))) + (:file "swine-cmds" :depends-on ("swine" "clhs-lookup" "debugger")))) --- /project/clim-desktop/cvsroot/clim-desktop/clhs-lookup.lisp 2006/03/18 00:09:18 1.2 +++ /project/clim-desktop/cvsroot/clim-desktop/clhs-lookup.lisp 2006/03/30 10:33:55 1.3 @@ -24,9 +24,6 @@ ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -(defpackage :clhs-lookup (:use :common-lisp) (:export :symbol-lookup - :populate-table - :spec-lookup)) (in-package :clhs-lookup) (defparameter *hyperspec-pathname* --- /project/clim-desktop/cvsroot/clim-desktop/class-browser.lisp 2006/01/06 03:15:46 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/class-browser.lisp 2006/03/30 10:33:55 1.2 @@ -31,9 +31,6 @@ ;; Note: Don't try with a non PCL-based CLOS. ;; After loading try calling (clim-class-browser::class-browser) -(defpackage :clim-class-browser - (:use :clim :clim-lisp)) - (in-package :clim-class-browser) (define-application-frame class-browser () --- /project/clim-desktop/cvsroot/clim-desktop/abbrev.lisp 2006/01/06 03:15:45 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/abbrev.lisp 2006/03/30 10:33:55 1.2 @@ -23,10 +23,6 @@ ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - -(in-package :common-lisp-user) -(defpackage :abbrev (:use :cl :split-sequence) - (:export :abbrev)) (in-package :abbrev) (defun could-be-wrap (term char-set) --- /project/clim-desktop/cvsroot/clim-desktop/EDITME.lisp 2006/03/18 00:09:18 1.4 +++ /project/clim-desktop/cvsroot/clim-desktop/EDITME.lisp 2006/03/30 10:33:55 1.5 @@ -4,10 +4,10 @@ (defparameter *mcclim-directory* (asdf:component-pathname (asdf:find-system "mcclim"))) -(defparameter *hyperspec-root* +(defparameter clhs-lookup::*hyperspec-root* "http://www.lispworks.com/reference/HyperSpec/") -(defparameter *mop-root* "http://www.alu.org/mop/") +(defparameter clhs-lookup::*mop-root* "http://www.alu.org/mop/") ;;; LOAD THE CLIM DEBUGGER (load (merge-pathnames "Apps/Debugger/clim-debugger.lisp" *mcclim-directory*)) --- /project/clim-desktop/cvsroot/clim-desktop/packages.lisp 2006/03/30 10:33:55 NONE +++ /project/clim-desktop/cvsroot/clim-desktop/packages.lisp 2006/03/30 10:33:55 1.1 (cl:defpackage :clim-desktop (:use :common-lisp :asdf)) (cl:defpackage :clhs-lookup (:use :common-lisp) (:export :symbol-lookup :populate-table :spec-lookup)) (cl:defpackage :abbrev (:use :cl :split-sequence) (:export :abbrev)) (cl:defpackage :clim-launcher (:use :common-lisp :clim) (:shadowing-import-from :clim-lisp-patch :interactive-stream-p) (:export :start :add-app)) (cl:defpackage :climfigurator (:use :common-lisp :clim) (:shadowing-import-from :clim-lisp-patch :interactive-stream-p)) (cl:defpackage :clim-lookup (:use :common-lisp :split-sequence) (:export :term-lookup :populate-table)) (cl:defpackage :clim-class-browser (:use :clim :clim-lisp)) From thenriksen at common-lisp.net Thu Mar 30 10:36:51 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 30 Mar 2006 05:36:51 -0500 (EST) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060330103651.CDB405B005@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv14599 Removed Files: package.lisp Log Message: Removed package.lisp. From thenriksen at common-lisp.net Thu Mar 30 14:38:19 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 30 Mar 2006 09:38:19 -0500 (EST) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060330143819.60CEC4E003@common-lisp.net> 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