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

[climacs-cvs] CVS climacs
by thenriksen 30 Apr '06

30 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5841 Modified Files: packages.lisp buffer.lisp Log Message: Added `buffer-substring' function. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/04/23 19:37:58 1.89 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/04/30 15:20:46 1.90 @@ -40,6 +40,7 @@ #:buffer-line-number #:buffer-column-number #:line-number #:column-number #:insert-buffer-object #:insert-buffer-sequence + #:buffer-substring #:insert-object #:insert-sequence #:delete-buffer-range #:delete-range #:delete-region --- /project/climacs/cvsroot/climacs/buffer.lisp 2006/04/23 12:40:31 1.32 +++ /project/climacs/cvsroot/climacs/buffer.lisp 2006/04/30 15:20:46 1.33 @@ -562,7 +562,12 @@ for i upfrom 0 do (setf (aref result i) (buffer-object buffer offset)) finally (return result)) - (make-array 0))) + (make-array 0))) + +(defun buffer-substring (buffer start end) + "Return a string of the contents of buffer from `start' to +`end', which must be offsets." + (coerce (buffer-sequence buffer start end) 'string)) (defgeneric object-before (mark) (:documentation "Return the object that is immediately before the mark. If mark is at

1 0

[climacs-cvs] CVS climacs
by thenriksen 30 Apr '06

30 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3929 Modified Files: misc-commands.lisp base.lisp Log Message: Fixed `indent-region': Update syntax for each indented line. Alsp prevent infinite loops in `do-buffer-region-lines'. --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/04/23 12:11:26 1.6 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/04/30 15:12:05 1.7 @@ -552,7 +552,12 @@ line tab-space-count syntax))) - (indent-line line indentation tab-width))))) + (indent-line line indentation tab-width)) + ;; We need to update the syntax every time we perform an + ;; indentation, so that subsequent indentations will be + ;; correctly indented (this matters in list forms). FIXME: This + ;; should probably happen automatically. + (update-syntax buffer syntax)))) (define-command (com-indent-region :name t :command-table indent-table) () "Indent every line of the current region as specified by the --- /project/climacs/cvsroot/climacs/base.lisp 2006/03/26 14:14:48 1.46 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/04/30 15:12:05 1.47 @@ -50,12 +50,13 @@ (let ((mark-sym (gensym)) (mark2-sym (gensym))) `(progn - (when (mark< ,mark2 ,mark1) - (rotatef ,mark1 ,mark2)) - (let ((,mark-sym (clone-mark ,mark1)) - (,mark2-sym (clone-mark ,mark2))) - (loop while (mark<= ,mark-sym ,mark2-sym) - do + (let* ((,mark-sym (clone-mark ,mark1)) + (,mark2-sym (clone-mark ,mark2))) + (when (mark< ,mark2-sym ,mark-sym) + (rotatef ,mark-sym ,mark2-sym)) + (loop while (and (mark<= ,mark-sym ,mark2-sym) + (not (end-of-buffer-p ,mark-sym))) + do (let ((,line-var (clone-mark ,mark-sym))) ,@body) (end-of-line ,mark-sym)

1 0

[climacs-cvs] CVS esa
by thenriksen 30 Apr '06

30 Apr '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv10537 Modified Files: esa.lisp Log Message: Made `gesture-name' return more sensible names and fixed bug in `find-keystrokes-for-command'. --- /project/climacs/cvsroot/esa/esa.lisp 2006/04/24 19:52:56 1.7 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/04/30 11:59:03 1.8 @@ -510,8 +510,11 @@ (defgeneric gesture-name (gesture)) (defmethod gesture-name ((char character)) - (or (char-name char) - char)) + (if (and (graphic-char-p char) + (not (char= char #\Space))) + (string char) + (or (char-name char) + char))) (defun translate-name-and-modifiers (key-name modifiers) (with-output-to-string (s) @@ -525,8 +528,7 @@ when (plusp (logand modifier modifiers)) do (princ name s)) (princ (if (typep key-name 'character) - (or (char-name key-name) - key-name) + (gesture-name key-name) key-name) s))) (defmethod gesture-name ((ev keyboard-event)) @@ -547,6 +549,7 @@ #'(lambda (menu-name keystroke item) (declare (ignore menu-name)) (cond ((and (eq (command-menu-item-type item) :command) + (listp (command-menu-item-value item)) (eq (car (command-menu-item-value item)) command)) (push (cons keystroke prefix) keystrokes)) ((eq (command-menu-item-type item) :menu)

1 0

[climacs-cvs] CVS esa
by crhodes 24 Apr '06

24 Apr '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv8220 Modified Files: esa.lisp Log Message: Don't handle all errors in com-extended-command --- /project/climacs/cvsroot/esa/esa.lisp 2006/04/08 23:36:44 1.6 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/04/24 19:52:56 1.7 @@ -472,9 +472,10 @@ (accept `(command :command-table ,(find-applicable-command-table *application-frame*)) :prompt "Extended Command") - (error () (progn (beep) - (display-message "No such command") - (return-from com-extended-command nil)))))) + ((or command-not-accessible command-not-present) () + (beep) + (display-message "No such command") + (return-from com-extended-command nil))))) (execute-frame-command *application-frame* item))) (set-key 'com-extended-command 'global-esa-table '((#\x :meta)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Apr '06

23 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5923 Modified Files: lisp-syntax.lisp Log Message: Oops. Removed blasting of secondary return value from `parse-symbol'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:17:17 1.56 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 21:36:23 1.57 @@ -1944,18 +1944,19 @@ (let ((package (cond ((string= package-name "") +keyword-package+) (package-name (find-package package-name)) (t package)))) - (or (and package - (find-symbol symbol-name package)) - (values (make-symbol symbol-name) nil))))) + (multiple-value-bind (symbol status) + (when package + (find-symbol symbol-name package)) + (if symbol + (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." - (let ((result (token-to-object syntax token t))) - (when (symbolp result) - result))) + (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,

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Apr '06

23 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv22484 Modified Files: pane.lisp packages.lisp file-commands.lisp Log Message: Added code to clear the cache of panes (the previous `clear-pane' invocation was apparently too naive). --- /project/climacs/cvsroot/climacs/pane.lisp 2006/03/27 19:24:07 1.36 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/04/23 19:37:58 1.37 @@ -286,6 +286,14 @@ (:default-initargs :default-view +climacs-textual-view+)) +(defgeneric clear-cache (pane) + (:documentation "Clear the cache for `pane.'")) + +(defmethod clear-cache ((pane climacs-pane)) + (with-slots (cache) pane + (setf cache (let ((cache (make-instance 'standard-flexichain))) + (insert* cache 0 nil) + cache)))) (defmethod tab-width ((pane climacs-pane)) (tab-width (stream-default-view pane))) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/04/23 12:11:26 1.88 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/04/23 19:37:58 1.89 @@ -147,6 +147,7 @@ (:export #:climacs-buffer #:needs-saving #:filepath #:read-only-p #:buffer-read-only #:climacs-pane #:point #:mark + #:clear-cache #:redisplay-pane #:full-redisplay #:display-cursor #:display-mark --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 18:38:03 1.8 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 19:37:58 1.9 @@ -212,10 +212,10 @@ (switch-to-buffer existing-buffer) (let ((buffer (make-buffer)) (pane (current-window))) - ;; Clear the pane, otherwise residue from the + ;; Clear the panes cache; otherwise residue from the ;; previously displayed buffer may under certain ;; circumstances be displayed. - (window-clear pane) + (clear-cache pane) (setf (syntax buffer) nil) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer (current-window)) buffer)

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Apr '06

23 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12015 Modified Files: file-commands.lisp Log Message: Added code to clear the pane before loading the new buffer into it. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 12:36:19 1.7 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 18:38:03 1.8 @@ -212,6 +212,10 @@ (switch-to-buffer existing-buffer) (let ((buffer (make-buffer)) (pane (current-window))) + ;; Clear the pane, otherwise residue from the + ;; previously displayed buffer may under certain + ;; circumstances be displayed. + (window-clear pane) (setf (syntax buffer) nil) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer (current-window)) buffer)

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Apr '06

23 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv20924 Modified Files: lisp-syntax.lisp Log Message: Added convenience functions for picking out elements of forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:14:49 1.55 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:17:17 1.56 @@ -1264,6 +1264,36 @@ "Returns the third formw in list." (nth-form 2 list)) +(defgeneric form-operator (form syntax) + (:documentation "Return the operator of `form' as a Lisp +object. Returns nil if none can be found.") + (:method (form syntax) nil)) + +(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)))) + operator-symbol)) + +(defgeneric form-operands (form syntax) + (:documentation "Returns the operands of `form' as a list of + Lisp objects. Returns nil if none can be found.") + (:method (form syntax) nil)) + +(defmethod form-operands ((form list-form) syntax) + ;; If *anything' goes wrong, just assume that we could not find any + ;; operands and return nil. + (mapcar #'(lambda (operand) + (if (typep operand 'form) + (token-to-object syntax operand t))) + (rest-forms (children form)))) + +(defun form-toplevel (form syntax) + "Return the top-level form of `form'." + (if (null (parent (parent form))) + form + (form-toplevel (parent form) syntax))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Apr '06

23 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19479 Modified Files: lisp-syntax.lisp Log Message: Added `token-to-object' function that will convert parser tokens to Lisp objects (for example, a `complete-list-form' to a list). Fixed a comment and some indentation. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:04:52 1.54 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:14:49 1.55 @@ -380,7 +380,7 @@ (#\| (fo) (make-instance 'multiple-escape-start-lexeme)) (t (cond ((or (constituentp object) (eql object #\\)) - (lex-token syntax scan)) + (lex-token syntax scan)) (t (fo) (make-instance 'error-lexeme)))))))) (defmethod lex ((syntax lisp-syntax) (state lexer-list-state) scan) @@ -1249,7 +1249,7 @@ (return item)))) (defun elt-form (list n) - "Returns the nth form in list." + "Returns the nth form in list or `nil'." (nth-form n list)) (defun first-form (list) @@ -1897,28 +1897,108 @@ (parse-token input readtable-case)))))) |# +(defun token-string (syntax token) + "Return the string that specifies `token' in the buffer of + `syntax'." + (coerce (buffer-sequence (buffer syntax) + (start-offset token) + (end-offset token)) + 'string)) + (defun parse-symbol (string &optional (package *package*)) "Find the symbol named STRING. -Return the symbol and a flag indicating whether the symbol was found." +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) (let ((package (cond ((string= package-name "") +keyword-package+) (package-name (find-package package-name)) (t package)))) - (if package - (find-symbol symbol-name package) - (values nil nil))))) + (or (and package + (find-symbol symbol-name package)) + (values (make-symbol symbol-name) nil))))) (defun token-to-symbol (syntax token) - (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))) - (token-string (coerce (buffer-sequence (buffer syntax) - (start-offset token) - (end-offset token)) - 'string))) - (parse-symbol token-string package))) + "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." + (let ((result (token-to-object syntax token t))) + (when (symbolp result) + result))) + +;; 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) + (: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) + ;; 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)))) + (call-next-method)) + (t () + (unless no-error + (error "Cannot convert token to Lisp object: ~A" token))))) + (:method (syntax (token t) &optional 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) + (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) + (declare (ignore no-error)) + (parse-symbol (token-string syntax token))) + +(defmethod token-to-object (syntax (token number-lexeme) &optional 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) + (declare (ignore no-error)) + (mapcar #'(lambda (form) + (token-to-object syntax form)) + (remove-if-not #'(lambda (form) + (typep form 'form)) + (children token)))) + +(defmethod token-to-object (syntax (token simple-vector-form) &optional no-error) + (declare (ignore no-error)) + (apply #'vector + (mapcar #'(lambda (form) + (token-to-object syntax form)) + (remove-if-not #'(lambda (form) + (typep form 'form)) + (children token))))) + +(defmethod token-to-object (syntax (token incomplete-string-form) &optional 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) + (declare (ignore no-error)) + (read-from-string (token-string syntax token))) + +(defmethod token-to-object (syntax (token quote-form) &optional no-error) + (list 'cl:quote + (token-to-object syntax (second (children token)) no-error))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Apr '06

23 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19077 Modified Files: lisp-syntax.lisp Log Message: Fixed the `form-{before, after, around}-in-children' functions. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 14:38:57 1.53 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 15:04:52 1.54 @@ -1547,25 +1547,26 @@ (defun form-before-in-children (children offset) (loop for (first . rest) on children - unless (typep first 'comment) - do (cond ((< (start-offset first) offset (end-offset first)) - (return (if (null (children first)) - nil - (form-before-in-children (children first) offset)))) - ((and (>= offset (end-offset first)) - (or (null rest) - ;; `first-noncomment' may return NIL if there are nothing but - ;; comments left; in that case, just take a comment - ;; with `first'. - (<= offset (start-offset (or (first-noncomment rest) - (first rest)))))) - (return (let ((potential-form - (when (typep first 'list-form) - (form-before-in-children (children first) offset)))) - (or potential-form - (when (typep first 'form) - first))))) - (t nil)))) + if (typep first 'form) + do + (cond ((< (start-offset first) offset (end-offset first)) + (return (if (null (children first)) + nil + (form-before-in-children (children first) offset)))) + ((and (>= offset (end-offset first)) + (or (null (first-form rest)) + (<= offset (start-offset (first-form rest))))) + (return (let ((potential-form + (when (typep first 'list-form) + (form-before-in-children (children first) offset)))) + (if (not (null potential-form)) + (if (<= (end-offset first) + (end-offset potential-form)) + potential-form + first) + (when (typep first 'form) + first))))) + (t nil)))) (defun form-before (syntax offset) (with-slots (stack-top) syntax @@ -1576,17 +1577,21 @@ (defun form-after-in-children (children offset) (loop for child in children - unless (typep child 'comment) - do (cond ((< (start-offset child) offset (end-offset child)) - (return (if (null (children child)) - nil - (form-after-in-children (children child) offset)))) - ((<= offset (start-offset child)) - (return (let ((potential-form (form-after-in-children (children child) offset))) - (or potential-form - (when (typep child 'form) - child))))) - (t nil)))) + if (typep child 'form) + do (cond ((< (start-offset child) offset (end-offset child)) + (return (if (null (children child)) + nil + (form-after-in-children (children child) offset)))) + ((<= offset (start-offset child)) + (return (let ((potential-form (form-after-in-children (children child) offset))) + (if (not (null potential-form)) + (if (<= (start-offset child) + (start-offset potential-form)) + child + potential-form) + (when (typep child 'form) + child))))) + (t nil)))) (defun form-after (syntax offset) (with-slots (stack-top) syntax @@ -1597,13 +1602,15 @@ (defun form-around-in-children (children offset) (loop for child in children - unless (typep child 'comment) - do (cond ((< (start-offset child) offset (end-offset child)) - (return (if (null (children child)) + if (typep child 'form) + do (cond ((<= (start-offset child) offset (end-offset child)) + (return (if (null (first-form (children child))) (when (typep child 'form) child) - (form-around-in-children (children child) offset)))) - ((<= offset (start-offset child)) + (or (form-around-in-children (children child) offset) + (when (typep child 'form) + child))))) + ((< offset (start-offset child)) (return nil)) (t nil))))

1 0