From thenriksen at common-lisp.net Thu Jun 1 22:51:40 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 1 Jun 2006 18:51:40 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060601225140.A15DB7061@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5957 Modified Files: file-commands.lisp Log Message: Use truenames (if available) when comparing pathnames in `find-file'. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/05/14 20:35:44 1.18 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/06/01 22:51:40 1.19 @@ -235,48 +235,56 @@ ((directory-pathname-p filepath) (display-message "~A is a directory name." filepath) (beep)) - (t - (let ((existing-buffer (find filepath (buffers *application-frame*) - :key #'filepath :test #'equal))) - (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t)) - (switch-to-buffer existing-buffer) - (progn - (when readonlyp - (unless (probe-file filepath) - (beep) - (display-message "No such file: ~A" filepath) - (return-from find-file nil))) - (let ((buffer (make-buffer)) - (pane (current-window))) - ;; Clear the pane's cache; otherwise residue from the - ;; previously displayed buffer may under certain - ;; circumstances be displayed. - (clear-cache pane) - (setf (syntax buffer) nil) - (setf (offset (point (buffer pane))) (offset (point pane))) - (setf (buffer (current-window)) buffer) - ;; Don't want to create the file if it doesn't exist. - (when (probe-file filepath) - (with-open-file (stream filepath :direction :input) - (input-from-stream stream buffer 0)) - (setf (file-write-time buffer) (file-write-date filepath)) - ;; A file! That means we may have a local options - ;; line to parse. - (evaluate-attributes-line buffer)) - ;; If the local options line didn't set a syntax, do - ;; it now. - (when (null (syntax buffer)) - (setf (syntax buffer) - (make-instance (syntax-class-name-for-filepath filepath) - :buffer buffer))) - (setf (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil - (read-only-p buffer) readonlyp) - (beginning-of-buffer (point pane)) - (update-syntax buffer (syntax buffer)) - (clear-modify buffer) - buffer))))))) + (t + (flet ((usable-pathname (pathname) + (if (probe-file pathname) + (truename pathname) + pathname))) + (let ((existing-buffer (find filepath (buffers *application-frame*) + :key #'filepath + :test #'(lambda (fp1 fp2) + (and fp1 fp2 + (equal (usable-pathname fp1) + (usable-pathname fp2))))))) + (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t)) + (switch-to-buffer existing-buffer) + (progn + (when readonlyp + (unless (probe-file filepath) + (beep) + (display-message "No such file: ~A" filepath) + (return-from find-file nil))) + (let ((buffer (make-buffer)) + (pane (current-window))) + ;; Clear the pane's cache; otherwise residue from the + ;; previously displayed buffer may under certain + ;; circumstances be displayed. + (clear-cache pane) + (setf (syntax buffer) nil) + (setf (offset (point (buffer pane))) (offset (point pane))) + (setf (buffer (current-window)) buffer) + ;; Don't want to create the file if it doesn't exist. + (when (probe-file filepath) + (with-open-file (stream filepath :direction :input) + (input-from-stream stream buffer 0)) + (setf (file-write-time buffer) (file-write-date filepath)) + ;; A file! That means we may have a local options + ;; line to parse. + (evaluate-attributes-line buffer)) + ;; If the local options line didn't set a syntax, do + ;; it now. + (when (null (syntax buffer)) + (setf (syntax buffer) + (make-instance (syntax-class-name-for-filepath filepath) + :buffer buffer))) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath) + (needs-saving buffer) nil + (read-only-p buffer) readonlyp) + (beginning-of-buffer (point pane)) + (update-syntax buffer (syntax buffer)) + (clear-modify buffer) + buffer)))))))) (defun directory-of-buffer (buffer) "Extract the directory part of the filepath to the file in BUFFER. From thenriksen at common-lisp.net Sat Jun 3 12:06:05 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 3 Jun 2006 08:06:05 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060603120605.5D0542F029@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv8830 Modified Files: lisp-syntax.lisp Log Message: Don't eat conditions in `token-to-object'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/05/31 14:47:28 1.79 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 12:06:00 1.80 @@ -2028,43 +2028,43 @@ (defgeneric token-to-object (syntax token &rest args &key no-error package quote read &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.") +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 &rest args &key no-error package quote read) ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. Also handle quoting. - (handler-case (let ((*package* (if (and (slot-boundp syntax 'package) - (slot-value syntax 'package) - (typep (slot-value syntax 'package) 'package)) - (slot-value syntax 'package) - (or (when package - (if (packagep package) - package - (find-package package))) - (find-package :common-lisp))))) - (cond (read - (read-from-string (token-string syntax token))) - (quote - (setf (getf args :quote) nil) - `',(call-next-method)) - (t - (call-next-method)))) - (t () - ;; Needs more usable error. - (unless no-error - (error "Cannot convert token to Lisp object: ~A" token))))) + (flet ((act () + (let ((*package* (if (and (slot-boundp syntax 'package) + (slot-value syntax 'package) + (typep (slot-value syntax 'package) 'package)) + (slot-value syntax 'package) + (or (when package + (if (packagep package) + package + (find-package package))) + (find-package :common-lisp))))) + (cond (read + (read-from-string (token-string syntax token))) + (quote + (setf (getf args :quote) nil) + `',(call-next-method)) + (t + (call-next-method)))))) + (if no-error + (ignore-errors (act)) + (act)))) (: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)) + (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) &key no-error) - (unless no-error - (error "Cannot convert incomplete form to Lisp object: ~A" - token)))) + (unless no-error + (error "Cannot convert incomplete form to Lisp object: ~A" + token)))) (defmethod token-to-object (syntax (token complete-token-lexeme) &key no-error From thenriksen at common-lisp.net Sat Jun 3 12:32:36 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 3 Jun 2006 08:32:36 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060603123236.7CC1E34028@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12591 Modified Files: lisp-syntax.lisp Log Message: Added `display-parse-tree' method specialized on `incomplete-list-form' to highlight unmatched left parentheses. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 12:06:00 1.80 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 12:32:36 1.81 @@ -1627,7 +1627,7 @@ (let* ((children (children parse-symbol)) (point-offset (the fixnum (offset (point pane)))) ;; The following is set to true if the location if the point - ;; warrants highlighting of a set of matching parantheses. + ;; warrants highlighting of a set of matching parentheses. (should-highlight (or (= (the fixnum (end-offset parse-symbol)) point-offset) (= (the fixnum (start-offset parse-symbol)) point-offset)))) (if should-highlight @@ -1640,6 +1640,20 @@ (display-parse-tree (car child-list) syntax pane)) else do (display-parse-tree (car child-list) syntax pane)))) + +(defmethod display-parse-tree ((parse-symbol incomplete-list-form) (syntax lisp-syntax) pane) + (let* ((children (children parse-symbol)) + (point-offset (the fixnum (offset (point pane)))) + ;; The following is set to true if the location if the point + ;; warrants highlighting of the beginning parenthesis + (should-highlight (= (the fixnum (start-offset parse-symbol)) point-offset))) + (with-face (:error) + (if should-highlight + (with-text-face (pane :bold) + (display-parse-tree (car children) syntax pane)) + (display-parse-tree (car children) syntax pane))) + (loop for child in (cdr children) do + (display-parse-tree child syntax pane)))) (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax lisp-syntax) current-p) (with-slots (top bot) pane From thenriksen at common-lisp.net Sat Jun 3 13:40:21 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 3 Jun 2006 09:40:21 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060603134021.056581D008@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19772 Modified Files: lisp-syntax.lisp Log Message: Changed the lambda list of `token-to-object', hopefully fixing an incompatible-lambda-list-error in OpenMCL. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 12:32:36 1.81 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 13:40:20 1.82 @@ -2040,7 +2040,7 @@ :case case :no-error t)) -(defgeneric token-to-object (syntax token &rest args &key no-error package quote read &allow-other-keys) +(defgeneric token-to-object (syntax token &key) (: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 From dmurray at common-lisp.net Sat Jun 3 17:58:04 2006 From: dmurray at common-lisp.net (dmurray) Date: Sat, 3 Jun 2006 13:58:04 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060603175804.7289C12046@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19455 Modified Files: misc-commands.lisp Log Message: Some fixups (Transpose Objects, Count Lines Page, Count Lines Region, What Cursor Position) --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/05/16 20:59:16 1.13 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/06/03 17:58:04 1.14 @@ -210,21 +210,19 @@ (unless (beginning-of-buffer-p mark) (when (end-of-line-p mark) (backward-object mark)) - (let ((object (object-after mark))) - (delete-range mark) - (backward-object mark) - (insert-object mark object) - (forward-object mark)))) + (unless (beginning-of-buffer-p mark) + (let ((object (object-after mark))) + (delete-range mark) + (backward-object mark) + (insert-object mark object) + (forward-object mark))))) (define-command (com-transpose-objects :name t :command-table editing-table) () "Transpose the objects before and after point, advancing point. At the end of a line transpose the previous two objects without advancing point. At the beginning of the buffer do nothing. At the beginning of any line other than the first effectively -move the first object of that line to the end of the previous line. - -FIXME: at the end of a single object line at the beginning of -the buffer deletes that object." +move the first object of that line to the end of the previous line." (transpose-objects (point (current-window)))) (set-key 'com-transpose-objects @@ -269,8 +267,7 @@ (setf ew1 (offset mark)) (forward-word mark) (when (= (offset mark) ew1) - ;; this is emacs' message in the minibuffer - (error "Don't have two things to transpose")) + (display-message "Don't have two things to transpose")) (setf ew2 (offset mark)) (backward-word mark) (setf bw2 (offset mark)) @@ -1271,8 +1268,7 @@ (define-command (com-count-lines-page :name t :command-table info-table) () "Print the number of lines in the current page. -Also prints the number of lines before and after point (as '(b + a)'). -FIXME: the count is off by one." +Also prints the number of lines before and after point (as '(b + a)')." (let* ((pane (current-window)) (point (point pane)) (start (clone-mark point)) @@ -1282,7 +1278,7 @@ (let ((total (number-of-lines-in-region start end)) (before (number-of-lines-in-region start point)) (after (number-of-lines-in-region point end))) - (display-message "Page has ~A lines (~A + ~A)" total before after)))) + (display-message "Page has ~A lines (~A + ~A)" (1+ total) before after)))) (set-key 'com-count-lines-page 'info-table @@ -1290,14 +1286,13 @@ (define-command (com-count-lines-region :name t :command-table info-table) () "Print the number of lines in the region. -Also prints the number of objects (as 'o character[s]'). -FIXME: line count is off by one." +Also prints the number of objects (as 'o character[s]')." (let* ((pane (current-window)) (point (point pane)) (mark (mark pane)) (lines (number-of-lines-in-region point mark)) (chars (abs (- (offset point) (offset mark))))) - (display-message "Region has ~D line~:P, ~D character~:P." lines chars))) + (display-message "Region has ~D line~:P, ~D character~:P." (1+ lines) chars))) (set-key 'com-count-lines-region 'info-table @@ -1315,11 +1310,14 @@ (buffer (buffer pane)) (offset (offset point)) (size (size buffer)) - (char (object-after point)) + (char (or (end-of-buffer-p point) (object-after point))) (column (column-number point))) - (display-message "Char: ~:C (#o~O ~:*~D ~:*#x~X) point=~D of ~D (~D%) column ~D" - char (char-code char) offset size - (round (* 100 (/ offset size))) column))) + (display-message "Char: ~:[none~*~;~:*~:C (#o~O ~:*~D ~:*#x~X)~] point=~D of ~D (~D%) column ~D" + (and (characterp char) char) + (and (characterp char) (char-code char)) + offset size + (if size (round (* 100 (/ offset size))) 100) + column))) (set-key 'com-what-cursor-position 'info-table From thenriksen at common-lisp.net Sun Jun 4 16:21:06 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 4 Jun 2006 12:21:06 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060604162106.6035E3C006@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4814 Modified Files: syntax.lisp lisp-syntax.lisp gui.lisp Log Message: Added optional keyword parameters to the `name-for-info-pane' generic function. --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/05/06 11:57:23 1.64 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/06/04 16:21:06 1.65 @@ -151,7 +151,9 @@ ;;; ;;; Name for info-pane -(defgeneric name-for-info-pane (syntax)) +(defgeneric name-for-info-pane (syntax &key &allow-other-keys) + (:documentation "Return the name that should be used for the + info-pane for panes displaying a buffer in this syntax.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -289,7 +291,7 @@ (declare (ignore buffer from to)) nil) -(defmethod name-for-info-pane ((syntax basic-syntax)) +(defmethod name-for-info-pane ((syntax basic-syntax) &key) (name syntax)) (defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax)) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/03 13:40:20 1.82 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/04 16:21:06 1.83 @@ -71,7 +71,7 @@ (with-slots (buffer scan) syntax (setf scan (clone-mark (low-mark buffer) :left)))) -(defmethod name-for-info-pane ((syntax lisp-syntax)) +(defmethod name-for-info-pane ((syntax lisp-syntax) &key) (format nil "Lisp~@[:~(~A~)~]" (let ((package (slot-value syntax 'package))) (typecase package --- /project/climacs/cvsroot/climacs/gui.lisp 2006/05/14 17:42:21 1.215 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/06/04 16:21:06 1.216 @@ -288,7 +288,7 @@ size))))))) (with-text-family (pane :sans-serif) (princ #\( pane) - (princ (name-for-info-pane (syntax buffer)) pane) + (princ (name-for-info-pane (syntax buffer) :pane pane) pane) (format pane "~{~:[~*~; ~A~]~}" (list (slot-value master-pane 'overwrite-mode) "Ovwrt" From thenriksen at common-lisp.net Sun Jun 4 16:27:18 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 4 Jun 2006 12:27:18 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060604162718.534F63D003@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4992 Modified Files: gui.lisp Log Message: Oops. Call `name-for-info-pane' with the master pane as the :pane parameter, not the info pane itself. --- /project/climacs/cvsroot/climacs/gui.lisp 2006/06/04 16:21:06 1.216 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/06/04 16:27:18 1.217 @@ -288,7 +288,7 @@ size))))))) (with-text-family (pane :sans-serif) (princ #\( pane) - (princ (name-for-info-pane (syntax buffer) :pane pane) pane) + (princ (name-for-info-pane (syntax buffer) :pane (master-pane pane)) pane) (format pane "~{~:[~*~; ~A~]~}" (list (slot-value master-pane 'overwrite-mode) "Ovwrt" From thenriksen at common-lisp.net Sun Jun 4 22:19:56 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 4 Jun 2006 18:19:56 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060604221956.EF10E5B01A@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv20507 Modified Files: lisp-syntax.lisp Log Message: Completely revamped the package interpretation style to be more SLIME-like (ie. the current package is determined by the points position in the buffer). Also added `with-syntax-package' macro for easy determination of the package at point. Made `token-to-object' use this macro for determining which package to look up symbols in. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/04 16:21:06 1.83 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/04 22:19:56 1.84 @@ -42,7 +42,12 @@ (current-start-mark) (current-size) (scan) - (package) + (package-list :accessor package-list + :documentation "An alist mapping the end offset + of (in-package) forms to a string of the package + designator in the form. The list is sorted with + the earliest (in-package) forms last (descending + offset).") (base :accessor base :initform 10 :documentation "The base which numbers in the buffer are @@ -71,12 +76,9 @@ (with-slots (buffer scan) syntax (setf scan (clone-mark (low-mark buffer) :left)))) -(defmethod name-for-info-pane ((syntax lisp-syntax) &key) +(defmethod name-for-info-pane ((syntax lisp-syntax) &key pane) (format nil "Lisp~@[:~(~A~)~]" - (let ((package (slot-value syntax 'package))) - (typecase package - (package (package-name package)) - (t package))))) + (package-name (package-at-mark syntax (point pane))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1167,45 +1169,86 @@ (defmethod update-syntax-for-display (buffer (syntax lisp-syntax) top bot) nil) -(defun package-of (syntax) - (let ((buffer (buffer syntax))) +(defun package-at-mark (syntax mark-or-offset) + "Get the specified Lisp package for the syntax. First, an +attempt will be made to find the package specified in +the (in-package) preceding `mark-or-offset'. If none can be +found, return the package specified in the attribute list. If no +package can be found at all, or the otherwise found packages are +invalid, return the CLIM-USER package." + (let* ((mark-offset (if (numberp mark-or-offset) + mark-or-offset + (offset mark-or-offset))) + (designator (rest (find mark-offset (package-list syntax) + :key #'first + :test #'>=)))) + (or (handler-case (find-package designator) + (type-error () + nil)) + (find-package (option-specified-package syntax)) + (find-package :clim-user)))) + +(defmacro with-syntax-package (syntax offset (package-sym) &body + body) + "Evaluate `body' with `package-sym' bound to a valid package, + preferably taken from `syntax' based on `offset'.." + `(let ((,package-sym (package-at-mark ,syntax ,offset))) + , at body)) + +(defun need-to-update-package-list-p (buffer syntax) + (let ((low-mark-offset (offset (low-mark buffer))) + (high-mark-offset (offset (high-mark buffer)))) (flet ((test (x) - (when (typep x 'complete-list-form) - (let ((candidate (first-form (children x)))) - (and (typep candidate 'token-mixin) - (eq (token-to-object syntax candidate - :no-error t) - 'cl:in-package)))))) + (let ((start-offset (start-offset x)) + (end-offset (end-offset x))) + (when (and (or (<= start-offset + low-mark-offset + end-offset + high-mark-offset) + (<= low-mark-offset + start-offset + high-mark-offset + end-offset) + (<= low-mark-offset + start-offset + end-offset + high-mark-offset) + (<= start-offset + low-mark-offset + high-mark-offset + end-offset)) + (typep x 'complete-list-form)) + (let ((candidate (first-form (children x)))) + (and (typep candidate 'token-mixin) + (eq (token-to-object syntax candidate + :no-error t) + 'cl:in-package))))))) (with-slots (stack-top) syntax - (let ((form (find-if #'test (children stack-top)))) - (or (when form - (let ((package-form (second-form (children form)))) - (when package-form - (let ((package-name - (typecase package-form - (token-mixin - (token-string syntax package-form)) - (complete-string-form - (buffer-substring - buffer - (1+ (start-offset package-form)) - (1- (end-offset package-form)))) - (quote-form - (buffer-substring - buffer - (start-offset (second-noncomment (children package-form))) - (end-offset (second-noncomment (children package-form))))) - (uninterned-symbol-form - (buffer-substring - buffer - (start-offset (second-noncomment (children package-form))) - (end-offset (second-noncomment (children package-form))))) - (t 'nil)))) - (when package-name - (let ((package-symbol (parse-token package-name))) - (or (find-package package-symbol) - package-symbol))))))) - (option-specified-package syntax))))))) + (or (not (slot-boundp syntax 'package-list)) + (loop for child in (children stack-top) + when (test child) + do (return t))))))) + +(defun update-package-list (buffer syntax) + (declare (ignore buffer)) + (setf (package-list syntax) nil) + (flet ((test (x) + (when (typep x 'complete-list-form) + (let ((candidate (first-form (children x)))) + (and (typep candidate 'token-mixin) + (eq (token-to-object syntax candidate + :no-error t) + 'cl:in-package))))) + (extract (x) + (let ((designator (second-form (children x)))) + (token-to-object syntax designator + :no-error t)))) + (with-slots (stack-top) syntax + (loop for child in (children stack-top) + when (test child) + do (push (cons (end-offset child) + (extract child)) + (package-list syntax)))))) (defmethod update-syntax (buffer (syntax lisp-syntax)) (let* ((low-mark (low-mark buffer)) @@ -1213,21 +1256,21 @@ (when (mark<= low-mark high-mark) (catch 'done (with-slots (current-state stack-top scan potentially-valid-trees) syntax - (setf potentially-valid-trees - (if (null stack-top) - nil - (find-first-potentially-valid-lexeme (children stack-top) - (offset high-mark)))) - (setf stack-top (find-last-valid-lexeme stack-top (offset low-mark))) - (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top)) - current-state (if (null stack-top) - |initial-state | - (new-state syntax - (parser-state stack-top) - stack-top))) - (loop do (parse-patch syntax)))))) - (with-slots (package) syntax - (setf package (package-of syntax)))) + (setf potentially-valid-trees + (if (null stack-top) + nil + (find-first-potentially-valid-lexeme (children stack-top) + (offset high-mark)))) + (setf stack-top (find-last-valid-lexeme stack-top (offset low-mark))) + (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top)) + current-state (if (null stack-top) + |initial-state | + (new-state syntax + (parser-state stack-top) + stack-top))) + (loop do (parse-patch syntax)))))) + (when (need-to-update-package-list-p buffer syntax) + (update-package-list buffer syntax))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -2050,22 +2093,16 @@ ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. Also handle quoting. (flet ((act () - (let ((*package* (if (and (slot-boundp syntax 'package) - (slot-value syntax 'package) - (typep (slot-value syntax 'package) 'package)) - (slot-value syntax 'package) - (or (when package - (if (packagep package) - package - (find-package package))) - (find-package :common-lisp))))) + (with-syntax-package syntax (start-offset token) + (syntax-package) + (let ((*package* syntax-package)) (cond (read (read-from-string (token-string syntax token))) (quote (setf (getf args :quote) nil) `',(call-next-method)) (t - (call-next-method)))))) + (call-next-method))))))) (if no-error (ignore-errors (act)) (act)))) From thenriksen at common-lisp.net Mon Jun 5 16:13:33 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 5 Jun 2006 12:13:33 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060605161333.36A4D3A006@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4125 Modified Files: lisp-syntax.lisp Log Message: Fixed a bunch of structural Lisp movement commands/methods (from elimination of infinite loops to proper handling of quote and backquote forms). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/04 22:19:56 1.84 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/05 16:13:33 1.85 @@ -1791,6 +1791,38 @@ nil (form-around-in-children (children stack-top) offset)))) +(defun find-list-parent-offset (form fn) + "Find a list parent of `token' and return `fn' +applied to this parent token. `Fn' should be a function +that returns an offset when applied to a +token (eg. `start-offset' or `end-offset'). If a list +parent cannot be found, return `fn' applied to `form'." + (when (not (typep form 'form*)) + (let ((parent (parent form))) + (typecase parent + (form* (funcall fn form)) + (list-form (funcall fn form)) + (null (funcall fn form)) + (t (find-list-parent-offset parent fn)))))) + +(defun find-list-child-offset (form fn &optional (min-offset 0)) + "Find a list child of `token' with a minimum start +offset of `min-offset' and return `fn' applied to this child token. +`Fn' should be a function that returns an offset when applied to a +token (eg. `start-offset' or `end-offset'). If a list child cannot +be found, return nil." + (labels ((has-list-child (form) + (some #'(lambda (child) + (if (and (typep child 'list-form) + (>= (start-offset child) + min-offset)) + child + (has-list-child child))) + (children form)))) + (let ((list-child (has-list-child form))) + (when (not (null list-child)) + (funcall fn list-child))))) + (defmethod backward-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) @@ -1810,7 +1842,10 @@ then (end-offset potential-form) for potential-form = (or (form-after syntax start) (form-around syntax start)) - until (null potential-form) + until (or (null potential-form) + (and (= start + (end-offset potential-form)) + (null (form-after syntax start)))) when (typep potential-form 'list-form) do (setf (offset mark) (end-offset potential-form)) (return) @@ -1821,55 +1856,52 @@ then (start-offset potential-form) for potential-form = (or (form-before syntax start) (form-around syntax start)) - until (null potential-form) + until (or (null potential-form) + (and (= start + (start-offset potential-form)) + (null (form-before syntax start)))) when (typep potential-form 'list-form) do (setf (offset mark) (start-offset potential-form)) (return) finally (error 'no-expression))) +(defun down-list-by-fn (mark syntax fn) + (let* ((offset (offset mark)) + (potential-form (form-after syntax offset))) + (let ((new-offset (typecase potential-form + (list-form (start-offset potential-form)) + (null nil) + (t (find-list-child-offset + (parent potential-form) + fn + offset))))) + (when new-offset + (setf (offset mark) (1+ new-offset)))))) + (defmethod down-list (mark (syntax lisp-syntax)) - (loop for start = (offset mark) - then (end-offset potential-form) - for potential-form = (or (form-after syntax start) - (form-around syntax start)) - until (null potential-form) - when (typep potential-form 'list-form) - do (setf (offset mark) (1+ (start-offset potential-form))) - (return) - finally (error 'no-expression))) + (down-list-by-fn mark syntax #'start-offset)) (defmethod backward-down-list (mark (syntax lisp-syntax)) - (loop for start = (offset mark) - then (start-offset potential-form) - for potential-form = (or (form-before syntax start) - (form-around syntax start)) - until (null potential-form) - when (typep potential-form 'list-form) - do (setf (offset mark) (1- (end-offset potential-form))) - (return) - finally (error 'no-expression))) + (down-list-by-fn mark syntax #'end-offset) + (backward-object mark)) -(defmethod backward-up-list (mark (syntax lisp-syntax)) - (let ((form (or (form-around syntax (offset mark)) - (form-before syntax (offset mark)) - (form-after syntax (offset mark))))) +(defun up-list-by-fn (mark syntax fn) + (let ((form (or (form-before syntax (offset mark)) + (form-after syntax (offset mark)) + (form-around syntax (offset mark))))) (if form - (let ((parent (parent form))) - (if (typep parent 'list-form) - (setf (offset mark) (start-offset parent)) - (error 'no-expression))) - (error 'no-expression)))) + (let ((parent (parent form))) + (when (not (null parent)) + (let ((new-offset (find-list-parent-offset parent fn))) + (when new-offset + (setf (offset mark) new-offset))))) + (error 'no-expression)))) + +(defmethod backward-up-list (mark (syntax lisp-syntax)) + (up-list-by-fn mark syntax #'start-offset)) (defmethod up-list (mark (syntax lisp-syntax)) - (let ((form (or (form-around syntax (offset mark)) - (form-before syntax (offset mark)) - (form-after syntax (offset mark))))) - (if form - (let ((parent (parent form))) - (if (typep parent 'list-form) - (setf (offset mark) (end-offset parent)) - (error 'no-expression))) - (error 'no-expression)))) + (up-list-by-fn mark syntax #'end-offset)) (defmethod eval-defun (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax From thenriksen at common-lisp.net Mon Jun 5 21:01:51 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 5 Jun 2006 17:01:51 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060605210151.52F1078009@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv9456 Modified Files: packages.lisp lisp-syntax-commands.lisp base.lisp Log Message: Added `fill-region' function and used it to implement filling of strings in the Lisp syntax. I have not implemented a Fill Region command because it seemed to fit poorly within the way filling works in Climacs. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/05/28 15:58:24 1.97 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/06/05 21:01:51 1.98 @@ -77,7 +77,7 @@ #:indent-line #:indent-region #:delete-indentation - #:fill-line + #:fill-line #:fill-region #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-looking-at #:looking-at --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/03/26 14:14:48 1.4 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/06/05 21:01:51 1.5 @@ -1,4 +1,4 @@ -;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*- +;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX; -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh at labri.fr) @@ -43,13 +43,36 @@ (define-command (com-package :name t :command-table lisp-table) () (let* ((pane (current-window)) (syntax (syntax (buffer pane))) - (package (climacs-lisp-syntax::package-of syntax))) + (package (package-at-mark syntax (point pane)))) (esa:display-message (format nil "~A" (if (packagep package) (package-name package) package))))) -(define-command (com-fill-paragraph :name t :command-table lisp-table) () - ) +(define-command (com-fill-paragraph :name t :command-table lisp-table) + () + "Fill paragraph at point. Will have no effect unless there is a +string at point." + (let* ((pane (current-window)) + (buffer (buffer pane)) + (implementation (implementation buffer)) + (syntax (syntax buffer)) + (token (form-around syntax (offset (point pane)))) + (fill-column (auto-fill-column pane)) + (tab-width (tab-space-count (stream-default-view pane)))) + (when (typep token 'string-form) + (with-accessors ((offset1 start-offset) + (offset2 end-offset)) token + (fill-region (make-instance 'standard-right-sticky-mark + :buffer implementation + :offset offset1) + (make-instance 'standard-right-sticky-mark + :buffer implementation + :offset offset2) + #'(lambda (mark) + (syntax-line-indentation mark tab-width syntax)) + fill-column + tab-width + t))))) (esa:set-key 'com-fill-paragraph 'lisp-table --- /project/climacs/cvsroot/climacs/base.lisp 2006/05/14 20:35:44 1.49 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/06/05 21:01:51 1.50 @@ -587,6 +587,23 @@ (setf column 0)) (incf (offset walking-mark))))) +(defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width + &optional (compress-whitespaces t)) + "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be +mark<= `mark2.'" + (let* ((buffer (buffer mark1))) + (do-buffer-region (object offset buffer + (offset mark1) (offset mark2)) + (when (eql object #\Newline) + (setf object #\Space))) + (when (>= (buffer-display-column buffer (offset mark2) tab-width) + (1- fill-column)) + (fill-line mark2 + syntax-line-indentation-function + fill-column + tab-width + compress-whitespaces)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Named objects From thenriksen at common-lisp.net Tue Jun 6 16:50:36 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 6 Jun 2006 12:50:36 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060606165036.CE4A86D01D@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv4207 Modified Files: packages.lisp Log Message: Export `current-buffer' and `current-point' from CLIMACS-GUI. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/06/05 21:01:51 1.98 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/06/06 16:50:36 1.99 @@ -177,6 +177,8 @@ ;; GUI functions follow. :climacs-rv ; Entry point with alternate colors. :current-window + :current-point + :current-buffer :current-buffer :point :syntax From thenriksen at common-lisp.net Mon Jun 12 10:48:30 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 12 Jun 2006 06:48:30 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060612104830.11EBF7800B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11217 Modified Files: lisp-syntax.lisp Log Message: Added simple-minded indentation rule for comma-forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/05 16:13:33 1.85 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/12 10:48:29 1.86 @@ -2302,6 +2302,9 @@ (defmethod indent-form ((syntax lisp-syntax) (tree backquote-form) path) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))) +(defmethod indent-form ((syntax lisp-syntax) (tree comma-form) path) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))) + (defmethod indent-form ((syntax lisp-syntax) (tree function-form) path) (if (null (cdr path)) (values tree 0) From thenriksen at common-lisp.net Tue Jun 13 11:34:52 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 13 Jun 2006 07:34:52 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060613113452.C2B621C012@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29666 Modified Files: gui.lisp Log Message: Added internal option to show line and column number in info-pane, fixed bug in info-pane display code where buffers with long names would cause an error. --- /project/climacs/cvsroot/climacs/gui.lisp 2006/06/12 19:10:58 1.218 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/06/13 11:34:52 1.219 @@ -63,6 +63,11 @@ (defparameter *with-scrollbars* t "If T, classic look and feel. If NIL, stripped-down look (:") +(defparameter *show-info-pane-mark-position* nil + "If T, show the line number and column number in the info pane + of all panes. If NIL, don't. This is off by default, as finding + the line and column numbers is potentially expensive.") + ;;; Basic command tables follow. The global command table, ;;; `global-climacs-table', inherits from these, so they should not ;;; contain any overly syntax-specific commands. The idea is that it @@ -255,7 +260,8 @@ (buffer (buffer master-pane)) (size (size buffer)) (top (top master-pane)) - (bot (bot master-pane))) + (bot (bot master-pane)) + (point (point master-pane))) (princ " " pane) (with-output-as-presentation (pane buffer 'read-only) (princ (cond @@ -274,7 +280,7 @@ (with-output-as-presentation (pane buffer 'buffer) (format pane "~A" (name buffer))) ;; FIXME: bare 25. - (format pane "~V at T" (- 25 (length (name buffer))))) + (format pane "~V at T" (max (- 25 (length (name buffer))) 1))) (format pane " ~A " (cond ((and (mark= size bot) (mark= 0 top)) @@ -286,6 +292,10 @@ (t (format nil "~a%" (round (* 100 (/ (offset top) size))))))) + (when *show-info-pane-mark-position* + (format pane "(~A,~A) " + (1+ (line-number point)) + (column-number point))) (with-text-family (pane :sans-serif) (princ #\( pane) (princ (name-for-info-pane (syntax buffer) :pane (master-pane pane)) pane) From thenriksen at common-lisp.net Tue Jun 13 14:58:37 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 13 Jun 2006 10:58:37 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060613145837.E388246121@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25345 Modified Files: lisp-syntax.lisp Log Message: Fixed indentation for quote and backquote forms (again?). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/12 19:10:58 1.87 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/13 14:58:37 1.88 @@ -2309,10 +2309,10 @@ (values tree 0)) (defmethod indent-form ((syntax lisp-syntax) (tree quote-form) path) - (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))) + (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) (defmethod indent-form ((syntax lisp-syntax) (tree backquote-form) path) - (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))) + (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) (defmethod indent-form ((syntax lisp-syntax) (tree comma-form) path) (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))) From thenriksen at common-lisp.net Mon Jun 12 19:10:59 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 12 Jun 2006 15:10:59 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060612191059.19F1968001@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv23493 Modified Files: ttcn3-syntax.lisp text-syntax.lisp syntax.lisp slidemacs.lisp search-commands.lisp prolog-syntax.lisp packages.lisp misc-commands.lisp lisp-syntax.lisp lisp-syntax-commands.lisp html-syntax.lisp gui.lisp fundamental-syntax.lisp file-commands.lisp climacs.asd cl-syntax.lisp buffer.lisp base.lisp Added Files: motion.lisp motion-commands.lisp editing.lisp editing-commands.lisp Log Message: Major motion and editing functions and commands refactoring (see the thread "paredit.lisp, regularization of motion commands, and more" on climacs-devel for full details). Breakage not found during testing, but still expected. --- /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/05/06 19:51:04 1.5 +++ /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/06/12 19:10:58 1.6 @@ -372,7 +372,7 @@ (incf valid-parse)))) (defmethod inter-lexeme-object-p ((lexer ttcn3-lexer) object) - (whitespacep object)) + (whitespacep (syntax (buffer lexer)) object)) (defmethod update-syntax (buffer (syntax ttcn3-syntax)) (with-slots (lexer valid-parse) syntax @@ -392,7 +392,8 @@ (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (and (< start end) - (whitespacep (buffer-object buffer start))) + (whitespacep (syntax buffer) + (buffer-object buffer start))) do (ecase (buffer-object buffer start) (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) --- /project/climacs/cvsroot/climacs/text-syntax.lisp 2005/08/06 20:51:19 1.9 +++ /project/climacs/cvsroot/climacs/text-syntax.lisp 2006/06/12 19:10:58 1.10 @@ -148,16 +148,17 @@ (incf pos1)) (t nil)))))))) -(defmethod backward-paragraph (mark (syntax text-syntax)) +(defmethod backward-one-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax (let ((pos1 (index-of-mark-after-offset paragraphs (offset mark)))) (when (> pos1 0) (setf (offset mark) (if (typep (element* paragraphs (1- pos1)) 'right-sticky-mark) (offset (element* paragraphs (- pos1 2))) - (offset (element* paragraphs (1- pos1))))))))) + (offset (element* paragraphs (1- pos1))))) + t)))) -(defmethod forward-paragraph (mark (syntax text-syntax)) +(defmethod forward-one-paragraph (mark (syntax text-syntax)) (with-slots (paragraphs) syntax (let ((pos1 (index-of-mark-after-offset paragraphs @@ -168,16 +169,18 @@ (setf (offset mark) (if (typep (element* paragraphs pos1) 'left-sticky-mark) (offset (element* paragraphs (1+ pos1))) - (offset (element* paragraphs pos1)))))))) + (offset (element* paragraphs pos1)))) + t)))) - (defmethod backward-sentence (mark (syntax text-syntax)) + (defmethod backward-one-sentence (mark (syntax text-syntax)) (with-slots (sentence-beginnings) syntax (let ((pos1 (index-of-mark-after-offset sentence-beginnings (offset mark)))) (when (> pos1 0) - (setf (offset mark) - (offset (element* sentence-beginnings (1- pos1)))))))) + (setf (offset mark) + (offset (element* sentence-beginnings (1- pos1)))) + t)))) - (defmethod forward-sentence (mark (syntax text-syntax)) + (defmethod forward-one-sentence (mark (syntax text-syntax)) (with-slots (sentence-endings) syntax (let ((pos1 (index-of-mark-after-offset sentence-endings @@ -186,13 +189,14 @@ (1+ (offset mark))))) (when (< pos1 (nb-elements sentence-endings)) (setf (offset mark) - (offset (element* sentence-endings pos1))))))) + (offset (element* sentence-endings pos1))) + t)))) (defmethod syntax-line-indentation (mark tab-width (syntax text-syntax)) (loop with indentation = 0 with mark2 = (clone-mark mark) until (beginning-of-buffer-p mark2) - do (previous-line mark2) + do (climacs-motion:backward-line mark2 syntax) (setf indentation (line-indentation mark2 tab-width)) while (empty-line-p mark2) finally (return indentation))) --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/06/04 16:21:06 1.65 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/06/12 19:10:58 1.66 @@ -50,49 +50,8 @@ (:documentation "Return the correct indentation for the line containing the mark, according to the specified syntax.")) -(defgeneric forward-expression (mark syntax)) - -(defgeneric backward-expression (mark syntax)) - (defgeneric eval-defun (mark syntax)) -(defgeneric beginning-of-definition (mark syntax)) - -(defgeneric end-of-definition (mark syntax)) - -(defgeneric backward-paragraph (mark syntax)) - -(defgeneric forward-paragraph (mark syntax)) - -(defgeneric backward-sentence (mark syntax)) - -(defgeneric forward-sentence (mark syntax)) - -(defgeneric forward-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - -(defgeneric backward-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - -(defgeneric down-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - -(defgeneric backward-down-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - -(defgeneric backward-up-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - -(defgeneric up-list (mark syntax) - (:method (mark syntax) - (error 'no-such-operation))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commenting @@ -298,33 +257,9 @@ (declare (ignore mark tab-width)) 0) -(defmethod forward-expression (mark syntax) - (error 'no-such-operation)) - -(defmethod backward-expression (mark syntax) - (error 'no-such-operation)) - (defmethod eval-defun (mark syntax) (error 'no-such-operation)) -(defmethod beginning-of-defintion (mark syntax) - (error 'no-such-operation)) - -(defmethod end-of-definition (mark syntax) - (error 'no-such-operation)) - -(defmethod backward-paragraph (mark syntax) - (error 'no-such-operation)) - -(defmethod forward-paragraph (mark syntax) - (error 'no-such-operation)) - -(defmethod backward-sentence (mark syntax) - (error 'no-such-operation)) - -(defmethod forward-sentence (mark syntax) - (error 'no-such-operation)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Incremental Earley parser @@ -789,3 +724,34 @@ (defgeneric redisplay-pane-with-syntax (pane syntax current-p)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Querying + +(defgeneric word-constituentp (syntax obj) + (:documentation "Return T if `obj' is a word constituent + character in `syntax'.") + (:method (syntax obj) + nil) + (:method (syntax (obj character)) + (alphanumericp obj))) + +(defgeneric whitespacep (syntax obj) + (:documentation "Return T if `obj' is a whitespace character in + `syntax'.") + (:method (syntax obj) + nil) + (:method (syntax (obj character)) + (member obj '(#\Space #\Tab #\Newline #\Page #\Return)))) + +(defgeneric page-delimiter (syntax) + (:documentation "Return the object sequence used as a page + deliminter in `syntax'.") + (:method (syntax) + '(#\Newline #\Page))) + +(defgeneric paragraph-delimiter (syntax) + (:documentation "Return the object used as a paragraph + deliminter in `syntax'.") + (:method (syntax) + '(#\Newline #\Newline))) \ No newline at end of file --- /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/05/06 19:51:04 1.9 +++ /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/06/12 19:10:58 1.10 @@ -363,7 +363,7 @@ nil) (defmethod inter-lexeme-object-p ((lexer slidemacs-lexer) object) - (whitespacep object)) + (whitespacep (syntax (buffer lexer)) object)) (defmethod update-syntax (buffer (syntax slidemacs-editor-syntax)) (with-slots (parser lexer valid-parse) syntax @@ -389,7 +389,8 @@ (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (and (< start end) - (whitespacep (buffer-object buffer start))) + (whitespacep (syntax buffer) + (buffer-object buffer start))) do (ecase (buffer-object buffer start) (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/05/26 22:41:54 1.6 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/06/12 19:10:58 1.7 @@ -538,11 +538,13 @@ with start = 0 while (< index length) do (loop until (>= index length) - while (whitespacep (char contents index)) + while (whitespacep (syntax buffer) + (char contents index)) do (incf index)) (setf start index) (loop until (>= index length) - until (whitespacep (char contents index)) + until (whitespacep (syntax buffer) + (char contents index)) do (incf index)) until (= start index) collecting (string-trim '(#\Space #\Tab #\Newline) --- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/05/06 19:51:04 1.27 +++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/06/12 19:10:58 1.28 @@ -302,7 +302,8 @@ (t (cond ((and (string= string ".") - (or (whitespacep (object-after scan)) + (or (whitespacep (syntax (buffer lexer)) + (object-after scan)) (eql (object-after scan) #\%))) (return (make-instance 'end-lexeme))) (t (return (make-instance 'graphic-lexeme)))))) @@ -372,7 +373,8 @@ (when (or (end-of-buffer-p scan) (let ((object (object-after scan))) (or (eql object #\%) - (whitespacep object)))) + (whitespacep (syntax (buffer lexer)) + object)))) (bo) (return (make-instance 'integer-lexeme))) (loop until (end-of-buffer-p scan) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/06/06 16:50:36 1.99 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/06/12 19:10:58 1.100 @@ -32,7 +32,10 @@ #:invalid-motion #:motion-before-beginning #:motion-after-end #:size #:number-of-lines #:offset #:mark< #:mark<= #:mark= #:mark> #:mark>= - #:forward-object #:backward-object + #:forward-object + #:backward-object + #:forward-line-start #:backward-line-start + #:forward-line-end #:backward-line-end #:beginning-of-buffer #:end-of-buffer #:beginning-of-buffer-p #:end-of-buffer-p #:beginning-of-line #:end-of-line @@ -47,44 +50,41 @@ #:buffer-object #:buffer-sequence #:object-before #:object-after #:region-to-sequence #:low-mark #:high-mark #:modified-p #:clear-modify - #:binseq-buffer #:obinseq-buffer #:binseq2-buffer #:persistent-left-sticky-mark #:persistent-right-sticky-mark #:persistent-left-sticky-line-mark #:persistent-right-sticky-line-mark #:p-line-mark-mixin #:buffer-line-offset - #:delegating-buffer #:implementation)) +(defpackage :climacs-kill-ring + (:use :clim-lisp :flexichain) + (:export #:kill-ring + #:kill-ring-length #:kill-ring-max-size + #:append-next-p + #:reset-yank-position #:rotate-yank-position #:kill-ring-yank + #:kill-ring-standard-push #:kill-ring-concatenating-push + #:kill-ring-reverse-concatenating-push)) + (defpackage :climacs-base - (:use :clim-lisp :climacs-buffer) + (:use :clim-lisp :climacs-buffer :climacs-kill-ring) (:export #:do-buffer-region #:do-buffer-region-lines #:previous-line #:next-line - #:open-line #:kill-line #:empty-line-p #:line-indentation #:buffer-display-column #:number-of-lines-in-region - #:constituentp #:whitespacep + #:constituentp #:forward-word #:backward-word - #:delete-word #:backward-delete-word #:buffer-region-case - #:upcase-buffer-region #:upcase-region - #:downcase-buffer-region #:downcase-region - #:capitalize-buffer-region #:capitalize-region - #:upcase-word #:downcase-word #:capitalize-word - #:tabify-region #:untabify-region - #:indent-line - #:indent-region - #:delete-indentation - #:fill-line #:fill-region #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-looking-at #:looking-at #:buffer-search-forward #:buffer-search-backward #:buffer-re-search-forward #:buffer-re-search-backward #:search-forward #:search-backward - #:re-search-forward #:re-search-backward)) + #:re-search-forward #:re-search-backward + #:*kill-ring*)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) @@ -125,15 +125,11 @@ #:backward-down-list #:backward-up-list #:syntax-line-comment-string #:line-comment-region #:comment-region - #:line-uncomment-region #:uncomment-region)) - -(defpackage :climacs-kill-ring - (:use :clim-lisp :flexichain) - (:export #:kill-ring #:kill-ring-length #:kill-ring-max-size - #:append-next-p - #:reset-yank-position #:rotate-yank-position #:kill-ring-yank - #:kill-ring-standard-push #:kill-ring-concatenating-push - #:kill-ring-reverse-concatenating-push)) + #:line-uncomment-region #:uncomment-region + #:word-constituentp + #:whitespacep + #:page-delimiter + #:paragraph-delimiter)) (defpackage :undo (:use :common-lisp) @@ -168,10 +164,129 @@ #:url #:climacs-textual-view #:+climacs-textual-view+)) +(defpackage :climacs-motion + (:use :clim-lisp :clim :climacs-base :climacs-buffer :climacs-syntax) + (:export #:forward-to-word-boundary #:backward-to-word-boundary + #:define-motion-fns + #:beep-limit-action #:revert-limit-action #:error-limit-action + #:motion-limit-error + #:make-diligent-motor + + ;; Lines + #:forward-one-line + #:backward-one-line + #:forward-line + #:backward-line + + ;; Words + #:forward-one-word + #:backward-one-word + #:forward-word + #:backward-word + + ;; Pages + #:forward-one-page + #:backward-one-page + #:forward-page + #:backward-page + + ;; Expressions + #:forward-one-expression + #:backward-one-expression + #:forward-expression + #:backward-expression + + ;; Definitions + #:forward-one-definition + #:backward-one-definition + #:forward-definition + #:backward-definition + + ;; Up + #:forward-one-up + #:backward-one-up + #:forward-up + #:backward-up + + ;; Down + #:forward-one-down + #:backward-one-down + #:forward-down + #:backward-down + + ;; Paragraphs + #:forward-one-paragraph + #:backward-one-paragraph + #:forward-paragraph + #:backward-paragraph + + ;; Sentences + #:forward-one-sentence + #:backward-one-sentence + #:forward-sentence + #:backward-sentence)) + +(defpackage :climacs-editing + (:use :clim-lisp :clim :climacs-base :climacs-buffer + :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring) + (:export #:transpose-objects + #:open-line + + ;; Lines + #:forward-delete-line #:backward-delete-line + #:forward-kill-line #:backward-kill-line + #:transpose-lines + #:forward-delete-line-start #:backward-delete-line-start + #:forward-kill-line-start #:backward-kill-line-start + #:transpose-line-starts + + ;; Words + #:forward-delete-word #:backward-delete-word + #:forward-kill-word #:backward-kill-word + #:transpose-words + + ;; Pages + #:forward-delete-page #:backward-delete-page + #:forward-kill-page #:backward-kill-page + #:transpose-page + + ;; Expressions + #:forward-delete-expression #:backward-delete-expression + #:forward-kill-expression #:backward-kill-expression + #:transpose-expressions + + ;; Definitions + #:forward-delete-definition #:backward-delete-definition + #:forward-kill-definition #:backward-kill-definition + #:transpose-definitions + + ;; Paragraphs + #:forward-delete-paragraph #:backward-delete-paragraph + #:forward-kill-paragraph #:backward-kill-paragraph + #:transpose-paragraphs + + ;; Sentences + #:forward-delete-sentence #:backward-delete-sentence + #:forward-kill-sentence #:backward-kill-sentence + #:transpose-sentences + + #:downcase-buffer-region #:downcase-region + #:upcase-buffer-region #:upcase-region + #:downcase-word #:upcase-word + #:capitalize-buffer-region #:capitalize-region + #:capitalize-word + #:tabify-region #:untabify-region + #:indent-line + #:indent-region + #:delete-indentation + #:fill-line + #:fill-region)) + (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-abbrev :climacs-syntax - :climacs-kill-ring :climacs-pane :clim-extensions :undo :esa) + :climacs-abbrev :climacs-syntax :climacs-motion + :climacs-kill-ring :climacs-pane :clim-extensions + :undo :esa :climacs-editing :climacs-motion) ;;(:import-from :lisp-string) (:export :climacs ; Main entry point. ;; GUI functions follow. @@ -183,7 +298,35 @@ :point :syntax :mark - :insert-character)) + :insert-character + :base-table + :buffer-table + :case-table + :comment-table + :deletion-table + :development-table + :editing-table + :fill-table + :indent-table + :info-table + :marking-table + :movement-table + :pane-table + :search-table + :self-insert-table + :window-table)) + +(defpackage :climacs-motion-commands + (:use :clim-lisp :clim :climacs-base :climacs-buffer + :climacs-syntax :climacs-motion :climacs-gui :esa) + (:export #:define-motion-commands)) + +(defpackage :climacs-editing-commands + (:use :clim-lisp :clim :climacs-base :climacs-buffer + :climacs-syntax :climacs-motion :climacs-gui + :esa :climacs-editing :climacs-kill-ring) + (:export #:define-deletion-commands + #:define-editing-commands)) (defpackage :climacs-fundamental-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base @@ -206,7 +349,5 @@ (defpackage :climacs-lisp-syntax (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane :climacs-gui) - (:export :lisp-string)) - - + :climacs-syntax :flexichain :climacs-pane :climacs-gui :climacs-motion :climacs-editing) + (:export :lisp-string)) \ No newline at end of file --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/06/03 17:58:04 1.14 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/06/12 19:10:58 1.15 @@ -85,14 +85,15 @@ (lambda (mark) (syntax-line-indentation mark tab-width syntax)) fill-column - tab-width)))))) + tab-width + (syntax buffer))))))) (defun insert-character (char) (let* ((window (current-window)) (point (point window))) (unless (constituentp char) (possibly-expand-abbrev point)) - (when (whitespacep char) + (when (whitespacep (syntax (buffer window)) char) (possibly-fill-line)) (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point))) (progn @@ -103,73 +104,6 @@ (define-command com-self-insert ((count 'integer)) (loop repeat count do (insert-character *current-gesture*))) -(define-command (com-beginning-of-line :name t :command-table movement-table) () - "Move point to the beginning of the current line." - (beginning-of-line (point (current-window)))) - -(set-key 'com-beginning-of-line - 'movement-table - '((:home))) - -(set-key 'com-beginning-of-line - 'movement-table - '((#\a :control))) - -(define-command (com-end-of-line :name t :command-table movement-table) () - "Move point to the end of the current line." - (end-of-line (point (current-window)))) - -(set-key 'com-end-of-line - 'movement-table - '((#\e :control))) - -(set-key 'com-end-of-line - 'movement-table - '((:end))) - -(define-command (com-delete-object :name t :command-table deletion-table) - ((count 'integer :prompt "Number of Objects") - (killp 'boolean :prompt "Kill?")) - "Delete the object after point. -With a numeric argument, kill that many objects -after (or before, if negative) point." - (let* ((point (point (current-window))) - (mark (clone-mark point))) - (forward-object mark count) - (when killp - (kill-ring-standard-push *kill-ring* - (region-to-sequence point mark))) - (delete-region point mark))) - -(set-key `(com-delete-object ,*numeric-argument-marker* - ,*numeric-argument-p*) - 'deletion-table - '(#\Rubout)) - -(set-key `(com-delete-object ,*numeric-argument-marker* - ,*numeric-argument-p*) - 'deletion-table - '((#\d :control))) - -(define-command (com-backward-delete-object :name t :command-table deletion-table) - ((count 'integer :prompt "Number of Objects") - (killp 'boolean :prompt "Kill?")) - "Delete the object before point. -With a numeric argument, kills that many objects -before (or after, if negative) point." - (let* ((point (point (current-window))) - (mark (clone-mark point))) - (backward-object mark count) - (when killp - (kill-ring-standard-push *kill-ring* - (region-to-sequence mark point))) - (delete-region mark point))) - -(set-key `(com-backward-delete-object ,*numeric-argument-marker* - ,*numeric-argument-p*) - 'deletion-table - '(#\Backspace)) - (define-command (com-zap-to-object :name t :command-table deletion-table) () "Prompt for an object and kill to the next occurence of that object after point. Characters can be entered in #\ format." @@ -206,174 +140,6 @@ 'deletion-table '((#\z :meta))) -(defun transpose-objects (mark) - (unless (beginning-of-buffer-p mark) - (when (end-of-line-p mark) - (backward-object mark)) - (unless (beginning-of-buffer-p mark) - (let ((object (object-after mark))) - (delete-range mark) - (backward-object mark) - (insert-object mark object) - (forward-object mark))))) - -(define-command (com-transpose-objects :name t :command-table editing-table) () - "Transpose the objects before and after point, advancing point. -At the end of a line transpose the previous two objects without -advancing point. At the beginning of the buffer do nothing. -At the beginning of any line other than the first effectively -move the first object of that line to the end of the previous line." - (transpose-objects (point (current-window)))) - -(set-key 'com-transpose-objects - 'editing-table - '((#\t :control))) - -(define-command (com-backward-object :name t :command-table movement-table) - ((count 'integer :prompt "Number of Objects")) - "Move point backward one object. -With a numeric argument, move point backward (or forward, if negative) -that number of objects." - (backward-object (point (current-window)) count)) - -(set-key `(com-backward-object ,*numeric-argument-marker*) - 'movement-table - '((#\b :control))) - -(set-key `(com-backward-object ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :left #-mcclim :left-arrow))) - -(define-command (com-forward-object :name t :command-table movement-table) - ((count 'integer :prompt "Number of Objects")) - "Move point forward one object. -With a numeric argument, move point forward (or backward, if negative) -that number of objects." - (forward-object (point (current-window)) count)) - -(set-key `(com-forward-object ,*numeric-argument-marker*) - 'movement-table - '((#\f :control))) - -(set-key `(com-forward-object ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :right #-mcclim :right-arrow))) - -(defun transpose-words (mark) - (let (bw1 bw2 ew1 ew2) - (backward-word mark) - (setf bw1 (offset mark)) - (forward-word mark) - (setf ew1 (offset mark)) - (forward-word mark) - (when (= (offset mark) ew1) - (display-message "Don't have two things to transpose")) - (setf ew2 (offset mark)) - (backward-word mark) - (setf bw2 (offset mark)) - (let ((w2 (buffer-sequence (buffer mark) bw2 ew2)) - (w1 (buffer-sequence (buffer mark) bw1 ew1))) - (delete-word mark) - (insert-sequence mark w1) - (backward-word mark) - (backward-word mark) - (delete-word mark) - (insert-sequence mark w2) - (forward-word mark)))) - -(define-command (com-transpose-words :name t :command-table editing-table) () - "Transpose the words around point, leaving point at the end of them. -With point in the whitespace between words, transpose the words before -and after point. With point inside a word, transpose that word with -the next one. With point before the first word of the buffer, transpose -the first two words of the buffer. - -FIXME: with point after the penultimate word of the buffer, -or if there are <2 words in the buffer, Strange Things (TM) -happen (including breaking Climacs)." - (transpose-words (point (current-window)))) - -(set-key 'com-transpose-words - 'editing-table - '((#\t :meta))) - -(defun transpose-lines (mark) - (beginning-of-line mark) - (unless (beginning-of-buffer-p mark) - (previous-line mark)) - (let* ((bol (offset mark)) - (eol (progn (end-of-line mark) - (offset mark))) - (line (buffer-sequence (buffer mark) bol eol))) - (delete-region bol mark) - ;; Remove newline at end of line as well. - (unless (end-of-buffer-p mark) - (delete-range mark)) - ;; If the current line is at the end of the buffer, we want to - ;; be able to insert past it, so we need to get an extra line - ;; at the end. - (end-of-line mark) - (when (end-of-buffer-p mark) - (insert-object mark #\Newline)) - (next-line mark 0) - (insert-sequence mark line) - (insert-object mark #\Newline))) - -(define-command (com-transpose-lines :name t :command-table editing-table) () - "Transpose current line and previous line, leaving point at the end of them. -If point is in the first line, transpose the first two lines. -If point is in the last line of the buffer and there is no -final #\Newline, add one." - (transpose-lines (point (current-window)))) - -(set-key 'com-transpose-lines - 'editing-table - '((#\x :control) (#\t :control))) - -(define-command (com-previous-line :name t :command-table movement-table) - ((numarg 'integer :prompt "How many lines?")) - "Move point to the previous line. -With a numeric argument, move point up (down, if negative) that many lines. -Successive line movement commands seek to respect the 'goal column'." - (let* ((window (current-window)) - (point (point window))) - (unless (or (eq (previous-command window) 'com-previous-line) - (eq (previous-command window) 'com-next-line)) - (setf (slot-value window 'goal-column) (column-number point))) - (if (plusp numarg) - (previous-line point (slot-value window 'goal-column) numarg) - (next-line point (slot-value window 'goal-column) (- numarg))))) - -(set-key `(com-previous-line ,*numeric-argument-marker*) - 'movement-table - '((#\p :control))) - -(set-key `(com-previous-line ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :up #-mcclim :up-arrow))) - -(define-command (com-next-line :name t :command-table movement-table) - ((numarg 'integer :prompt "How many lines?")) - "Move point to the next line. -With a numeric argument, move point down (up, if negative) that many lines. -Successive line movement commands seek to respect the 'goal column'." - (let* ((window (current-window)) - (point (point window))) - (unless (or (eq (previous-command window) 'com-previous-line) - (eq (previous-command window) 'com-next-line)) - (setf (slot-value window 'goal-column) (column-number point))) - (if (plusp numarg) - (next-line point (slot-value window 'goal-column) numarg) - (previous-line point (slot-value window 'goal-column) (- numarg))))) - -(set-key `(com-next-line ,*numeric-argument-marker*) - 'movement-table - '((#\n :control))) - -(set-key `(com-next-line ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :down #-mcclim :down-arrow))) - (define-command (com-open-line :name t :command-table editing-table) ((numarg 'integer :prompt "How many lines?")) "Insert a #\Newline and leave point before it. @@ -402,7 +168,7 @@ do (forward-object mark))) (t (cond ((end-of-buffer-p mark) nil) - ((end-of-line-p mark)(forward-object mark)) + ((end-of-line-p mark) (forward-object mark)) (t (end-of-line mark))))) (unless (mark= mark start) (if concatenate-p @@ -431,122 +197,64 @@ 'deletion-table '((#\k :control))) -(define-command (com-forward-word :name t :command-table movement-table) - ((count 'integer :prompt "Number of words")) - "Move point to the next word end. -With a numeric argument, move point forward (backward, if negative) -that many words." - (if (plusp count) - (forward-word (point (current-window)) count) - (backward-word (point (current-window)) (- count)))) - -(set-key `(com-forward-word ,*numeric-argument-marker*) - 'movement-table - '((#\f :meta))) - -(set-key `(com-forward-word ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :right #-mcclim :right-arrow :control))) - -(define-command (com-backward-word :name t :command-table movement-table) - ((count 'integer :prompt "Number of words")) - "Move point to the previous word beginning. -With a numeric argument, move point backward (forward, if negative) -that many words." - (backward-word (point (current-window)) count)) - -(set-key `(com-backward-word ,*numeric-argument-marker*) - 'movement-table - '((#\b :meta))) - -(set-key `(com-backward-word ,*numeric-argument-marker*) - 'movement-table - '((#+mcclim :left #-mcclim :left-arrow :control))) - -(define-command (com-delete-word :name t :command-table deletion-table) - ((count 'integer :prompt "Number of words")) - "Delete from point until the next word end. -With a positive numeric argument, delete that many words forward." - (delete-word (point (current-window)) count)) - -(defun kill-word (mark &optional (count 1) (concatenate-p nil)) - (let ((start (offset mark))) - (if (plusp count) - (loop repeat count - until (end-of-buffer-p mark) - do (forward-word mark)) - (loop repeat (- count) - until (beginning-of-buffer-p mark) - do (backward-word mark))) - (unless (mark= mark start) - (if concatenate-p - (if (plusp count) - (kill-ring-concatenating-push *kill-ring* - (region-to-sequence start mark)) - (kill-ring-reverse-concatenating-push *kill-ring* - (region-to-sequence start mark))) - (kill-ring-standard-push *kill-ring* - (region-to-sequence start mark))) - (delete-region start mark)))) - -(define-command (com-kill-word :name t :command-table deletion-table) - ((count 'integer :prompt "Number of words")) - "Kill from point until the next word end. -With a numeric argument, kill forward (backward, if negative) -that many words. - -Successive kills append to the kill ring." - (let* ((pane (current-window)) - (point (point pane)) - (concatenate-p (eq (previous-command pane) 'com-kill-word))) - (kill-word point count concatenate-p))) - -(set-key `(com-kill-word ,*numeric-argument-marker*) - 'deletion-table - '((#\d :meta))) - -(define-command (com-backward-kill-word :name t :command-table deletion-table) - ((count 'integer :prompt "Number of words")) - "Kill from point until the previous word beginning. -With a numeric argument, kill backward (forward, if negative) -that many words. - -Successive kills append to the kill ring." - (let* ((pane (current-window)) - (point (point pane)) - (concatenate-p (eq (previous-command pane) 'com-backward-kill-word))) - (kill-word point (- count) concatenate-p))) - -(set-key `(com-backward-kill-word ,*numeric-argument-marker*) - 'deletion-table - '((#\Backspace :meta))) - -(define-command (com-mark-word :name t :command-table marking-table) - ((count 'integer :prompt "Number of words")) - "Place mark at the next word end. +(defmacro define-mark-unit-command (unit command-table &key + move-point + noun + plural) + "Define a COM-MARK- for `unit' command and put it in + `command-table'." + (labels ((symbol (&rest strings) + (intern (apply #'concat strings))) + (concat (&rest strings) + (apply #'concatenate 'STRING (mapcar #'string strings)))) + (let ((forward (symbol "FORWARD-" unit)) + (backward (symbol "BACKWARD-" unit)) + (noun (or noun (string-downcase unit))) + (plural (or plural (concat (string-downcase unit) "s")))) + `(define-command (,(symbol "COM-MARK-" unit) + :name t + :command-table ,command-table) + ((count 'integer :prompt ,(concat "Number of " plural))) + ,(if (not (null move-point)) + (concat "Place point and mark around the current " noun ". +Put point at the beginning of the current " noun ", and mark at the end. +With a positive numeric argument, put mark that many " plural " forward. +With a negative numeric argument, put point at the end of the current +" noun " and mark that many " plural " backward. +Successive invocations extend the selection.") [700 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/12 10:48:29 1.86 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/12 19:10:58 1.87 @@ -246,7 +246,7 @@ (macrolet ((fo () `(forward-object scan))) (loop when (end-of-buffer-p scan) do (return nil) - until (not (whitespacep (object-after scan))) + until (not (whitespacep syntax (object-after scan))) do (fo) finally (return t)))) @@ -434,7 +434,7 @@ (defmethod skip-inter ((syntax lisp-syntax) (state lexer-line-comment-state) scan) (macrolet ((fo () `(forward-object scan))) (loop until (or (end-of-line-p scan) - (not (whitespacep (object-after scan)))) + (not (whitespacep syntax (object-after scan)))) do (fo) finally (return t)))) @@ -520,7 +520,7 @@ (fo) (go start)) (if (evenp bars-seen) - (unless (whitespacep (object-after scan)) + (unless (whitespacep syntax (object-after scan)) (fo) (go start)) (when (constituentp (object-after scan)) @@ -1823,47 +1823,57 @@ (when (not (null list-child)) (funcall fn list-child))))) -(defmethod backward-expression (mark (syntax lisp-syntax)) +(defmethod backward-one-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) (if potential-form (setf (offset mark) (start-offset potential-form)) (error 'no-expression)))) -(defmethod forward-expression (mark (syntax lisp-syntax)) +(defmethod forward-one-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-after syntax (offset mark)) (form-around syntax (offset mark))))) (if potential-form (setf (offset mark) (end-offset potential-form)) (error 'no-expression)))) -(defmethod forward-list (mark (syntax lisp-syntax)) +(defgeneric forward-one-list (mark syntax) + (:documentation + "Move `mark' forward by one list. +Return T if successful, or NIL if the buffer limit was reached.")) + +(defmethod forward-one-list (mark (syntax lisp-syntax)) (loop for start = (offset mark) - then (end-offset potential-form) - for potential-form = (or (form-after syntax start) - (form-around syntax start)) - until (or (null potential-form) - (and (= start - (end-offset potential-form)) - (null (form-after syntax start)))) - when (typep potential-form 'list-form) - do (setf (offset mark) (end-offset potential-form)) - (return) - finally (error 'no-expression))) + then (end-offset potential-form) + for potential-form = (or (form-after syntax start) + (form-around syntax start)) + until (or (null potential-form) + (and (= start + (end-offset potential-form)) + (null (form-after syntax start)))) + when (typep potential-form 'list-form) + do (setf (offset mark) (end-offset potential-form)) + (return t))) + +(defgeneric backward-one-list (mark syntax) + (:documentation + "Move `mark' backward by one list. Return T if successful, or +NIL if the buffer limit was reached.")) -(defmethod backward-list (mark (syntax lisp-syntax)) +(defmethod backward-one-list (mark (syntax lisp-syntax)) (loop for start = (offset mark) - then (start-offset potential-form) - for potential-form = (or (form-before syntax start) - (form-around syntax start)) - until (or (null potential-form) - (and (= start - (start-offset potential-form)) - (null (form-before syntax start)))) - when (typep potential-form 'list-form) - do (setf (offset mark) (start-offset potential-form)) - (return) - finally (error 'no-expression))) + then (start-offset potential-form) + for potential-form = (or (form-before syntax start) + (form-around syntax start)) + until (or (null potential-form) + (and (= start + (start-offset potential-form)) + (null (form-before syntax start)))) + when (typep potential-form 'list-form) + do (setf (offset mark) (start-offset potential-form)) + (return t))) + +(climacs-motion:define-motion-fns list) (defun down-list-by-fn (mark syntax fn) (let* ((offset (offset mark)) @@ -1876,31 +1886,30 @@ fn offset))))) (when new-offset - (setf (offset mark) (1+ new-offset)))))) + (progn (setf (offset mark) (1+ new-offset)) t))))) -(defmethod down-list (mark (syntax lisp-syntax)) +(defmethod forward-one-down (mark (syntax lisp-syntax)) (down-list-by-fn mark syntax #'start-offset)) -(defmethod backward-down-list (mark (syntax lisp-syntax)) +(defmethod backward-one-down (mark (syntax lisp-syntax)) (down-list-by-fn mark syntax #'end-offset) - (backward-object mark)) + (backward-object mark syntax)) (defun up-list-by-fn (mark syntax fn) (let ((form (or (form-before syntax (offset mark)) (form-after syntax (offset mark)) (form-around syntax (offset mark))))) - (if form + (when form (let ((parent (parent form))) (when (not (null parent)) (let ((new-offset (find-list-parent-offset parent fn))) (when new-offset - (setf (offset mark) new-offset))))) - (error 'no-expression)))) + (setf (offset mark) new-offset)))))))) -(defmethod backward-up-list (mark (syntax lisp-syntax)) +(defmethod backward-one-up (mark (syntax lisp-syntax)) (up-list-by-fn mark syntax #'start-offset)) -(defmethod up-list (mark (syntax lisp-syntax)) +(defmethod forward-one-up (mark (syntax lisp-syntax)) (up-list-by-fn mark syntax #'end-offset)) (defmethod eval-defun (mark (syntax lisp-syntax)) @@ -1911,7 +1920,7 @@ do (return (eval (read-from-string (token-string syntax form))))))) -(defmethod beginning-of-definition (mark (syntax lisp-syntax)) +(defmethod backward-one-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) with last-toplevel-list = nil @@ -1925,15 +1934,18 @@ when (typep form 'form) do (setf last-toplevel-list form) finally (when last-toplevel-list form - (setf (offset mark) (start-offset last-toplevel-list)))))) + (setf (offset mark) + (start-offset last-toplevel-list)) + (return t))))) -(defmethod end-of-definition (mark (syntax lisp-syntax)) +(defmethod forward-one-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax (loop for form in (children stack-top) when (and (typep form 'form) (mark< mark (end-offset form))) do (setf (offset mark) (end-offset form)) - (loop-finish)))) + (loop-finish) + finally (return t)))) (defun in-type-p-in-children (children offset type) (loop for child in children --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/06/05 21:01:51 1.5 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/06/12 19:10:58 1.6 @@ -30,16 +30,26 @@ (in-package :climacs-lisp-syntax) +;; Movement commands. +(climacs-motion-commands:define-motion-commands expression lisp-table) +(climacs-motion-commands:define-motion-commands definition lisp-table) +(climacs-motion-commands:define-motion-commands up lisp-table + :noun "nesting level up" + :plural "levels") +(climacs-motion-commands:define-motion-commands down lisp-table + :noun "nesting level down" + :plural "levels") +(climacs-motion-commands:define-motion-commands list lisp-table) + +(climacs-editing-commands:define-editing-commands expression lisp-table) +(climacs-editing-commands:define-deletion-commands expression lisp-table) + (define-command (com-eval-defun :name t :command-table lisp-table) () (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) (eval-defun point syntax))) -(esa:set-key 'com-eval-defun - 'lisp-table - '((#\x :control :meta))) - (define-command (com-package :name t :command-table lisp-table) () (let* ((pane (current-window)) (syntax (syntax (buffer pane))) @@ -62,35 +72,74 @@ (when (typep token 'string-form) (with-accessors ((offset1 start-offset) (offset2 end-offset)) token - (fill-region (make-instance 'standard-right-sticky-mark - :buffer implementation - :offset offset1) - (make-instance 'standard-right-sticky-mark - :buffer implementation - :offset offset2) - #'(lambda (mark) - (syntax-line-indentation mark tab-width syntax)) - fill-column - tab-width - t))))) - -(esa:set-key 'com-fill-paragraph - 'lisp-table - '((#\q :meta))) + (climacs-editing:fill-region (make-instance 'standard-right-sticky-mark + :buffer implementation + :offset offset1) + (make-instance 'standard-right-sticky-mark + :buffer implementation + :offset offset2) + #'(lambda (mark) + (syntax-line-indentation mark tab-width syntax)) + fill-column + tab-width + syntax + t))))) (define-command (com-indent-expression :name t :command-table lisp-table) ((count 'integer :prompt "Number of expressions")) (let* ((pane (current-window)) (point (point pane)) (mark (clone-mark point)) - (syntax (syntax (buffer pane))) - (view (stream-default-view pane)) - (tab-space-count (tab-space-count view))) + (syntax (syntax (buffer pane)))) (if (plusp count) (loop repeat count do (forward-expression mark syntax)) (loop repeat (- count) do (backward-expression mark syntax))) - (indent-region pane (clone-mark point) mark))) + (climacs-editing:indent-region pane (clone-mark point) mark))) + +(esa:set-key 'com-fill-paragraph + 'lisp-table + '((#\q :meta))) + +(esa:set-key 'com-eval-defun + 'lisp-table + '((#\x :control :meta))) (esa:set-key `(com-indent-expression ,*numeric-argument-marker*) 'lisp-table - '((#\q :meta :control))) \ No newline at end of file + '((#\q :meta :control))) + +(esa:set-key `(com-backward-up ,*numeric-argument-marker*) + 'lisp-table + '((#\u :control :meta))) + +(esa:set-key `(com-forward-down ,*numeric-argument-marker*) + 'lisp-table + '((#\d :control :meta))) + +(esa:set-key `(com-backward-expression ,*numeric-argument-marker*) + 'lisp-table + '((#\b :control :meta))) + +(esa:set-key `(com-forward-expression ,*numeric-argument-marker*) + 'lisp-table + '((#\f :control :meta))) + +(esa:set-key `(com-backward-definition ,*numeric-argument-marker*) + 'lisp-table + '((#\a :control :meta))) + +(esa:set-key `(com-forward-definition ,*numeric-argument-marker*) + 'lisp-table + '((#\e :control :meta))) + +(esa:set-key `(com-forward-list ,*numeric-argument-marker*) + 'lisp-table + '((#\n :control :meta))) + +(esa:set-key `(com-backward-list ,*numeric-argument-marker*) + 'lisp-table + '((#\p :control :meta))) + +(esa:set-key `(com-kill-expression ,*numeric-argument-marker*) + 'lisp-table + '((#\k :control :meta))) \ No newline at end of file --- /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/05/06 19:51:04 1.33 +++ /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/06/12 19:10:58 1.34 @@ -675,7 +675,7 @@ (incf valid-parse)))) (defmethod inter-lexeme-object-p ((lexer html-lexer) object) - (whitespacep object)) + (whitespacep (syntax (buffer lexer)) object)) (defmethod update-syntax (buffer (syntax html-syntax)) (with-slots (lexer valid-parse) syntax --- /project/climacs/cvsroot/climacs/gui.lisp 2006/06/04 16:27:18 1.217 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/06/12 19:10:58 1.218 @@ -311,8 +311,6 @@ (declare (ignore region)) (redisplay-frame-pane *application-frame* pane)) -(defvar *kill-ring* (make-instance 'kill-ring :max-size 7)) - (defmethod execute-frame-command :around ((frame climacs) command) (let ((current-window (car (windows frame)))) (handler-case --- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/05/06 19:51:04 1.3 +++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/06/12 19:10:58 1.4 @@ -192,12 +192,6 @@ ;;; ;;; exploit the parse -(defmethod backward-expression (mark (syntax fundamental-syntax)) - nil) - -(defmethod forward-expression (mark (syntax fundamental-syntax)) - nil) - ;; do this better (defmethod syntax-line-indentation (mark tab-width (syntax fundamental-syntax)) 0) --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/06/01 22:51:40 1.19 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/06/12 19:10:58 1.20 @@ -177,7 +177,7 @@ (let ((scan (beginning-of-buffer (clone-mark (point buffer))))) ;; skip the leading whitespace (loop until (end-of-buffer-p scan) - until (not (whitespacep (object-after scan))) + until (not (whitespacep (syntax buffer) (object-after scan))) do (forward-object scan)) ;; stop looking if we're already 1,000 objects into the buffer (unless (> (offset scan) 1000) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/04/23 12:11:26 1.44 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/06/12 19:10:58 1.45 @@ -44,15 +44,17 @@ (:file "packages" :depends-on ("cl-automaton" "Persistent")) (:file "buffer" :depends-on ("packages")) + (:file "motion" :depends-on ("packages" "buffer" "syntax")) + (:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring")) (:file "persistent-buffer" :pathname #p"Persistent/persistent-buffer.lisp" :depends-on ("packages" "buffer" "Persistent")) - (:file "base" :depends-on ("packages" "buffer" "persistent-buffer")) + (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring")) (:file "io" :depends-on ("packages" "buffer")) (:file "abbrev" :depends-on ("packages" "buffer" "base")) (:file "syntax" :depends-on ("packages" "buffer" "base")) - (:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax")) + (:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax" "motion")) (:file "delegating-buffer" :depends-on ("packages" "buffer")) (:file "kill-ring" :depends-on ("packages")) (:file "undo" :depends-on ("packages")) @@ -72,12 +74,14 @@ "pane")) (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" "gui")) - (:file "lisp-syntax-commands" :depends-on ("lisp-syntax")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands")) (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" "kill-ring" "io" "text-syntax" - "abbrev" )) + "abbrev" "editing" "motion")) ;; (:file "buffer-commands" :depends-on ("gui")) (:file "developer-commands" :depends-on ("gui" "lisp-syntax")) + (:file "motion-commands" :depends-on ("gui")) + (:file "editing-commands" :depends-on ("gui")) (:file "file-commands" :depends-on ("gui")) (:file "misc-commands" :depends-on ("gui")) (:file "search-commands" :depends-on ("gui")) --- /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/05/06 19:51:04 1.18 +++ /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/06/12 19:10:58 1.19 @@ -1006,7 +1006,7 @@ (incf valid-parse)))) (defmethod inter-lexeme-object-p ((lexer cl-lexer) object) - (whitespacep object)) + (whitespacep (syntax (buffer lexer)) object)) (defmethod update-syntax (buffer (syntax cl-syntax)) (with-slots (lexer valid-parse) syntax @@ -1030,7 +1030,8 @@ (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (and (< start end) - (whitespacep (buffer-object buffer start))) + (whitespacep (syntax buffer) + (buffer-object buffer start))) do (ecase (buffer-object buffer start) (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) --- /project/climacs/cvsroot/climacs/buffer.lisp 2006/04/30 15:20:46 1.33 +++ /project/climacs/cvsroot/climacs/buffer.lisp 2006/06/12 19:10:58 1.34 @@ -136,25 +136,17 @@ (:documentation "Move `mark' `count' objects backwards. Returns `mark'.")) -(defmethod backward-object :around (mark &optional count) - (declare (ignore count)) - (call-next-method) - mark) - -(defmethod backward-object ((mark mark-mixin) &optional (count 1)) - (decf (offset mark) count)) - (defgeneric forward-object (mark &optional count) (:documentation "Move `mark' `count' objects forwards. Returns `mark'")) -(defmethod forward-object :around (mark &optional count) - (declare (ignore count)) - (call-next-method) - mark) - (defmethod forward-object ((mark mark-mixin) &optional (count 1)) - (incf (offset mark) count)) + (incf (offset mark) count) + t) + +(defmethod backward-object ((mark mark-mixin) &optional (count 1)) + (decf (offset mark) count) + t) (defclass standard-left-sticky-mark (left-sticky-mark mark-mixin) () (:documentation "A left-sticky-mark subclass suitable for use in a standard-buffer")) @@ -377,7 +369,7 @@ (defmethod beginning-of-line ((mark mark-mixin)) (loop until (beginning-of-line-p mark) - do (decf (offset mark)))) + do (backward-object mark))) (defgeneric end-of-line (mark) (:documentation "Move the mark to the end of the line. The mark will be positioned @@ -432,6 +424,15 @@ (defmethod column-number ((mark mark-mixin)) (buffer-column-number (buffer mark) (offset mark))) +(defgeneric (setf column-number) (number mark) + (:documentation "Set the column number of the mark.")) + +(defmethod (setf column-number) (number mark) + (beginning-of-line mark) + (loop repeat number + until (end-of-line-p mark) + do (incf (offset mark)))) + (defgeneric insert-buffer-object (buffer offset object) (:documentation "Insert the object at the offset in the buffer. Any left-sticky marks that are placed at the offset will remain positioned before the --- /project/climacs/cvsroot/climacs/base.lisp 2006/06/05 21:01:51 1.50 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/06/12 19:10:58 1.51 @@ -63,71 +63,6 @@ (unless (end-of-buffer-p ,mark-sym) (forward-object ,mark-sym))))))) -(defmethod previous-line (mark &optional column (count 1)) - "Move a mark up COUNT lines conserving horizontal position." - (unless column - (setf column (column-number mark))) - (loop repeat count - do (beginning-of-line mark) - until (beginning-of-buffer-p mark) - do (backward-object mark)) - (end-of-line mark) - (when (> (column-number mark) column) - (beginning-of-line mark) - (incf (offset mark) column))) - -(defmethod previous-line ((mark p-line-mark-mixin) &optional column (count 1)) - "Move a mark up COUNT lines conserving horizontal position." - (unless column - (setf column (column-number mark))) - (let* ((line (line-number mark)) - (goto-line (max 0 (- line count)))) - (setf (offset mark) - (+ column (buffer-line-offset (buffer mark) goto-line))))) - -(defmethod next-line (mark &optional column (count 1)) - "Move a mark down COUNT lines conserving horizontal position." - (unless column - (setf column (column-number mark))) - (loop repeat count - do (end-of-line mark) - until (end-of-buffer-p mark) - do (forward-object mark)) - (end-of-line mark) - (when (> (column-number mark) column) - (beginning-of-line mark) - (incf (offset mark) column))) - -(defmethod next-line ((mark p-line-mark-mixin) &optional column (count 1)) - "Move a mark down COUNT lines conserving horizontal position." - (unless column - (setf column (column-number mark))) - (let* ((line (line-number mark)) - (goto-line (min (number-of-lines (buffer mark)) - (+ line count)))) - (setf (offset mark) - (+ column (buffer-line-offset (buffer mark) goto-line))))) - -(defmethod open-line ((mark left-sticky-mark) &optional (count 1)) - "Create a new line in a buffer after the mark." - (loop repeat count - do (insert-object mark #\Newline))) - -(defmethod open-line ((mark right-sticky-mark) &optional (count 1)) - "Create a new line in a buffer after the mark." - (loop repeat count - do (insert-object mark #\Newline) - (decf (offset mark)))) - -(defun kill-line (mark) - "Remove a line from a buffer." - (if (end-of-line-p mark) - (unless (end-of-buffer-p mark) - (delete-range mark)) - (let ((offset (offset mark))) - (end-of-line mark) - (delete-region offset mark)))) - (defun empty-line-p (mark) "Check whether the mark is in an empty line." (and (beginning-of-line-p mark) (end-of-line-p mark))) @@ -204,60 +139,6 @@ #\: #\< #\= #\> #\? #\@ #\^ #\~ #\_ #\{ #\} #\[ #\] ))))) -(defun whitespacep (obj) - "A predicate to ensure that an object is a whitespace character." - (and (characterp obj) - (member obj '(#\Space #\Tab #\Newline #\Page #\Return)))) - -(defun forward-to-word-boundary (mark) - "Move the mark forward to the beginning of the next word." - (loop until (end-of-buffer-p mark) - until (constituentp (object-after mark)) - do (incf (offset mark)))) - -(defun backward-to-word-boundary (mark) - "Move the mark backward to the end of the previous word." - (loop until (beginning-of-buffer-p mark) - until (constituentp (object-before mark)) - do (decf (offset mark)))) - -(defun forward-word (mark &optional (count 1)) - "Forward the mark to the next word." - (loop repeat count - do (forward-to-word-boundary mark) - (loop until (end-of-buffer-p mark) - while (constituentp (object-after mark)) - do (incf (offset mark))))) - -(defun backward-word (mark &optional (count 1)) - "Shuttle the mark to the start of the previous word." - (loop repeat count - do (backward-to-word-boundary mark) - (loop until (beginning-of-buffer-p mark) - while (constituentp (object-before mark)) - do (decf (offset mark))))) - -(defun delete-word (mark &optional (count 1)) - "Delete until the end of the word" - (let ((mark2 (clone-mark mark))) - (forward-word mark2 count) - (delete-region mark mark2))) - -(defun backward-delete-word (mark &optional (count 1)) - "Delete until the beginning of the word" - (let ((mark2 (clone-mark mark))) - (backward-word mark2 count) - (delete-region mark mark2))) - -(defun previous-word (mark) - "Return a freshly allocated sequence, that is word before the mark" - (region-to-sequence - (loop for i downfrom (offset mark) - while (and (plusp i) - (constituentp (buffer-object (buffer mark) (1- i)))) - finally (return i)) - mark)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case @@ -285,325 +166,6 @@ (possibly-capitalized :capitalized) (t nil)))) -;;; I'd rather have update-buffer-range methods spec. on buffer for this, -;;; for performance and history-size reasons --amb -(defun downcase-buffer-region (buffer offset1 offset2) - (do-buffer-region (object offset buffer offset1 offset2) - (when (and (constituentp object) (upper-case-p object)) - (setf object (char-downcase object))))) - -(defgeneric downcase-region (mark1 mark2) - (:documentation "Convert all characters after mark1 and before mark2 to -lowercase. An error is signaled if the two marks are positioned in different -buffers. It is acceptable to pass an offset in place of one of the marks.")) - -(defmethod downcase-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod downcase-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod downcase-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark1) offset1 offset2))) - -(defun downcase-word (mark &optional (n 1)) - "Convert the next N words to lowercase, leaving mark after the last word." - (loop repeat n - do (forward-to-word-boundary mark) - (let ((offset (offset mark))) - (forward-word mark) - (downcase-region offset mark)))) - -(defun upcase-buffer-region (buffer offset1 offset2) - (do-buffer-region (object offset buffer offset1 offset2) - (when (and (constituentp object) (lower-case-p object)) - (setf object (char-upcase object))))) - -(defgeneric upcase-region (mark1 mark2) - (:documentation "Convert all characters after mark1 and before mark2 to -uppercase. An error is signaled if the two marks are positioned in different -buffers. It is acceptable to pass an offset in place of one of the marks.")) - -(defmethod upcase-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod upcase-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod upcase-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark1) offset1 offset2))) - -(defun upcase-word (mark &optional (n 1)) - "Convert the next N words to uppercase, leaving mark after the last word." - (loop repeat n - do (forward-to-word-boundary mark) - (let ((offset (offset mark))) - (forward-word mark) - (upcase-region offset mark)))) - -(defun capitalize-buffer-region (buffer offset1 offset2) - (let ((previous-char-constituent-p nil)) - (do-buffer-region (object offset buffer offset1 offset2) - (when (constituentp object) - (if previous-char-constituent-p - (when (upper-case-p object) - (setf object (char-downcase object))) - (when (lower-case-p object) - (setf object (char-upcase object))))) - (setf previous-char-constituent-p (constituentp object))))) - -(defgeneric capitalize-region (mark1 mark2) - (:documentation "Capitalize all words after mark1 and before mark2. -An error is signaled if the two marks are positioned in different buffers. -It is acceptable to pass an offset in place of one of the marks.")) - -(defmethod capitalize-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod capitalize-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod capitalize-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark1) offset1 offset2))) - -(defun capitalize-word (mark &optional (n 1)) - "Capitalize the next N words, leaving mark after the last word." - (loop repeat n - do (forward-to-word-boundary mark) - (let ((offset (offset mark))) - (forward-word mark) - (capitalize-region offset mark)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Tabify - -(defun tabify-buffer-region (buffer offset1 offset2 tab-width) - (flet ((looking-at-spaces (buffer offset count) - (loop for i from offset - repeat count - unless (char= (buffer-object buffer i) #\Space) - return nil - finally (return t)))) - (loop for offset = offset1 then (1+ offset) - until (>= offset offset2) - do (let* ((column (buffer-display-column - buffer offset tab-width)) - (count (- tab-width (mod column tab-width)))) - (when (looking-at-spaces buffer offset count) - (finish-output) - (delete-buffer-range buffer offset count) - (insert-buffer-object buffer offset #\Tab) - (decf offset2 (1- count))))))) - -(defgeneric tabify-region (mark1 mark2 tab-width) - (:documentation "Replace sequences of tab-width spaces with tabs -in the region delimited by mark1 and mark2.")) - -(defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) - -(defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defun untabify-buffer-region (buffer offset1 offset2 tab-width) - (loop for offset = offset1 then (1+ offset) - until (>= offset offset2) - when (char= (buffer-object buffer offset) #\Tab) - do (let* ((column (buffer-display-column buffer - offset - tab-width)) - (count (- tab-width (mod column tab-width)))) - (delete-buffer-range buffer offset 1) - (loop repeat count - do (insert-buffer-object buffer offset #\Space)) - (incf offset (1- count)) - (incf offset2 (1- count))))) - -(defgeneric untabify-region (mark1 mark2 tab-width) - (:documentation "Replace tabs with tab-width spaces in the region -delimited by mark1 and mark2.")) - -(defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) - -(defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Indentation - -(defgeneric indent-line (mark indentation tab-width) - (:documentation "Indent the line containing mark with indentation -spaces. Use tabs and spaces if tab-width is not nil, otherwise use -spaces only.")) - -(defun indent-line* (mark indentation tab-width left) - (let ((mark2 (clone-mark mark))) - (beginning-of-line mark2) - (loop until (end-of-buffer-p mark2) - as object = (object-after mark2) - while (or (eql object #\Space) (eql object #\Tab)) - do (delete-range mark2 1)) - (loop until (zerop indentation) - do (cond ((and tab-width (>= indentation tab-width)) - (insert-object mark2 #\Tab) - (when left ; spaces must follow tabs - (forward-object mark2)) - (decf indentation tab-width)) - (t - (insert-object mark2 #\Space) - (decf indentation)))))) - -(defmethod indent-line ((mark left-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width t)) - -(defmethod indent-line ((mark right-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width nil)) - -(defun delete-indentation (mark) - (beginning-of-line mark) - (unless (beginning-of-buffer-p mark) - (delete-range mark -1) - (loop until (end-of-buffer-p mark) - while (whitespacep (object-after mark)) - do (delete-range mark 1)) - (loop until (beginning-of-buffer-p mark) - while (whitespacep (object-before mark)) - do (delete-range mark -1)) - (when (and (not (beginning-of-buffer-p mark)) - (constituentp (object-before mark))) - (insert-object mark #\Space)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Auto fill - -(defun fill-line (mark syntax-line-indentation-function fill-column tab-width - &optional (compress-whitespaces t)) - "Breaks the contents of line pointed to by MARK up to MARK into -multiple lines such that none of them is longer than FILL-COLUMN. If -COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the [84 lines skipped] --- /project/climacs/cvsroot/climacs/motion.lisp 2006/06/12 19:10:59 NONE +++ /project/climacs/cvsroot/climacs/motion.lisp 2006/06/12 19:10:59 1.1 [589 lines skipped] --- /project/climacs/cvsroot/climacs/motion-commands.lisp 2006/06/12 19:10:59 NONE +++ /project/climacs/cvsroot/climacs/motion-commands.lisp 2006/06/12 19:10:59 1.1 [803 lines skipped] --- /project/climacs/cvsroot/climacs/editing.lisp 2006/06/12 19:10:59 NONE +++ /project/climacs/cvsroot/climacs/editing.lisp 2006/06/12 19:10:59 1.1 [1427 lines skipped] --- /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/06/12 19:10:59 NONE +++ /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/06/12 19:10:59 1.1 [1676 lines skipped] From thenriksen at common-lisp.net Thu Jun 29 14:23:27 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 29 Jun 2006 10:23:27 -0400 (EDT) Subject: [climacs-cvs] CVS climacs Message-ID: <20060629142327.1F11E68001@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1454 Modified Files: base.lisp Log Message: Added non-syntax-aware version of `whitespacep'. --- /project/climacs/cvsroot/climacs/base.lisp 2006/06/12 19:10:58 1.51 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/06/29 14:23:26 1.52 @@ -139,6 +139,11 @@ #\: #\< #\= #\> #\? #\@ #\^ #\~ #\_ #\{ #\} #\[ #\] ))))) +(defun buffer-whitespacep (obj) + "Return T if `obj' is a basic whitespace character. This + function does not respect the current syntax." + (member obj '(#\Space #\Tab #\Newline #\Page #\Return))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case @@ -317,7 +322,7 @@ (loop for i downfrom (- offset wlen) to 0 for j = (+ i wlen) - when (and (or (zerop i) (whitespacep t (buffer-object buffer (1- i)))) + when (and (or (zerop i) (buffer-whitespacep (buffer-object buffer (1- i)))) (buffer-looking-at buffer i word :test test) (not (and (< (+ i wlen) blen) (constituentp (buffer-object buffer (+ i wlen)))))) @@ -337,7 +342,7 @@ (loop for i upfrom offset to (- blen (max wlen 1)) for j = (+ i wlen) - when (and (or (zerop i) (whitespacep (buffer-object buffer (1- i)))) + when (and (or (zerop i) (buffer-whitespacep (buffer-object buffer (1- i)))) (buffer-looking-at buffer i word :test test) (not (and (< j blen) (constituentp (buffer-object buffer j)))))