May 2006 - climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[climacs-cvs] CVS climacs
by thenriksen 02 May '06

02 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv632 Modified Files: gui.lisp Log Message: Added new help commands. --- /project/climacs/cvsroot/climacs/gui.lisp 2006/05/01 18:36:41 1.210 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/05/02 18:02:15 1.211 @@ -478,3 +478,49 @@ (set-key 'com-kill-buffer 'pane-table '((#\x :control) (#\k))) + +;;; Commands for calling the ESA help functions. + +(define-command (com-describe-binding :name t :command-table help-table) + () + "Display documentation for the command invoked by a giving gesture sequence. +When invoked, this command will wait for user input. If the user inputs a gesture +sequence bound to a command available in the syntax of the current buffer, +documentation and other details will be displayed in a typeout pane." + (let ((command-table (esa:find-applicable-command-table *application-frame*))) + (multiple-value-bind (command gestures) + (esa::read-gestures-for-help command-table) + (let ((gesture-name (format nil "~{~A~#[~; ~; ~]~}" + (mapcar #'esa:gesture-name gestures)))) + (if command + (let ((out-stream (typeout-window (format nil "~10THelp: Describe Binding for ~A" gesture-name)))) + (describe-command-binding-to-stream gesture-name command + :command-table command-table + :stream out-stream)) + (display-message "Unbound gesture: ~A" gesture-name)))))) + +(define-command (com-describe-command :name t :command-table help-table) + ((command 'command-name)) + "Display documentation for the given command." + (unless command + (setf command (accept 'command-name))) + (let ((command-table (esa::find-applicable-command-table *application-frame*)) + (out-stream (typeout-window (format nil "~10THelp: Describe Command for ~A" command)))) + (describe-command-to-stream command + :command-table command-table + :stream out-stream))) + +(set-key 'com-describe-binding + 'help-table + '((#\h :control) (#\k))) + +(set-key '(com-describe-command nil) + 'help-table + '((#\h :control) (#\f))) + +(define-presentation-to-command-translator describe-command + (command-name com-describe-command help-table + :gesture :select + :documentation "Describe command") + (object) + (list object)) \ No newline at end of file

1 0

[climacs-cvs] CVS esa
by thenriksen 02 May '06

02 May '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv496 Modified Files: packages.lisp esa.lisp Log Message: Added command and command-binding description functions. --- /project/climacs/cvsroot/esa/packages.lisp 2006/04/08 23:36:44 1.2 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/05/02 18:01:49 1.3 @@ -9,6 +9,9 @@ #:esa-top-level #:simple-command-loop #:global-esa-table #:keyboard-macro-table #:help-table + #:describe-command-binding-to-stream + #:describe-command-to-stream + #:gesture-name #:set-key #:find-applicable-command-table)) --- /project/climacs/cvsroot/esa/esa.lisp 2006/04/30 11:59:03 1.8 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/05/02 18:01:49 1.9 @@ -639,6 +639,67 @@ :height (* length (stream-line-height stream))) (scroll-extent stream 0 0)))) +(defun print-docstring-for-command (command-name &optional (stream *standard-output*)) + "Print documentation for `command-name', which should + be a symbol bound to a function, to `stream. If no + documentation can be found, this fact will be printed to the stream." + ;; Eventually, we should try to parse the docstring and hyperlink + ;; it to other relevant symbols. + (let ((command-documentation (or (documentation command-name 'function) + "This command is not documented."))) + (princ command-documentation stream))) + +(defun describe-command-binding-to-stream (gesture-name command &key + (command-table (find-applicable-command-table *application-frame*)) + (stream *standard-output*)) + "Describe `command' as invoked by `gesture' to `stream'." + (let* ((command-name (if (listp command) + (first command) + command)) + (command-args (if (listp command) + (rest command))) + (real-command-table (or (command-accessible-in-command-table-p + command-name + command-table) + command-table))) + (princ "The gesture " stream) + (with-text-face (stream :italic) + (princ gesture-name stream)) + (princ " is bound to the command " stream) + (if (command-present-in-command-table-p command-name real-command-table) + (present command-name 'command-name :stream stream) + (present command-name 'symbol :stream stream)) + (princ " in " stream) + (present real-command-table 'command-table :stream stream) + (format stream ".~%") + (when command-args + (apply #'format stream "This binding invokes the command with the arguments ~@{~A~^, ~}.~%" command-args)) + (terpri stream) + (print-docstring-for-command command-name stream))) + +(defun describe-command-to-stream (command-name &key + (command-table (esa:find-applicable-command-table *application-frame*)) + (stream *standard-output*)) + "Describe `command' to `stream'." + (let ((keystrokes (find-keystrokes-for-command-with-inheritance command-name command-table))) + (present command-name 'command-name :stream stream) + (princ " calls the function " stream) + (present command-name 'symbol :stream stream) + (princ " and is accessible in " stream) + (present (command-accessible-in-command-table-p command-name command-table) 'command-table + :stream stream) + (format stream ".~%") + (when (plusp (length keystrokes)) + (princ "It is bound to " stream) + (loop for gestures-list on (first keystrokes) + do (format stream "~{~A~^ ~}" + (mapcar #'gesture-name (reverse (first gestures-list)))) + when (not (null (rest gestures-list))) + do (princ ", " stream))) + (terpri stream) + (terpri stream) + (print-docstring-for-command command-name stream))) + ;;; help commands (define-command-table help-table)

1 0

[climacs-cvs] CVS climacs
by thenriksen 02 May '06

02 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv30253 Modified Files: lisp-syntax.lisp Log Message: Proper indentation of multi-line string forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 17:04:37 1.61 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 17:47:19 1.62 @@ -2089,6 +2089,9 @@ (values (elt-noncomment (children tree) (1- (car path))) 0)) (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) +(defmethod indent-form ((syntax lisp-syntax) (tree string-form) path) + (values (form-toplevel tree syntax) 0)) + ;; FIXME: The next two methods are basically identical to the above definition, ;; something should be done about this duplication.

1 0

[climacs-cvs] CVS climacs
by thenriksen 02 May '06

02 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv24098 Modified Files: lisp-syntax.lisp Log Message: Fixed `form-operator'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:33:33 1.60 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 17:04:37 1.61 @@ -1272,7 +1272,7 @@ (defmethod form-operator ((form list-form) syntax) (let* ((operator-token (first-form (rest (children form)))) (operator-symbol (when operator-token - (token-to-object syntax operator-token t)))) + (token-to-object syntax operator-token :no-error t)))) operator-symbol)) (defgeneric form-operands (form syntax)

1 0

[climacs-cvs] CVS climacs
by thenriksen 02 May '06

02 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5927 Modified Files: lisp-syntax.lisp Log Message: Fixed the form-to-object methods and the form-to-symbol function. Converted all calls to `form-to-symbol' to `form-to-object'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:29:44 1.59 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:33:33 1.60 @@ -1131,7 +1131,7 @@ (when (typep x 'complete-list-form) (let ((candidate (first-form (children x)))) (and (typep candidate 'token-mixin) - (eq (token-to-symbol syntax candidate) + (eq (token-to-object syntax candidate) 'cl:in-package)))))) (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) @@ -1285,7 +1285,7 @@ ;; operands and return nil. (mapcar #'(lambda (operand) (if (typep operand 'form) - (token-to-object syntax operand t))) + (token-to-object syntax operand :no-error t))) (rest-forms (children form)))) (defun form-toplevel (form syntax) @@ -1557,7 +1557,7 @@ (start-offset conditional) (end-offset conditional)) 'string)) - (symbol (parse-symbol string +keyword-package+))) + (symbol (parse-symbol string :package +keyword-package+))) (member symbol *features*))) (defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) @@ -1576,7 +1576,7 @@ (start-offset type) (end-offset type)) 'string)) - (type-symbol (parse-symbol type-string +keyword-package+))) + (type-symbol (parse-symbol type-string :package +keyword-package+))) (case type-symbol (:and (funcall #'every #'eval-fc conditionals)) (:or (funcall #'some #'eval-fc conditionals)) @@ -1843,7 +1843,7 @@ (defmethod form-operator ((form list-form) syntax) (let* ((operator-token (first-noncomment (rest (children form)))) (operator-symbol (when operator-token - (token-to-symbol syntax operator-token)))) + (token-to-object syntax operator-token)))) operator-symbol)) ;;; shamelessly replacing SWANK code @@ -1978,12 +1978,13 @@ (end-offset token)) 'string)) -(defun parse-symbol (string &optional (package *package*)) +(defun parse-symbol (string &key (package *package*) (case (readtable-case *readtable*))) "Find the symbol named STRING. Return the symbol and a flag indicating whether the symbol was found in the package. Note that a symbol may be returned even if it was not found in a package." - (multiple-value-bind (symbol-name package-name) (parse-token string) + (multiple-value-bind (symbol-name package-name) + (parse-token string case) (let ((package (cond ((string= package-name "") +keyword-package+) (package-name (find-package package-name)) (t package)))) @@ -1994,56 +1995,58 @@ (values symbol status) (values (make-symbol symbol-name) nil)))))) -(defun token-to-symbol (syntax token) - "Return the symbol `token' represents. If `token' represents -anything else than a symbol, or it cannot be correctly converted -to a symbol, return nil. If the symbol cannot be found in a -package, an uninterned symbol will be returned." - (token-to-object syntax token t)) - -;; FIXME? This generic function often errors on erroneous input. Since -;; we are an editor, we might consider being a bit more lenient. Also, -;; it will never intern symbols itself, but return NIL for uninterned -;; symbols. -(defgeneric token-to-object (syntax token &optional no-error) +(defun token-to-symbol (syntax token &optional (case (readtable-case *readtable*))) + "Return the symbol `token' represents. If the symbol cannot be +found in a package, an uninterned symbol will be returned." + (token-to-object syntax token + :case case + :no-error t)) + +(defgeneric token-to-object (syntax token &key no-error &allow-other-keys) (:documentation "Return the Lisp object `token' would evaluate to if read. An attempt will be made to construct objects from incomplete tokens. This function may signal an error if `no-error' is nil and `token' cannot be converted to a Lisp object. Otherwise, nil will be returned.") - (:method :around (syntax token &optional no-error) + (:method :around (syntax token &key no-error package) ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. (handler-case (let ((*package* (if (and (slot-boundp syntax 'package) (slot-value syntax 'package) (typep (slot-value syntax 'package) 'package)) (slot-value syntax 'package) - (find-package :common-lisp)))) + (or (when package + (if (packagep package) + package + (find-package package))) + (find-package :common-lisp))))) (call-next-method)) (t () (unless no-error (error "Cannot convert token to Lisp object: ~A" token))))) - (:method (syntax (token t) &optional no-error) + (:method (syntax (token t) &key no-error) (declare (ignore no-error)) ;; We ignore `no-error' as it is truly a bug in Climacs if no ;; handler method is specialized on this form. (error "Cannot convert token to Lisp object: ~A" token)) - (:method (syntax (token incomplete-form-mixin) &optional no-error) + (:method (syntax (token incomplete-form-mixin) &key no-error) (unless no-error (error "Cannot convert incomplete form to Lisp object: ~A" token)))) -(defmethod token-to-object (syntax (token complete-token-lexeme) &optional no-error) +(defmethod token-to-object (syntax (token complete-token-lexeme) + &key no-error + (case (readtable-case *readtable*))) (declare (ignore no-error)) - (parse-symbol (token-string syntax token))) + (parse-symbol (token-string syntax token) :case case)) -(defmethod token-to-object (syntax (token number-lexeme) &optional no-error) +(defmethod token-to-object (syntax (token number-lexeme) &key no-error) (declare (ignore no-error)) (let ((*read-base* (base syntax))) (read-from-string (token-string syntax token)))) -(defmethod token-to-object (syntax (token list-form) &optional no-error) +(defmethod token-to-object (syntax (token list-form) &key no-error) (declare (ignore no-error)) (mapcar #'(lambda (form) (token-to-object syntax form)) @@ -2051,7 +2054,7 @@ (typep form 'form)) (children token)))) -(defmethod token-to-object (syntax (token simple-vector-form) &optional no-error) +(defmethod token-to-object (syntax (token simple-vector-form) &key no-error) (declare (ignore no-error)) (apply #'vector (mapcar #'(lambda (form) @@ -2060,19 +2063,19 @@ (typep form 'form)) (children token))))) -(defmethod token-to-object (syntax (token incomplete-string-form) &optional no-error) +(defmethod token-to-object (syntax (token incomplete-string-form) &key no-error) (declare (ignore no-error)) (read-from-string (concatenate 'string (token-string syntax token) "\""))) -(defmethod token-to-object (syntax (token complete-string-form) &optional no-error) +(defmethod token-to-object (syntax (token complete-string-form) &key no-error) (declare (ignore no-error)) (read-from-string (token-string syntax token))) -(defmethod token-to-object (syntax (token quote-form) &optional no-error) +(defmethod token-to-object (syntax (token quote-form) &key no-error) (list 'cl:quote - (token-to-object syntax (second (children token)) no-error))) + (token-to-object syntax (second (children token)) :no-error no-error))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -2111,8 +2114,8 @@ (values tree 1) (let ((first-child (elt-noncomment (children tree) 1))) (cond ((and (typep first-child 'token-mixin) - (token-to-symbol syntax first-child)) - (compute-list-indentation syntax (token-to-symbol syntax first-child) tree path)) + (token-to-object syntax first-child)) + (compute-list-indentation syntax (token-to-object syntax first-child) tree path)) ((null (cdr path)) ;; top level (if (= (car path) 2)

1 0

[climacs-cvs] CVS climacs
by thenriksen 02 May '06

02 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4439 Modified Files: lisp-syntax.lisp Log Message: Added two form extraction functions. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:25:24 1.58 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:29:44 1.59 @@ -1307,6 +1307,27 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Useful functions for selecting forms based on the mark. + +(defun expression-at-mark (mark syntax) + "Return the form at `mark'. If `mark' is just after, +or inside, a top-level-form, or if there are no forms after +`mark', the form preceding `mark' is returned. Otherwise, the +form following `mark' is returned." + (or (form-around syntax (offset mark)) + (form-after syntax (offset mark)) + (form-before syntax (offset mark)))) + +(defun definition-at-mark (mark syntax) + "Return the top-level form at `mark'. If `mark' is just after, +or inside, a top-level-form, or if there are no forms after +`mark', the top-level-form preceding `mark' is +returned. Otherwise, the top-level-form following `mark' is +returned." + (form-toplevel (expression-at-mark mark syntax) syntax)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; display (defvar *white-space-start* nil)

1 0

[climacs-cvs] CVS climacs
by thenriksen 02 May '06

02 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4377 Modified Files: lisp-syntax.lisp Log Message: Added clear highlighting of macros and special forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 21:36:23 1.57 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/02 14:25:24 1.58 @@ -1294,6 +1294,17 @@ form (form-toplevel (parent form) syntax))) +(defgeneric operator-p (token syntax) + (:documentation "Return true if `token' is the operator of its form. Otherwise, + return nil.") + (:method (token syntax) + (with-accessors ((pre-token preceding-parse-tree)) token + (cond ((typep pre-token 'left-parenthesis-lexeme) + t) + ((typep pre-token 'comment) + (operator-p pre-token syntax)) + (t nil))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display @@ -1305,8 +1316,10 @@ (defparameter *standard-faces* `((:error ,+red+ nil) - (:string ,+foreground-ink+ ,(make-text-style nil :italic nil)) + (:string ,+coral+ ,(make-text-style nil :italic nil)) (:keyword ,+dark-violet+ nil) + (:macro ,+cyan+) + (:special-form ,+cyan+) (:lambda-list-keyword ,+dark-green+ nil) (:comment ,+maroon+ nil) (:reader-conditional ,+gray50+ nil))) @@ -1315,6 +1328,8 @@ `((:error ,+red+ nil) (:string ,+gray50+ ,(make-text-style nil :italic nil)) (:keyword ,+gray50+ nil) + (:macro ,+gray50+ nil) + (:special-form ,+gray50+ nil) (:lambda-list-keyword ,+gray50+ nil) (:comment ,+gray50+ nil) (:reader-conditional ,+gray50+ nil))) @@ -1399,7 +1414,7 @@ (end-offset parse-symbol)) 'string))) (multiple-value-bind (symbol status) - (token-to-symbol syntax parse-symbol) + (token-to-object syntax parse-symbol) (with-output-as-presentation (pane (if status symbol string) (if status 'symbol 'unknown-symbol) :single-box :highlighting) @@ -1409,8 +1424,15 @@ ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) (with-face (:lambda-list-keyword) (call-next-method))) - (t (call-next-method))) - ))) + ((and (macro-function symbol) + (operator-p parse-symbol syntax)) + (with-face (:macro) + (call-next-method))) + ((and (special-operator-p symbol) + (operator-p parse-symbol syntax)) + (with-face (:special-form) + (call-next-method))) + (t (call-next-method)))))) (call-next-method))) (defmethod display-parse-tree ((parser-symbol lisp-lexeme) (syntax lisp-syntax) pane)

1 0

[climacs-cvs] CVS climacs
by thenriksen 01 May '06

01 May '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv18869 Modified Files: packages.lisp gui.lisp Log Message: Changed the colors of `climacs-rv' slightly and exported the symbol from the :climacs-gui package. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/04/30 15:20:46 1.90 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/05/01 18:36:41 1.91 @@ -174,6 +174,7 @@ ;;(:import-from :lisp-string) (:export :climacs ; Main entry point. ;; GUI functions follow. + :climacs-rv ; Entry point with alternate colors. :current-window :point :syntax --- /project/climacs/cvsroot/climacs/gui.lisp 2006/03/27 15:54:31 1.209 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/05/01 18:36:41 1.210 @@ -203,23 +203,17 @@ "Starts up a climacs session" ;; SBCL doesn't inherit dynamic bindings when starting new ;; processes, so start a new processes and THEN setup the colors. - (if new-process - (clim-sys:make-process (lambda () - (let ((*bg-color* +black+) - (*fg-color* +white+) - (*info-bg-color* +blue+) - (*info-fg-color* +yellow+) - (*mini-bg-color* +black+) - (*mini-fg-color* +white+)) - (climacs :new-process nil :width width :height height))) - :name process-name) - (let ((*bg-color* +black+) - (*fg-color* +white+) - (*info-bg-color* +blue+) - (*info-fg-color* +yellow+) - (*mini-bg-color* +black+) - (*mini-fg-color* +white+)) - (climacs :new-process new-process :process-name process-name :width width :height height)))) + (flet ((run () + (let ((*bg-color* +black+) + (*fg-color* +gray+) + (*info-bg-color* +darkslategray+) + (*info-fg-color* +gray+) + (*mini-bg-color* +black+) + (*mini-fg-color* +white+)) + (climacs :new-process nil :width width :height height)))) + (if new-process + (clim-sys:make-process #'run :name process-name) + (run)))) (defun display-info (frame pane) (let* ((master-pane (master-pane pane))

1 0