From thenriksen at common-lisp.net Thu Jun 1 19:59:11 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 1 Jun 2006 15:59:11 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060601195911.43A8056164@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv12319 Modified Files: swine.lisp climacs.lisp Log Message: Added translators and commands to only lookup some definitions of a symbol (eg, a class definition) and cleaned the rest of the cross-application Climacs calling code. --- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/05/31 18:01:04 1.17 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/01 19:59:11 1.18 @@ -1005,13 +1005,31 @@ (climacs-gui::goto-position (point (climacs-gui::current-window)) offset)) (pop-find-definition-stack))))) -(defun edit-definition (symbol) - (let ((definitions (find-definitions-for-climacs symbol))) - (cond ((null definitions) - (climacs-gui::display-message "No known definitions for: ~A" symbol) - (beep)) - (t - (goto-definition symbol definitions))))) +;; KLUDGE: We need to put more info in the definition objects to begin with. +(defun definition-type (definition) + (let ((data (read-from-string (first definition)))) + (case (first data) + ((or cl:defclass) + 'cl:class) + ((or cl:defgeneric + cl:defmethod + cl:defun + cl:defmacro) + 'cl:function) + (t t)))) + +(defun edit-definition (symbol &optional type) + (let ((all-definitions (find-definitions-for-climacs symbol))) + (let ((definitions (if (not type) + all-definitions + (remove-if-not #'(lambda (definition) + (eq (definition-type definition) type)) + all-definitions)))) + (cond ((null definitions) + (climacs-gui::display-message "No known definitions for: ~A" symbol) + (beep)) + (t + (goto-definition symbol definitions)))))) ;; XXX, get Swine into Climacs proper. (export 'edit-definition) --- /project/clim-desktop/cvsroot/clim-desktop/climacs.lisp 2006/05/31 11:11:08 1.9 +++ /project/clim-desktop/cvsroot/clim-desktop/climacs.lisp 2006/06/01 19:59:11 1.10 @@ -29,6 +29,8 @@ 'base-table '((#\c :control) (#\d :control) (#\s :control))) +;; The following code relates to calling Climacs from other applications. + (defmacro with-climacs-frame ((frame-symbol) &body body) (let ((frame-manager-sym (gensym))) `(let ((,frame-manager-sym (find-frame-manager))) @@ -46,14 +48,14 @@ ;; FIXME: The new frame must be ready, this is a hack. (sleep 1)))) -(defgeneric edit-in-climacs (thing) +(defgeneric edit-in-climacs (thing &key &allow-other-keys) (:documentation "Edit thing in Climacs, start Climacs if is not - running.") - (:method :before (thing) - (declare (ignore thing)) - (ensure-climacs))) + running.") + (:method :before (thing &key &allow-other-keys) + (declare (ignore thing)) + (ensure-climacs))) -(defmethod edit-in-climacs ((thing pathname)) +(defmethod edit-in-climacs ((thing pathname) &key &allow-other-keys) (when (wild-pathname-p thing) (error 'file-error :pathname thing "Cannot edit wild pathname.")) @@ -62,15 +64,35 @@ (execute-frame-command frame `(com-find-file ,thing))))) -(defmethod edit-in-climacs ((thing string)) +(defmethod edit-in-climacs ((thing string) &key &allow-other-keys) ;; Hope it is a pathname. (edit-in-climacs (pathname thing))) -(defmethod edit-in-climacs ((thing symbol)) +(defmethod edit-in-climacs ((thing symbol) &key type &allow-other-keys) (with-climacs-frame (frame) (when frame (execute-frame-command - frame `(com-edit-definition ,thing))))) + frame `(com-edit-definition-of-type ,thing ,type))))) + +;; These commands should only be called from within Climacs: + +(define-command (com-edit-definition :name t :command-table global-climacs-table) + ((symbol 'symbol + :prompt "Edit symbol")) + "Edit the definition of a symbol as a given type. + +If the symbol has been defined more than once (eg. to a function +as well as a class, or as numerous methods), a +mouse-click-sensitive list of available definitions will be +displayed." + (climacs-lisp-syntax:edit-definition symbol)) + +(define-command (com-edit-definition-of-type :name t :command-table global-climacs-table) + ((symbol 'symbol + :prompt "Edit symbol") + (type 'symbol)) + "Edit the definition of a symbol as a given type." + (climacs-lisp-syntax:edit-definition symbol type)) ;; Redefine (ed) (handler-bind ((#+sbcl sb-ext:package-lock-violation @@ -87,40 +109,50 @@ (with-climacs-frame (frame) (raise-frame frame)))))) -(define-command (com-edit-definition :name t :command-table global-climacs-table) +;; The following commands can be safely called from outside Climacs: + +(define-command (com-edit-class-definition :name t :command-table global-command-table) ((symbol 'symbol :prompt "Edit symbol")) - "Edit the definition of a symbol. + "Edit the class definition of a symbol." + (edit-in-climacs symbol :type 'class)) -If the symbol has been defined more than once (eg. to a function -as well as a class, or as numerous methods), a -mouse-click-sensitive list of available definitions will be -displayed." - (climacs-lisp-syntax:edit-definition symbol)) +(define-command (com-edit-function-definition :name t :command-table global-command-table) + ((symbol 'symbol + :prompt "Edit symbol")) + "Edit the function definition of a symbol." + (edit-in-climacs symbol :type 'function)) (define-command (com-edit-in-climacs :command-table global-command-table) ((thing t)) (edit-in-climacs thing)) -(define-presentation-to-command-translator global-edit-symbol-definition - (symbol com-edit-in-climacs global-command-table +(define-presentation-to-command-translator global-edit-symbol-definition-translator + (symbol com-edit-definition global-command-table :tester ((object presentation) (declare (ignore object)) - (not (eq (presentation-type presentation) 'unknown-symbol))) + (and (not (eq (presentation-type presentation) 'unknown-symbol)))) :gesture :edit :documentation "Edit Definition") (object) (list object)) -(define-presentation-to-command-translator global-edit-command-name-definition - (command-name com-edit-in-climacs global-command-table +(define-presentation-to-command-translator global-edit-class-name-definition-translator + (class-name com-edit-class-definition global-command-table + :gesture :edit + :documentation "Edit Class Definition") + (object) + (list object)) + +(define-presentation-to-command-translator global-edit-command-name-definition-translator + (command-name com-edit-function-definition global-command-table :gesture :edit :documentation "Edit Definition Of Command") (object) (list object)) -(define-presentation-to-command-translator global-edit-command-definition - (command com-edit-in-climacs global-command-table +(define-presentation-to-command-translator global-edit-command-definition-translator + (command com-edit-function-definition global-command-table :gesture :edit :documentation "Edit Definition Of Command") (object) From thenriksen at common-lisp.net Thu Jun 1 23:00:09 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 1 Jun 2006 19:00:09 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060601230009.E8FEE111C9@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv7956 Modified Files: climacs.lisp Log Message: The Climacs-internal com-edit-definition and com-edit-definition-of-type commands should not be directly callable (Climacs uses the global CLIM commands as well, except for com-edit-this-definition of course), add Edit Symbol Definition as the global command for editing all definitions (this fixes a bug). --- /project/clim-desktop/cvsroot/clim-desktop/climacs.lisp 2006/06/01 19:59:11 1.10 +++ /project/clim-desktop/cvsroot/clim-desktop/climacs.lisp 2006/06/01 23:00:09 1.11 @@ -76,7 +76,7 @@ ;; These commands should only be called from within Climacs: -(define-command (com-edit-definition :name t :command-table global-climacs-table) +(define-command (com-edit-definition :command-table global-climacs-table) ((symbol 'symbol :prompt "Edit symbol")) "Edit the definition of a symbol as a given type. @@ -87,7 +87,7 @@ displayed." (climacs-lisp-syntax:edit-definition symbol)) -(define-command (com-edit-definition-of-type :name t :command-table global-climacs-table) +(define-command (com-edit-definition-of-type :command-table global-climacs-table) ((symbol 'symbol :prompt "Edit symbol") (type 'symbol)) @@ -111,6 +111,17 @@ ;; The following commands can be safely called from outside Climacs: +(define-command (com-edit-symbol-definition :name t :command-table global-command-table) + ((symbol 'symbol + :prompt "Edit symbol")) + "Edit the definition of a symbol as a given type. + +If the symbol has been defined more than once (eg. to a function +as well as a class, or as numerous methods), a +mouse-click-sensitive list of available definitions will be +displayed." + (edit-in-climacs symbol)) + (define-command (com-edit-class-definition :name t :command-table global-command-table) ((symbol 'symbol :prompt "Edit symbol")) @@ -128,7 +139,7 @@ (edit-in-climacs thing)) (define-presentation-to-command-translator global-edit-symbol-definition-translator - (symbol com-edit-definition global-command-table + (symbol com-edit-symbol-definition global-command-table :tester ((object presentation) (declare (ignore object)) (and (not (eq (presentation-type presentation) 'unknown-symbol)))) From thenriksen at common-lisp.net Thu Jun 1 23:02:22 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 1 Jun 2006 19:02:22 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060601230222.ED34B11456@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv8746 Modified Files: beirc.lisp Log Message: Added Edit User Init File command, partially for easy access and partially to show off Climacs. :) --- /project/clim-desktop/cvsroot/clim-desktop/beirc.lisp 2006/01/06 03:15:45 1.1.1.1 +++ /project/clim-desktop/cvsroot/clim-desktop/beirc.lisp 2006/06/01 23:02:22 1.2 @@ -2,3 +2,7 @@ (define-beirc-command (com-browse-url :name t) ((url 'url :prompt "url")) (closure:visit url)) + +(define-beirc-command (com-edit-user-init-file :name t) + () + (ed *beirc-user-init-file*)) From thenriksen at common-lisp.net Thu Jun 1 23:21:30 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 1 Jun 2006 19:21:30 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060601232130.0823918004@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv10585 Modified Files: swine.lisp swine-cmds.lisp Log Message: Changed the generic function `show-arglist-for-form' to a normal function named `show-arglist-for-form-at-mark', added `preceding-form' function and used it instead of `this-form' in the `with-code-insight' macro. --- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/01 19:59:11 1.18 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/01 23:21:29 1.19 @@ -133,6 +133,11 @@ (or (form-around syntax (offset mark)) (form-before syntax (offset mark)))) +(defun preceding-form (mark syntax) + "Return a form at mark." + (or (form-before syntax (offset mark)) + (form-around syntax (offset mark)))) + (defun usable-package (package-designator) "Return a usable package based on `package-designator'." (or (find-package package-designator) @@ -952,7 +957,7 @@ (,form-sym ;; Find a form with a valid (fboundp) operator. (let ((immediate-form - (this-form ,mark-value-sym ,syntax-value-sym))) + (preceding-form ,mark-value-sym ,syntax-value-sym))) ;; Recurse upwards until we find a form with a valid ;; operator. This could be improved a lot, as we could ;; inspect the lambda list of the found operator and @@ -977,21 +982,16 @@ (when ,form-sym (find-operand-info ,mark-value-sym ,syntax-value-sym ,form-sym)) , at body)))) - ;; This is a generic function in order to facilitate different lambda - ;; list types for different form types (I'm not yet sure when this - ;; would be useful). -(defgeneric show-arglist-for-form (mark syntax) - (: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) +(defun show-arglist-for-form-at-mark (mark syntax) + "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." (with-code-insight mark syntax (:operator operator :preceding-operand preceding-operand :preceding-operand-indices preceding-operand-indices :operands operands) - (when (valid-operator-p operator) - (show-arglist-silent operator preceding-operand-indices preceding-operand operands)))) + (when (valid-operator-p operator) + (show-arglist-silent operator preceding-operand-indices preceding-operand operands)))) (defparameter *find-definition-stack* '()) --- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/05/31 18:01:04 1.19 +++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/06/01 23:21:29 1.20 @@ -223,9 +223,7 @@ ;; the parse tree our insertion of a space character may have ;; done. (update-syntax (buffer syntax) syntax) - ;; Try to find the argument before point, if that is not possible, - ;; find the form that point is in. - (show-arglist-for-form mark syntax) + (show-arglist-for-form-at-mark mark syntax) (forward-object mark) (clear-completions))) From thenriksen at common-lisp.net Fri Jun 2 09:25:09 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 2 Jun 2006 05:25:09 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060602092509.D95F21D007@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv21969 Modified Files: climacs.lisp Log Message: Removed unnecessary Find File Arg command. --- /project/clim-desktop/cvsroot/clim-desktop/climacs.lisp 2006/06/01 23:00:09 1.11 +++ /project/clim-desktop/cvsroot/clim-desktop/climacs.lisp 2006/06/02 09:25:09 1.12 @@ -4,10 +4,6 @@ (let ((url (accept 'url :prompt "Browse URL"))) (closure:visit url))) -(define-command (com-find-file-arg :name t :command-table buffer-table) - ((file 'pathname)) - (find-file file)) - (define-command (com-inspect-buffer :name "Inspect Buffer" :command-table base-table) () (clouseau:inspector (buffer (current-window)))) From thenriksen at common-lisp.net Fri Jun 2 21:06:32 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 2 Jun 2006 17:06:32 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060602210632.4C6C163030@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv19697 Modified Files: swine.lisp Log Message: Added fallback indentation for macros (proper indentation of &body and &rest parameters even when no specific rules have been defined for the operator). Belongs in Climacs itself (as usual). --- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/01 23:21:29 1.19 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/02 21:06:32 1.20 @@ -470,6 +470,36 @@ (show-note-counts notes (second result)) (when notes (show-notes notes (name buffer) ""))))) +;;; Fix indentation of macro forms: + +;; Redefine the basic method from Climacs to check the symbols argument list. +;; This gives us Emacs/SLIME-style indentation regarding +;; &body and &rest parameters in macros. +(defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) + (if (null (cdr path)) + ;; top level + (let* ((arglist (arglist symbol)) + (body-or-rest-pos (or (position '&body arglist) + (position '&rest arglist)))) + (if (and (or (macro-function symbol) + (special-operator-p symbol)) + (and (not (null body-or-rest-pos)) + (plusp body-or-rest-pos))) + ;; macro-form with "interesting" arguments. + (if (>= (- (car path) 2) body-or-rest-pos) + ;; &body arg. + (values (elt-noncomment (children tree) 1) 1) + ;; non-&body-arg. + (values (elt-noncomment (children tree) 1) 3)) + ;; normal form. + (if (= (car path) 2) + ;; indent like first child + (values (elt-noncomment (children tree) 1) 0) + ;; indent like second child + (values (elt-noncomment (children tree) 2) 0)))) + ;; inside a subexpression + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) + ;;; Parameter hinting code. ;;; ----------------------- From thenriksen at common-lisp.net Sat Jun 3 11:26:45 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 3 Jun 2006 07:26:45 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060603112645.B91C638009@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv32393 Modified Files: swine.lisp Log Message: Check whether symbol is fbound before looking up it's arglist. --- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/02 21:06:32 1.20 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/03 11:26:45 1.21 @@ -478,7 +478,7 @@ (defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) (if (null (cdr path)) ;; top level - (let* ((arglist (arglist symbol)) + (let* ((arglist (when (fboundp symbol) (arglist symbol))) (body-or-rest-pos (or (position '&body arglist) (position '&rest arglist)))) (if (and (or (macro-function symbol) From thenriksen at common-lisp.net Sat Jun 3 17:50:57 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 3 Jun 2006 13:50:57 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060603175057.0C24E111CC@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv19304 Modified Files: swine.lisp Log Message: Fixed `macroexpand-token' to set the package "properly" before macroexpanding and fixed `one-line-ify' to not break on strings with ending linespace. --- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/03 11:26:45 1.21 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/03 17:50:56 1.22 @@ -153,27 +153,29 @@ ;;; Real code: (defun macroexpand-token (syntax token &optional (all nil)) - (let* ((string (token-string syntax token)) - (expression (read-from-string string)) - (expansion (funcall (if all - #'macroexpand - #'macroexpand-1) - expression)) - (expansion-string (with-output-to-string (s) - (pprint expansion s)))) - (let ((buffer (climacs-gui::switch-to-buffer "*Macroexpansion*"))) - (climacs-gui::set-syntax buffer "Lisp")) - (let ((point (point (climacs-gui::current-window))) - (header-string (one-line-ify (subseq string 0 - (min 40 (length string)))))) - (climacs-gui::end-of-buffer point) - (unless (beginning-of-buffer-p point) - (insert-object point #\Newline)) - (insert-sequence point - (format nil ";;; Macroexpand-~:[1~;all~] ~A...~%" - all header-string)) - (insert-sequence point expansion-string) - (insert-object point #\Newline)))) + (with-syntax-package syntax (package) + (let ((*package* package)) + (let* ((string (token-string syntax token)) + (expression (read-from-string string)) + (expansion (funcall (if all + #'macroexpand + #'macroexpand-1) + expression)) + (expansion-string (with-output-to-string (s) + (pprint expansion s)))) + (let ((buffer (climacs-gui::switch-to-buffer "*Macroexpansion*"))) + (climacs-gui::set-syntax buffer "Lisp")) + (let ((point (point (climacs-gui::current-window))) + (header-string (one-line-ify (subseq string 0 + (min 40 (length string)))))) + (climacs-gui::end-of-buffer point) + (unless (beginning-of-buffer-p point) + (insert-object point #\Newline)) + (insert-sequence point + (format nil ";;; Macroexpand-~:[1~;all~] ~A...~%" + all header-string)) + (insert-sequence point expansion-string) + (insert-object point #\Newline)))))) (defun eval-string (string) "Evaluate all expressions in STRING and return a list of @@ -383,9 +385,13 @@ with new-string = (make-array 0 :element-type 'character :adjustable t :fill-pointer 0) when (char= (char string count) #\Newline) - do (vector-push-extend #\Space new-string) - (loop while (whitespacep (char string count)) - do (incf count)) + do (loop while (and (< count (length string)) + (whitespacep (char string count))) + do (incf count) + ;; Just ignore whitespace if it is last in the + ;; string. + finally (when (< count (length string)) + (vector-push-extend #\Space new-string))) else do (vector-push-extend (char string count) new-string) (incf count) From thenriksen at common-lisp.net Sat Jun 3 18:14:42 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 3 Jun 2006 14:14:42 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060603181442.0267115006@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv21320 Modified Files: swine.lisp swine-cmds.lisp Log Message: Added `evaluating-interactively' macro for providing error messages when Climacs cannot convert some some text to code for evaluation or compilation, added usage of this macro to Eval Region and Compile Definition. --- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/03 17:50:56 1.22 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/03 18:14:42 1.23 @@ -150,6 +150,11 @@ `(let ((,package-sym (usable-package (slot-value ,syntax 'package)))) , at body)) +(defmacro evaluating-interactively (&body body) + `(handler-case (progn , at body) + (end-of-file () + (esa:display-message "Unbalanced parentheses in form.")))) + ;;; Real code: (defun macroexpand-token (syntax token &optional (all nil)) @@ -192,11 +197,7 @@ (offset start) (offset end))) (values (multiple-value-list - (handler-case (eval-string string) - (error (condition) - (progn (beep) - (esa:display-message "~A" condition) - (return-from eval-region nil)))))) + (eval-string string))) ;; Enclose each set of values in {}. (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}" values))) --- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/06/01 23:21:29 1.20 +++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/06/03 18:14:42 1.21 @@ -82,8 +82,9 @@ (point (point (current-window)))) (when (mark> mark point) (rotatef mark point)) - (eval-region mark point - (syntax (buffer (current-window)))))) + (evaluating-interactively + (eval-region mark point + (syntax (buffer (current-window))))))) (esa:set-key 'com-eval-region 'lisp-table @@ -92,9 +93,10 @@ (define-command (com-compile-definition :name t :command-table lisp-table) () "Compile and load definition at point." - (compile-definition-interactively (point (current-window)) - (current-window) - (syntax (buffer (current-window))))) + (evaluating-interactively + (compile-definition-interactively (point (current-window)) + (current-window) + (syntax (buffer (current-window)))))) (esa:set-key 'com-compile-definition 'lisp-table From thenriksen at common-lisp.net Sun Jun 4 22:25:15 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 4 Jun 2006 18:25:15 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060604222515.2DD5F62010@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv20774 Modified Files: swine.lisp swine-cmds.lisp Log Message: Updated Swine to use the new package selection code in Climacs. --- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/03 18:14:42 1.23 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/04 22:25:15 1.24 @@ -143,13 +143,6 @@ (or (find-package package-designator) *package*)) -(defmacro with-syntax-package (syntax (package-sym) - &body body) - "Evaluate `body' with `package-sym' bound to a valid package, - preferably taken from `syntax'." - `(let ((,package-sym (usable-package (slot-value ,syntax 'package)))) - , at body)) - (defmacro evaluating-interactively (&body body) `(handler-case (progn , at body) (end-of-file () @@ -158,7 +151,7 @@ ;;; Real code: (defun macroexpand-token (syntax token &optional (all nil)) - (with-syntax-package syntax (package) + (with-syntax-package syntax (start-offset token) (package) (let ((*package* package)) (let* ((string (token-string syntax token)) (expression (read-from-string string)) @@ -204,7 +197,7 @@ (esa:display-message result)))) (defun compile-definition-interactively (mark pane syntax) - (with-syntax-package syntax (package) + (with-syntax-package syntax mark (package) (let* ((token (definition-at-mark mark syntax)) (string (token-string syntax token)) (m (clone-mark mark)) @@ -471,7 +464,7 @@ (when (and (needs-saving buffer) (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer)))) (climacs-gui::save-buffer buffer)) - (with-syntax-package (syntax buffer) (package) + (with-syntax-package (syntax buffer) 0 (package) (multiple-value-bind (result notes) (compile-file-for-climacs (filepath buffer) package load-p) (show-note-counts notes (second result)) @@ -1130,40 +1123,38 @@ (climacs-gui::delete-window *completion-pane*) (setf *completion-pane* nil))) -(defun show-completions-by-fn (fn symbol) - (with-slots (package) (syntax (buffer (climacs-gui::current-window))) - (climacs-gui::display-message (format nil "~a completions" symbol)) - (let* ((result (funcall fn symbol (package-name (usable-package package)))) - (set (first result)) - (longest (second result))) - (cond ((<= (length set) 1) - (clear-completions)) - (t (let ((stream (or *completion-pane* - (climacs-gui::typeout-window "Simple Completions")))) - (setf *completion-pane* stream) - (window-clear stream) - (format stream "~{~A~%~}" set)))) +(defun show-completions-by-fn (fn symbol package) + (climacs-gui::display-message (format nil "~a completions" symbol)) + (let* ((result (funcall fn symbol (package-name package))) + (set (first result)) + (longest (second result))) + (cond ((<= (length set) 1) + (clear-completions)) + (t (let ((stream (or *completion-pane* + (climacs-gui::typeout-window "Simple Completions")))) + (setf *completion-pane* stream) + (window-clear stream) + (format stream "~{~A~%~}" set)))) - (climacs-gui::display-message (format nil "Longest is ~a|" longest)) - longest))) + (climacs-gui::display-message (format nil "Longest is ~a|" longest)) + longest)) -(defun show-completions (symbol) - (show-completions-by-fn #'simple-completions symbol)) +(defun show-completions (symbol-name package) + (show-completions-by-fn #'simple-completions symbol-name package)) -(defun show-fuzzy-completions (symbol) - (with-syntax-package (syntax (buffer (climacs-gui::current-window))) (package) - (climacs-gui::display-message (format nil "~a completions" symbol)) - (let* ((set (fuzzy-completions symbol package 10)) - (best (caar set))) - (cond ((<= (length set) 1) - (clear-completions)) - (t (let ((stream (or *completion-pane* - (climacs-gui::typeout-window "Simple Completions")))) - (setf *completion-pane* stream) - (window-clear stream) - (loop for completed-string in set - do (format stream "~{~A ~}~%" completed-string))))) +(defun show-fuzzy-completions (symbol-name package) + (climacs-gui::display-message (format nil "~a completions" symbol-name)) + (let* ((set (fuzzy-completions symbol-name package 10)) + (best (caar set))) + (cond ((<= (length set) 1) + (clear-completions)) + (t (let ((stream (or *completion-pane* + (climacs-gui::typeout-window "Simple Completions")))) + (setf *completion-pane* stream) + (window-clear stream) + (loop for completed-string in set + do (format stream "~{~A ~}~%" completed-string))))) - (climacs-gui::display-message (format nil "Best is ~a|" best)) - best))) + (climacs-gui::display-message (format nil "Best is ~a|" best)) + best)) --- /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/06/03 18:14:42 1.21 +++ /project/clim-desktop/cvsroot/clim-desktop/swine-cmds.lisp 2006/06/04 22:25:15 1.22 @@ -32,7 +32,7 @@ (mark (point (current-window))) (token (form-before syntax (offset mark)))) (if token - (with-syntax-package syntax (package) + (with-syntax-package syntax mark (package) (let ((*package* package)) (climacs-gui::com-eval-expression (read-from-string (token-string syntax token)) @@ -238,16 +238,20 @@ If more than one completion is available, a list of possible completions will be displayed." - (let* ((point-current-window (point (current-window))) + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (point-current-window (point pane)) (name (symbol-name-at-mark point-current-window - (syntax (buffer (current-window)))))) + syntax))) (when name - (let ((completion (show-completions name)) - (mark (clone-mark point-current-window))) - (unless (= (length completion) 0) - (backward-object mark (length name)) - (delete-region mark point-current-window) - (insert-sequence point-current-window completion)))))) + (with-syntax-package syntax point-current-window (package) + (let ((completion (show-completions name package)) + (mark (clone-mark point-current-window))) + (unless (= (length completion) 0) + (backward-object mark (length name)) + (delete-region mark point-current-window) + (insert-sequence point-current-window completion))))))) (define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () "Attempt to fuzzily complete the abbreviation at mark. @@ -255,16 +259,20 @@ Fuzzy completion tries to guess which symbol is abbreviated. If the abbreviation is ambiguous, a list of possible completions will be displayed." - (let* ((point-current-window (point (current-window))) + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (point-current-window (point pane)) (name (symbol-name-at-mark point-current-window - (syntax (buffer (current-window)))))) + syntax))) (when name - (let ((completion (show-fuzzy-completions name)) - (mark (clone-mark point-current-window))) - (unless (= (length completion) 0) - (backward-object mark (length name)) - (delete-region mark point-current-window) - (insert-sequence point-current-window completion)))))) + (with-syntax-package syntax point-current-window (package) + (let ((completion (show-fuzzy-completions name package)) + (mark (clone-mark point-current-window))) + (unless (= (length completion) 0) + (backward-object mark (length name)) + (delete-region mark point-current-window) + (insert-sequence point-current-window completion))))))) (esa:set-key 'com-complete-symbol 'lisp-table From thenriksen at common-lisp.net Mon Jun 5 20:21:51 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 5 Jun 2006 16:21:51 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060605202151.06E8476042@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv2701 Modified Files: swine.lisp Log Message: `Symbol-name-at-mark': Survive if no symbol can be found at mark. --- /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/04 22:25:15 1.24 +++ /project/clim-desktop/cvsroot/clim-desktop/swine.lisp 2006/06/05 20:21:50 1.25 @@ -124,8 +124,8 @@ (defun symbol-name-at-mark (mark syntax) "Return the text of the symbol at mark." - (token-string syntax - (symbol-at-mark mark syntax))) + (let ((token (symbol-at-mark mark syntax))) + (when token (token-string syntax token)))) (defun this-form (mark syntax) "Return a form at mark. This function defines which From thenriksen at common-lisp.net Tue Jun 6 13:46:58 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 6 Jun 2006 09:46:58 -0400 (EDT) Subject: [clim-desktop-cvs] CVS clim-desktop Message-ID: <20060606134658.B9A7872022@common-lisp.net> Update of /project/clim-desktop/cvsroot/clim-desktop In directory clnet:/tmp/cvs-serv12631 Modified Files: clim-launcher.lisp Log Message: Added support for launching applications to the Listener. --- /project/clim-desktop/cvsroot/clim-desktop/clim-launcher.lisp 2006/03/30 10:33:55 1.2 +++ /project/clim-desktop/cvsroot/clim-desktop/clim-launcher.lisp 2006/06/06 13:46:58 1.3 @@ -4,8 +4,6 @@ ;;(asdf:oos 'asdf:load-op :clim-listener) ;;(asdf:oos 'asdf:load-op :climacs) - - (in-package :clim-launcher) (define-application-frame launcher () @@ -39,9 +37,9 @@ (define-launcher-command com-launch-app ((appl 'clim-app)) - ;; 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. + ;; KLUDGE: 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)) @@ -80,4 +78,71 @@ (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))) \ No newline at end of file + (run-frame-top-level (make-application-frame 'clim-launcher::launcher))) + +;; Get some support for launching apps into the CLIM Listener: + +(defmethod display-commands ((frame clim-listener::listener) stream) + (loop for app being the hash-values of *apps* + do (present app 'clim-app :stream stream))) + +(define-command (com-list-applications + :name t + :command-table clim-listener::show-commands + :menu t) + () + (display-commands *application-frame* (frame-standard-output *application-frame*))) + +(define-command (com-launch-application + :name t + :command-table clim-listener::lisp-commands + :menu t) + ((appl 'clim-app)) + ;; KLUDGE: SBCL doesn't inherit local dynamic bindings from the + ;; parent 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-presentation-to-command-translator launch-application-translator + (clim-app com-launch-application clim-listener::lisp-commands + :gesture :select + :documentation "Launch Application") + (object) + (list object)) + +(define-presentation-to-command-translator edit-application-translator + (clim-app climacs-gui::com-edit-function-definition clim-listener::lisp-commands + :gesture :edit + :tester ((object presentation) + (declare (ignore presentation)) + (symbolp (entry object))) + :documentation "Edit Application") + (object) + (list (entry object))) + +(define-presentation-method accept + ((type clim-app) stream view &key (default nil defaultp) + (default-type type)) + (multiple-value-bind (object success string) + (complete-input stream + (lambda (so-far action) + (complete-from-possibilities + so-far + (loop for val being the hash-values of *apps* + collecting val) + '() + :action action + :name-key #'name + :value-key #'identity)) + :partial-completers '(#\Space) + :allow-any-input t) + (cond (success + (values object type)) + ((and (zerop (length string)) defaultp) + (values default default-type)) + (t (values string 'string))))) \ No newline at end of file