climacs-cvs December 2004

climacs-cvs@common-lisp.net

4 participants
42 discussions

[climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp climacs/syntax.lisp
by rstrandh＠common-lisp.net 31 Dec '04

31 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv22282 Modified Files: gui.lisp packages.lisp syntax.lisp Log Message: Simplified the redisplay routine. Introduced a cache of lines in the form of a flexichain. The ultra-fast redisplay is not yet in place, because I thought the bottle neck was in Climacs, whereas it is in McCLIM. I know how to fix that, though, by using :cache-test #'eq for cached lines. The only problem with that is that the line has to be traversed (despite being cached) in order that we can compute the position of the cursor. This might involve either invalidating the line with the cursor on it, so that it will be rescanned, or else rescanning it anyway, despite it being cached. Date: Fri Dec 31 14:33:07 2004 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.36 climacs/gui.lisp:1.37 --- climacs/gui.lisp:1.36 Fri Dec 31 07:39:21 2004 +++ climacs/gui.lisp Fri Dec 31 14:33:06 2004 @@ -354,10 +354,10 @@ (setf (filename buffer) filename (name buffer) (pathname-filename filename) (needs-saving buffer) nil) + (beginning-of-buffer point) ;; this one is needed so that the buffer modification protocol ;; resets the low and high marks after redisplay - (redisplay-frame-panes *application-frame*) - (beginning-of-buffer point)))) + (redisplay-frame-panes *application-frame*)))) (define-named-command com-save-buffer () (let* ((buffer (buffer (win *application-frame*))) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.15 climacs/packages.lisp:1.16 --- climacs/packages.lisp:1.15 Wed Dec 29 17:03:21 2004 +++ climacs/packages.lisp Fri Dec 31 14:33:06 2004 @@ -56,7 +56,7 @@ #:expand-abbrev #:abbrev-mixin #:possibly-expand-abbrev)) (defpackage :climacs-syntax - (:use :clim-lisp :clim :climacs-buffer :climacs-base) + (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:basic-syntax #:texinfo-syntax #:redisplay-pane #:redisplay-with-syntax #:full-redisplay #:url)) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.12 climacs/syntax.lisp:1.13 --- climacs/syntax.lisp:1.12 Wed Dec 29 12:38:34 2004 +++ climacs/syntax.lisp Fri Dec 31 14:33:06 2004 @@ -38,11 +38,11 @@ ((top :reader top) (bot :reader bot) (scan :reader scan) - (saved-offset :initform nil :accessor saved-offset) - (cursor-x :initform nil) - (cursor-y :initform nil) + (cursor-x :initform 2) + (cursor-y :initform 2) (space-width :initform nil) - (tab-width :initform nil))) + (tab-width :initform nil) + (cache :initform nil))) (defmethod initialize-instance :after ((syntax basic-syntax) &rest args &key pane) (declare (ignore args)) @@ -66,72 +66,97 @@ 'string) :stream pane))) -;;(defmacro maybe-updating-output (stuff &body body) -;; `(progn ,@body)) - - (defmacro maybe-updating-output (stuff &body body) - `(updating-output ,stuff ,@body)) - -(defmethod display-line (pane (syntax basic-syntax)) - (with-slots (saved-offset bot scan cursor-x cursor-y space-width tab-width) syntax - (flet ((compute-contents () - (unless (null saved-offset) - (prog1 (coerce (buffer-sequence (buffer pane) saved-offset scan) 'string) - (setf saved-offset nil))))) - (macrolet ((output-word (&body body) - `(let ((contents (compute-contents))) - (if (null contents) - ,(if body - `(maybe-updating-output (pane :unique-id (incf id)) - ,@body) - `(progn)) - (progn - (maybe-updating-output (pane :unique-id (incf id) - :cache-value contents - :cache-test #'string=) - (present-contents contents pane syntax)) - ,(when body - `(maybe-updating-output (pane :unique-id (incf id)) - ,@body))))))) - (loop with id = 0 +(defmethod display-line (pane (syntax basic-syntax) line) + (let ((saved-index nil) + (id 0)) + (flet ((output-word (index) + (unless (null saved-index) + (let ((contents (coerce (subseq line saved-index index) 'string))) + (updating-output (pane :unique-id (incf id) + :cache-value contents + :cache-test #'string=) + (present-contents contents pane syntax))) + (setf saved-index nil)))) + (with-slots (bot scan cursor-x cursor-y space-width tab-width) syntax + (loop for index from 0 + for obj across line when (mark= scan (point pane)) do (multiple-value-bind (x y) (stream-cursor-position pane) - (setf cursor-x (+ x (if (null saved-offset) + (setf cursor-x (+ x (if (null saved-index) 0 - (* space-width (- scan saved-offset)))) + (* space-width (- index saved-index)))) cursor-y y)) - when (mark= scan bot) - do (output-word) - (return) - until (eql (buffer-object (buffer pane) scan) #\Newline) - do (let ((obj (buffer-object (buffer pane) scan))) - (cond ((eql obj #\Space) - (output-word) - (stream-increment-cursor-position pane space-width 0)) - ((eql obj #\Tab) - (output-word) - (let ((x (stream-cursor-position pane))) - (stream-increment-cursor-position - pane (- tab-width (mod x tab-width)) 0))) - ((constituentp obj) - (when (null saved-offset) - (setf saved-offset scan))) - (t - (output-word (princ obj pane))))) + do (cond ((eql obj #\Space) + (output-word index) + (stream-increment-cursor-position pane space-width 0)) + ((eql obj #\Tab) + (output-word index) + (let ((x (stream-cursor-position pane))) + (stream-increment-cursor-position + pane (- tab-width (mod x tab-width)) 0))) + ((constituentp obj) + (when (null saved-index) + (setf saved-index index))) + ((characterp obj) + (output-word index) + (updating-output (pane :unique-id (incf id) + :cache-value obj) + (present obj))) + (t + (output-word index) + (updating-output (pane :unique-id (incf id) + :cache-value obj + :cache-test #'eq) + (present obj)))) (incf scan) - finally (output-word (terpri pane)) + finally (output-word index) + (when (mark= scan (point pane)) + (multiple-value-bind (x y) (stream-cursor-position pane) + (setf cursor-x x + cursor-y y))) + (terpri pane) (incf scan)))))) -(defun round-up (x) - (cond ((zerop x) 2) - ((evenp x) x) - (t (1+ x)))) +(defmethod compute-cache (pane (syntax basic-syntax)) + (with-slots (top bot cache) syntax + (let* ((buffer (buffer pane)) + (high-mark (high-mark buffer)) + (low-mark (low-mark buffer))) + (when (or (mark< low-mark top) (mark> high-mark bot)) + (setf cache nil)) + (if (null cache) + (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot))) + (mark1 (clone-mark top)) + (mark2 (clone-mark top))) + (setf cache (make-instance 'standard-flexichain)) + (loop for line from 0 below nb-lines-on-display + do (beginning-of-line mark1) + (end-of-line mark2) + (insert* cache line (region-to-sequence mark1 mark2)) + unless (end-of-buffer-p mark2) + do (setf (offset mark1) (1+ (offset mark2)) + (offset mark2) (offset mark1)))) + (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot))) + (mark1 (clone-mark low-mark)) + (mark2 (clone-mark low-mark)) + (size1 (number-of-lines-in-region top low-mark)) + (size2 (number-of-lines-in-region high-mark bot))) + (loop repeat (- (nb-elements cache) size1 size2) + do (delete* cache size1)) + (loop for line from size1 + repeat (- nb-lines-on-display (nb-elements cache)) + do (beginning-of-line mark1) + (end-of-line mark2) + (insert* cache line (region-to-sequence mark1 mark2)) + unless (end-of-buffer-p mark2) + do (setf (offset mark1) (1+ (offset mark2)) + (offset mark2) (offset mark1)))))))) -(defmethod redisplay-with-syntax (pane (syntax basic-syntax)) +(defun position-window (pane syntax) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) (height (text-style-height style medium))) - (with-slots (top bot scan cursor-x cursor-y) syntax + (with-slots (top bot cache) syntax (beginning-of-line top) (end-of-line bot) (multiple-value-bind (x y w h) (bounding-rectangle* pane) @@ -141,13 +166,17 @@ ;; adjust the region on display to fit the pane (loop repeat (- nb-lines-on-display nb-lines-in-pane) do (beginning-of-line bot) - (decf (offset bot))) + (decf (offset bot)) + (unless (null cache) + (pop-end cache))) (loop until (end-of-buffer-p bot) repeat (- nb-lines-in-pane nb-lines-on-display) do (incf (offset bot)) - (end-of-line bot)) + (end-of-line bot) + (setf cache nil)) ;; move region on display if point is outside the current region (when (or (mark< (point pane) top) (mark> (point pane) bot)) + (setf cache nil) (setf (offset top) (offset (point pane))) (loop do (beginning-of-line top) repeat (floor nb-lines-in-pane 2) @@ -159,24 +188,38 @@ repeat (1- nb-lines-in-pane) until (end-of-buffer-p bot) do (incf (offset bot)) - (end-of-line bot))) - (setf scan (offset top)) - (loop for id from 0 - until (mark= scan bot) - do (maybe-updating-output (pane :unique-id id) - (display-line pane syntax))) - (when (mark= scan (point pane)) - (multiple-value-bind (x y) (stream-cursor-position pane) - (setf cursor-x x - cursor-y y))) - (maybe-updating-output (pane :all-new t :fixed-position t) - (draw-line* pane - ;; cursors with odd x-positions were invisible - ;; so we strip off the low bit to make them even. - - (round-up cursor-x) (- cursor-y (* 0.2 height)) - (round-up cursor-x) (+ cursor-y (* 0.8 height)) - :ink +red+))))))) + (end-of-line bot)))))))) + + +;;; this one should not be necessary. +(defun round-up (x) + (cond ((zerop x) 2) + ((evenp x) x) + (t (1+ x)))) + +(defmethod redisplay-with-syntax (pane (syntax basic-syntax)) + (let* ((medium (sheet-medium pane)) + (style (medium-text-style medium)) + (height (text-style-height style medium))) + (with-slots (top bot scan cache cursor-x cursor-y) syntax + (position-window pane syntax) + (compute-cache pane syntax) + (setf scan (offset top)) + (loop for id from 0 below (nb-elements cache) + do (updating-output (pane :unique-id id) + (display-line pane syntax (element* cache id)))) + (when (mark= scan (point pane)) + (multiple-value-bind (x y) (stream-cursor-position pane) + (setf cursor-x x + cursor-y y))) + (updating-output (pane :unique-id -1) + (draw-line* pane + ;; cursors with odd or zero x-positions were invisible + ;; so we round them up to even. + ;; We don't know why, though. + (round-up cursor-x) (- cursor-y (* 0.2 height)) + (round-up cursor-x) (+ cursor-y (* 0.8 height)) + :ink +red+))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[climacs-cvs] CVS update: climacs/abbrev.lisp climacs/gui.lisp
by rstrandh＠common-lisp.net 31 Dec '04

31 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv2151 Modified Files: abbrev.lisp gui.lisp Log Message: Prelimary code for reading numeric argument. However, I suspect a bug in McCLIM with respect to unread-gesture, so waiting for a fix for that before actually using the code. Date: Fri Dec 31 07:39:22 2004 Author: rstrandh Index: climacs/abbrev.lisp diff -u climacs/abbrev.lisp:1.4 climacs/abbrev.lisp:1.5 --- climacs/abbrev.lisp:1.4 Thu Dec 23 09:00:33 2004 +++ climacs/abbrev.lisp Fri Dec 31 07:39:21 2004 @@ -52,10 +52,7 @@ (defun string-upper-case-p (string) "A predicate testing if each character of a string is uppercase." - (loop for c across string - unless (upper-case-p c) - do (return nil) - finally (return t))) + (every #'upper-case-p string)) (defmethod expand-abbrev (word (expander dictionary-abbrev-expander)) "Expands an abbrevated word by attempting to assocate it with a member of Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.35 climacs/gui.lisp:1.36 --- climacs/gui.lisp:1.35 Thu Dec 30 11:42:45 2004 +++ climacs/gui.lisp Fri Dec 31 07:39:21 2004 @@ -117,6 +117,43 @@ (defvar *kill-ring* (initialize-kill-ring 7)) (defparameter *current-gesture* nil) +(defun meta-digit (gesture) + (position gesture + '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta) + (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) + :test #'event-matches-gesture-name-p)) + +(defun read-numeric-argument (&key (stream *standard-input*)) + (let ((gesture (read-gesture :stream stream))) + (cond ((event-matches-gesture-name-p gesture '(#\u :control)) + (let ((numarg 4)) + (loop for gesture = (read-gesture :stream stream) + while (event-matches-gesture-name-p gesture '(#\u :control)) + do (setf numarg (* 4 numarg)) + finally (unread-gesture gesture :stream stream)) + (let ((gesture (read-gesture :stream stream))) + (cond ((and (characterp gesture) + (digit-char-p gesture 10)) + (setf numarg (- (char-code gesture) (char-code #\0))) + (loop for gesture = (read-gesture :stream stream) + while (and (characterp gesture) + (digit-char-p gesture 10)) + do (setf gesture (+ (* 10 numarg) + (- (char-code gesture) (char-code #\0)))) + finally (unread-gesture gesture :stream stream) + (return (values numarg t)))) + (t + (values numarg t)))))) + ((meta-digit gesture) + (let ((numarg (meta-digit gesture))) + (loop for gesture = (read-gesture :stream stream) + while (meta-digit gesture) + do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) + finally (unread-gesture gesture :stream stream) + (return (values numarg t))))) + (t (unread-gesture gesture :stream stream) + (values 1 nil))))) + (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -128,6 +165,7 @@ (*abort-gestures* nil)) (redisplay-frame-panes frame :force-p t) (loop with gestures = '() + with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*) do (setf *current-gesture* (read-gesture :stream *standard-input*)) (when (or (characterp *current-gesture*) (and (typep *current-gesture* 'keyboard-event) @@ -145,12 +183,16 @@ (cond ((not item) (beep) (setf gestures '())) ((eq (command-menu-item-type item) :command) - (handler-case - (funcall (command-menu-item-value item)) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) - (setf gestures '())) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (handler-case + (execute-frame-command frame command) + (error (condition) + (beep) + (format *error-output* "~a~%" condition))) + (setf gestures '()))) (t nil)))) (let ((buffer (buffer (win frame)))) (when (modified-p buffer)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by ejohnson＠common-lisp.net 30 Dec '04

30 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv6045 Modified Files: gui.lisp Log Message: Wrapped an (EVAL-WHEN (:compile-toplevel) ...) around COMPLETABLE-PATHNAME to rid us of an asdf style warning Date: Thu Dec 30 11:42:46 2004 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.34 climacs/gui.lisp:1.35 --- climacs/gui.lisp:1.34 Thu Dec 30 06:37:34 2004 +++ climacs/gui.lisp Thu Dec 30 11:42:45 2004 @@ -220,8 +220,9 @@ (let ((item (accept 'command :prompt "Extended Command"))) (execute-frame-command *application-frame* item))) -(define-presentation-type completable-pathname () - :inherit-from 'pathname) +(eval-when (:compile-toplevel) + (define-presentation-type completable-pathname () + :inherit-from 'pathname)) (defun filename-completer (so-far mode) (flet ((remove-trail (s)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by abridgewater＠common-lisp.net 30 Dec '04

30 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv23923 Modified Files: gui.lisp Log Message: Added DEFINE-NAMED-COMMAND and converted most commands to use it. Date: Thu Dec 30 06:37:34 2004 Author: abridgewater Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.33 climacs/gui.lisp:1.34 --- climacs/gui.lisp:1.33 Thu Dec 30 06:28:21 2004 +++ climacs/gui.lisp Thu Dec 30 06:37:34 2004 @@ -157,7 +157,10 @@ (setf (needs-saving buffer) t))) (redisplay-frame-panes frame)))) -(define-climacs-command (com-quit :name t) () +(defmacro define-named-command (command-name args &body body) + `(define-climacs-command ,(if (listp command-name) `(,@command-name :name t) `(,command-name :name t)) ,args ,@body)) + +(define-named-command (com-quit) () (frame-exit *application-frame*)) (define-command com-self-insert () @@ -165,49 +168,49 @@ (possibly-expand-abbrev (point (win *application-frame*)))) (insert-object (point (win *application-frame*)) *current-gesture*)) -(define-command com-backward-object () +(define-named-command com-backward-object () (decf (offset (point (win *application-frame*))))) -(define-command com-forward-object () +(define-named-command com-forward-object () (incf (offset (point (win *application-frame*))))) -(define-command com-beginning-of-line () +(define-named-command com-beginning-of-line () (beginning-of-line (point (win *application-frame*)))) -(define-command com-end-of-line () +(define-named-command com-end-of-line () (end-of-line (point (win *application-frame*)))) -(define-command com-delete-object () +(define-named-command com-delete-object () (delete-range (point (win *application-frame*)))) -(define-command com-backward-delete-object () +(define-named-command com-backward-delete-object () (delete-range (point (win *application-frame*)) -1)) -(define-command com-previous-line () +(define-named-command com-previous-line () (previous-line (point (win *application-frame*)))) -(define-command com-next-line () +(define-named-command com-next-line () (next-line (point (win *application-frame*)))) -(define-command com-open-line () +(define-named-command com-open-line () (open-line (point (win *application-frame*)))) -(define-command com-kill-line () +(define-named-command com-kill-line () (kill-line (point (win *application-frame*)))) -(define-command com-forward-word () +(define-named-command com-forward-word () (forward-word (point (win *application-frame*)))) -(define-command com-backward-word () +(define-named-command com-backward-word () (backward-word (point (win *application-frame*)))) -(define-command com-delete-word () +(define-named-command com-delete-word () (delete-word (point (win *application-frame*)))) -(define-command com-backward-delete-word () +(define-named-command com-backward-delete-word () (backward-delete-word (point (win *application-frame*)))) -(define-command com-toggle-layout () +(define-named-command com-toggle-layout () (setf (frame-current-layout *application-frame*) (if (eq (frame-current-layout *application-frame*) 'default) 'with-interactor @@ -296,7 +299,7 @@ (concatenate 'string (pathname-name pathname) "." (pathname-type pathname)))) -(define-climacs-command (com-find-file :name t) () +(define-named-command com-find-file () (let ((filename (accept 'completable-pathname :prompt "Find File"))) (with-slots (buffer point syntax) (win *application-frame*) @@ -313,7 +316,7 @@ (redisplay-frame-panes *application-frame*) (beginning-of-buffer point)))) -(define-command com-save-buffer () +(define-named-command com-save-buffer () (let* ((buffer (buffer (win *application-frame*))) (filename (or (filename buffer) (accept 'completable-pathname @@ -328,7 +331,7 @@ (display-message "No changes need to be saved from ~a" (name buffer))) (setf (needs-saving buffer) nil))) -(define-command com-write-buffer () +(define-named-command com-write-buffer () (let ((filename (accept 'completable-pathname :prompt "Write Buffer to File")) (buffer (buffer (win *application-frame*)))) @@ -339,24 +342,24 @@ (needs-saving buffer) nil) (display-message "Wrote: ~a" (filename buffer)))) -(define-command com-beginning-of-buffer () +(define-named-command com-beginning-of-buffer () (beginning-of-buffer (point (win *application-frame*)))) -(define-command com-end-of-buffer () +(define-named-command com-end-of-buffer () (end-of-buffer (point (win *application-frame*)))) -(define-command com-back-to-indentation () +(define-named-command com-back-to-indentation () (let ((point (point (win *application-frame*)))) (beginning-of-line point) (loop until (end-of-line-p point) while (whitespacep (object-after point)) do (incf (offset point))))) -(define-climacs-command (com-goto-position :name t) () +(define-named-command com-goto-position () (setf (offset (point (win *application-frame*))) (accept 'integer :prompt "Goto Position"))) -(define-climacs-command (com-goto-line :name t) () +(define-named-command com-goto-line () (loop with mark = (make-instance 'standard-right-sticky-mark :buffer (buffer (win *application-frame*))) do (end-of-line mark) @@ -368,10 +371,10 @@ (setf (offset (point (win *application-frame*))) (offset mark)))) -(define-climacs-command (com-browse-url :name t) () +(define-named-command com-browse-url () (accept 'url :prompt "Browse URL")) -(define-command com-set-mark () +(define-named-command com-set-mark () (with-slots (point mark) (win *application-frame*) (setf mark (clone-mark point)))) @@ -379,15 +382,15 @@ ;; Kill ring commands ;; Copies an element from a kill-ring to a buffer at the given offset -(define-command com-copy-in () +(define-named-command com-copy-in () (insert-sequence (point (win *application-frame*)) (kr-copy *kill-ring*))) ;; Cuts an element from a kill-ring out to a buffer at a given offset -(define-command com-cut-in () +(define-named-command com-cut-in () (insert-sequence (point (win *application-frame*)) (kr-pop *kill-ring*))) ;; Destructively cut a given buffer region into the kill-ring -(define-command com-cut-out () +(define-named-command com-cut-out () (with-slots (buffer point mark)(win *application-frame*) (if (< (offset point) (offset mark)) ((lambda (b o1 o2) @@ -401,7 +404,7 @@ ;; Non destructively copies in buffer region to the kill ring -(define-command com-copy-out () +(define-named-command com-copy-out () (with-slots (buffer point mark)(win *application-frame*) (let ((off1 (offset point)) (off2 (offset mark))) @@ -410,11 +413,11 @@ (kr-push *kill-ring* (buffer-sequence buffer off2 off1)))))) ;; Needs adjustment to be like emacs M-y -(define-command com-kr-rotate () +(define-named-command com-kr-rotate () (kr-rotate *kill-ring* -1)) ;; Not bound to a key yet -(define-command com-kr-resize () +(define-named-command com-kr-resize () (let ((size (accept 'fixnum :prompt "New kill ring size: "))) (kr-resize *kill-ring* size)))

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp
by rstrandh＠common-lisp.net 30 Dec '04

30 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv23174 Modified Files: base.lisp gui.lisp Log Message: fixed some problems with word delete commands. Used define-climacs-command instead of :command-table climacs, and :name t when appropriate (as of now: always). Date: Thu Dec 30 06:28:23 2004 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.7 climacs/base.lisp:1.8 --- climacs/base.lisp:1.7 Wed Dec 29 17:03:21 2004 +++ climacs/base.lisp Thu Dec 30 06:28:21 2004 @@ -121,7 +121,7 @@ "Delete until the end of the word" (loop until (end-of-buffer-p mark) until (constituentp (object-after mark)) - do (incf (offset mark))) + do (delete-range mark)) (loop until (end-of-buffer-p mark) while (constituentp (object-after mark)) do (delete-range mark))) @@ -130,7 +130,7 @@ "Delete until the beginning of the word" (loop until (beginning-of-buffer-p mark) until (constituentp (object-before mark)) - do (decf (offset mark))) + do (delete-range mark -1)) (loop until (beginning-of-buffer-p mark) while (constituentp (object-before mark)) do (delete-range mark -1))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.32 climacs/gui.lisp:1.33 --- climacs/gui.lisp:1.32 Wed Dec 29 17:03:21 2004 +++ climacs/gui.lisp Thu Dec 30 06:28:21 2004 @@ -157,7 +157,7 @@ (setf (needs-saving buffer) t))) (redisplay-frame-panes frame)))) -(define-command (com-quit :name t :command-table climacs) () +(define-climacs-command (com-quit :name t) () (frame-exit *application-frame*)) (define-command com-self-insert () @@ -296,7 +296,7 @@ (concatenate 'string (pathname-name pathname) "." (pathname-type pathname)))) -(define-command (com-find-file :name t :command-table climacs) () +(define-climacs-command (com-find-file :name t) () (let ((filename (accept 'completable-pathname :prompt "Find File"))) (with-slots (buffer point syntax) (win *application-frame*) @@ -352,11 +352,11 @@ while (whitespacep (object-after point)) do (incf (offset point))))) -(define-command (com-goto-position :name t :command-table climacs) () +(define-climacs-command (com-goto-position :name t) () (setf (offset (point (win *application-frame*))) (accept 'integer :prompt "Goto Position"))) -(define-command (com-goto-line :name t :command-table climacs) () +(define-climacs-command (com-goto-line :name t) () (loop with mark = (make-instance 'standard-right-sticky-mark :buffer (buffer (win *application-frame*))) do (end-of-line mark) @@ -368,7 +368,7 @@ (setf (offset (point (win *application-frame*))) (offset mark)))) -(define-command com-browse-url () +(define-climacs-command (com-browse-url :name t) () (accept 'url :prompt "Browse URL")) (define-command com-set-mark ()

1 0

[climacs-cvs] CVS update: climacs/kill-ring.lisp
by ejohnson＠common-lisp.net 30 Dec '04

30 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18458 Modified Files: kill-ring.lisp Log Message: Changed fixnum limit of kill ring to unsigned-byte Date: Thu Dec 30 04:55:14 2004 Author: ejohnson Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.2 climacs/kill-ring.lisp:1.3 --- climacs/kill-ring.lisp:1.2 Wed Dec 29 08:06:46 2004 +++ climacs/kill-ring.lisp Thu Dec 30 04:55:14 2004 @@ -25,7 +25,7 @@ (in-package :climacs-kill-ring) (defclass kill-ring () - ((max-size :type 'fixnum + ((max-size :type unsigned-byte :initarg :max-size :accessor kr-max-size) (flexichain :type standard-flexichain

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp
by rstrandh＠common-lisp.net 29 Dec '04

29 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14833 Modified Files: base.lisp gui.lisp packages.lisp Log Message: New commands: M-m (back to indentation) M-d (delete word) M-backspace (backward delete word) M-x goto-position M-x goto-line New function whitespacep. Used `:name t' instead of repeating the command name in define-command. Date: Wed Dec 29 17:03:22 2004 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.6 climacs/base.lisp:1.7 --- climacs/base.lisp:1.6 Mon Dec 27 12:32:46 2004 +++ climacs/base.lisp Wed Dec 29 17:03:21 2004 @@ -93,6 +93,12 @@ #+sbcl (sb-impl::constituentp obj) #-sbcl (alphanumericp obj))) +(defun whitespacep (obj) + "A predicate to ensure that an object is a whitespace character." + (and (characterp obj) + #+sbcl (sb-impl::whitespacep obj) + #-sbcl (member obj '(#\Space #\Tab)))) + (defun forward-word (mark) "Forward the mark to the next word." (loop until (end-of-buffer-p mark) @@ -110,4 +116,22 @@ (loop until (beginning-of-buffer-p mark) while (constituentp (object-before mark)) do (decf (offset mark)))) + +(defun delete-word (mark) + "Delete until the end of the word" + (loop until (end-of-buffer-p mark) + until (constituentp (object-after mark)) + do (incf (offset mark))) + (loop until (end-of-buffer-p mark) + while (constituentp (object-after mark)) + do (delete-range mark))) + +(defun backward-delete-word (mark) + "Delete until the beginning of the word" + (loop until (beginning-of-buffer-p mark) + until (constituentp (object-before mark)) + do (decf (offset mark))) + (loop until (beginning-of-buffer-p mark) + while (constituentp (object-before mark)) + do (delete-range mark -1))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.31 climacs/gui.lisp:1.32 --- climacs/gui.lisp:1.31 Wed Dec 29 09:02:45 2004 +++ climacs/gui.lisp Wed Dec 29 17:03:21 2004 @@ -157,7 +157,7 @@ (setf (needs-saving buffer) t))) (redisplay-frame-panes frame)))) -(define-command (com-quit :name "Quit" :command-table climacs) () +(define-command (com-quit :name t :command-table climacs) () (frame-exit *application-frame*)) (define-command com-self-insert () @@ -201,6 +201,12 @@ (define-command com-backward-word () (backward-word (point (win *application-frame*)))) +(define-command com-delete-word () + (delete-word (point (win *application-frame*)))) + +(define-command com-backward-delete-word () + (backward-delete-word (point (win *application-frame*)))) + (define-command com-toggle-layout () (setf (frame-current-layout *application-frame*) (if (eq (frame-current-layout *application-frame*) 'default) @@ -290,7 +296,7 @@ (concatenate 'string (pathname-name pathname) "." (pathname-type pathname)))) -(define-command (com-find-file :name "Find File" :command-table climacs) () +(define-command (com-find-file :name t :command-table climacs) () (let ((filename (accept 'completable-pathname :prompt "Find File"))) (with-slots (buffer point syntax) (win *application-frame*) @@ -339,6 +345,29 @@ (define-command com-end-of-buffer () (end-of-buffer (point (win *application-frame*)))) +(define-command com-back-to-indentation () + (let ((point (point (win *application-frame*)))) + (beginning-of-line point) + (loop until (end-of-line-p point) + while (whitespacep (object-after point)) + do (incf (offset point))))) + +(define-command (com-goto-position :name t :command-table climacs) () + (setf (offset (point (win *application-frame*))) + (accept 'integer :prompt "Goto Position"))) + +(define-command (com-goto-line :name t :command-table climacs) () + (loop with mark = (make-instance 'standard-right-sticky-mark + :buffer (buffer (win *application-frame*))) + do (end-of-line mark) + until (end-of-buffer-p mark) + repeat (accept 'integer :prompt "Goto Line") + do (incf (offset mark)) + (end-of-line mark) + finally (beginning-of-line mark) + (setf (offset (point (win *application-frame*))) + (offset mark)))) + (define-command com-browse-url () (accept 'url :prompt "Browse URL")) @@ -424,6 +453,9 @@ (global-set-key '(#\< :shift :meta) 'com-beginning-of-buffer) (global-set-key '(#\> :shift :meta) 'com-end-of-buffer) (global-set-key '(#\u :meta) 'com-browse-url) +(global-set-key '(#\m :meta) 'com-back-to-indentation) +(global-set-key '(#\d :meta) 'com-delete-word) +(global-set-key '(#\Backspace :meta) 'com-backward-delete-word) (global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.14 climacs/packages.lisp:1.15 --- climacs/packages.lisp:1.14 Wed Dec 29 08:06:46 2004 +++ climacs/packages.lisp Wed Dec 29 17:03:21 2004 @@ -45,8 +45,9 @@ (:export #:previous-line #:next-line #:open-line #:kill-line #:number-of-lines-in-region - #:constituentp + #:constituentp #:whitespacep #:forward-word #:backward-word + #:delete-word #:backward-delete-word #:input-from-stream #:output-to-stream)) (defpackage :climacs-abbrev

1 0

[climacs-cvs] CVS update: climacs/syntax.lisp
by rstrandh＠common-lisp.net 29 Dec '04

29 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv579 Modified Files: syntax.lisp Log Message: Fixed the invisible cursor problem. Still don't know why even positions are required, though. Date: Wed Dec 29 12:38:34 2004 Author: rstrandh Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.11 climacs/syntax.lisp:1.12 --- climacs/syntax.lisp:1.11 Tue Dec 28 23:41:14 2004 +++ climacs/syntax.lisp Wed Dec 29 12:38:34 2004 @@ -122,6 +122,11 @@ finally (output-word (terpri pane)) (incf scan)))))) +(defun round-up (x) + (cond ((zerop x) 2) + ((evenp x) x) + (t (1+ x)))) + (defmethod redisplay-with-syntax (pane (syntax basic-syntax)) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) @@ -168,8 +173,9 @@ (draw-line* pane ;; cursors with odd x-positions were invisible ;; so we strip off the low bit to make them even. - (logand -2 cursor-x) (- cursor-y (* 0.2 height)) - (logand -2 cursor-x) (+ cursor-y (* 0.8 height)) + + (round-up cursor-x) (- cursor-y (* 0.2 height)) + (round-up cursor-x) (+ cursor-y (* 0.8 height)) :ink +red+))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by ejohnson＠common-lisp.net 29 Dec '04

29 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv22317 Modified Files: gui.lisp Log Message: factored out kr generic functions in gui.lisp for define-commands Date: Wed Dec 29 09:02:45 2004 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.30 climacs/gui.lisp:1.31 --- climacs/gui.lisp:1.30 Wed Dec 29 08:26:02 2004 +++ climacs/gui.lisp Wed Dec 29 09:02:45 2004 @@ -349,56 +349,36 @@ ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands -;; The naming may sound odd here, but think of electronic wireing: -;; outputs to inputs and inputs to outputs. Copying into a buffer -;; first requires coping out of the kill ring. - -(defgeneric kr-copy-in (buffer kr offset1 offset2) - (:documentation "Non destructively copies in buffer region to the kill ring")) - -(defmethod kr-copy-in ((buffer standard-buffer) (kr kill-ring) offset1 offset2) - (kr-push kr (buffer-sequence buffer offset1 offset2))) - -(defgeneric kr-cut-in (buffer kr offset1 offset2) - (:documentation "Destructively cut a given buffer region into the kill-ring")) - -(defmethod kr-cut-in ((buffer standard-buffer) (kr kill-ring) offset1 offset2) - (kr-copy-in buffer kr offset1 offset2) - (climacs-buffer::delete-buffer-range buffer offset1 (- offset2 offset1))) - -(defgeneric kr-copy-out (mark kr) - (:documentation "Copies an element from a kill-ring to a buffer at the given offset")) - -(defmethod kr-copy-out ((mark standard-right-sticky-mark)(kr kill-ring)) - (insert-sequence mark (kr-copy kr))) - -(defgeneric kr-cut-out (mark kr) - (:documentation "Cuts an element from a kill-ring out to a buffer at a given offset")) - -(defmethod kr-cut-out ((mark standard-right-sticky-mark) (kr kill-ring)) - (insert-sequence mark (kr-pop kr))) - +;; Copies an element from a kill-ring to a buffer at the given offset (define-command com-copy-in () - (kr-copy-out (point (win *application-frame*)) *kill-ring*)) + (insert-sequence (point (win *application-frame*)) (kr-copy *kill-ring*))) +;; Cuts an element from a kill-ring out to a buffer at a given offset (define-command com-cut-in () - (kr-cut-out (point (win *application-frame*)) *kill-ring*)) + (insert-sequence (point (win *application-frame*)) (kr-pop *kill-ring*))) +;; Destructively cut a given buffer region into the kill-ring (define-command com-cut-out () (with-slots (buffer point mark)(win *application-frame*) - (let ((off1 (offset point)) - (off2 (offset mark))) - (if (< off1 off2) - (kr-cut-in buffer *kill-ring* off1 off2) - (kr-cut-in buffer *kill-ring* off2 off1))))) + (if (< (offset point) (offset mark)) + ((lambda (b o1 o2) + (kr-push *kill-ring* (buffer-sequence b o1 o2)) + (delete-buffer-range b o1 (- o2 o1))) + buffer (offset point) (offset mark)) + ((lambda (b o1 o2) + (kr-push *kill-ring* (buffer-sequence b o2 o1)) + (delete-buffer-range b o1 (- o2 o1))) + buffer (offset mark) (offset point))))) + +;; Non destructively copies in buffer region to the kill ring (define-command com-copy-out () (with-slots (buffer point mark)(win *application-frame*) (let ((off1 (offset point)) (off2 (offset mark))) (if (< off1 off2) - (kr-copy-in buffer *kill-ring* off1 off2) - (kr-copy-in buffer *kill-ring* off2 off1))))) + (kr-push *kill-ring* (buffer-sequence buffer off1 off2)) + (kr-push *kill-ring* (buffer-sequence buffer off2 off1)))))) ;; Needs adjustment to be like emacs M-y (define-command com-kr-rotate ()

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 29 Dec '04

29 Dec '04

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20099 Modified Files: gui.lisp Log Message: Implemented a suggestion from Lawrence Mitchell to avoid saving a buffer that has not need to be saved. Date: Wed Dec 29 08:26:02 2004 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.29 climacs/gui.lisp:1.30 --- climacs/gui.lisp:1.29 Wed Dec 29 08:06:46 2004 +++ climacs/gui.lisp Wed Dec 29 08:26:02 2004 @@ -88,6 +88,9 @@ (let ((frame (make-application-frame 'climacs))) (run-frame-top-level frame))) +(defun display-message (format-string &rest format-args) + (apply #'format *standard-input* format-string format-args)) + (defun display-info (frame pane) (let* ((win (win frame)) (buf (buffer win)) @@ -305,15 +308,19 @@ (beginning-of-buffer point)))) (define-command com-save-buffer () - (let ((filename (or (filename (buffer (win *application-frame*))) - (accept 'completable-pathname - :prompt "Save Buffer to File"))) - (buffer (buffer (win *application-frame*)))) - (with-open-file (stream filename :direction :output :if-exists :supersede) - (output-to-stream stream buffer 0 (size buffer))) - (setf (filename buffer) filename - (name buffer) (pathname-filename filename) - (needs-saving buffer) nil))) + (let* ((buffer (buffer (win *application-frame*))) + (filename (or (filename buffer) + (accept 'completable-pathname + :prompt "Save Buffer to File")))) + (if (or (null (filename buffer)) + (needs-saving buffer)) + (progn (with-open-file (stream filename :direction :output :if-exists :supersede) + (output-to-stream stream buffer 0 (size buffer))) + (setf (filename buffer) filename + (name buffer) (pathname-filename filename)) + (display-message "Wrote: ~a" (filename buffer))) + (display-message "No changes need to be saved from ~a" (name buffer))) + (setf (needs-saving buffer) nil))) (define-command com-write-buffer () (let ((filename (accept 'completable-pathname @@ -323,7 +330,8 @@ (output-to-stream stream buffer 0 (size buffer))) (setf (filename buffer) filename (name buffer) (pathname-filename filename) - (needs-saving buffer) nil))) + (needs-saving buffer) nil) + (display-message "Wrote: ~a" (filename buffer)))) (define-command com-beginning-of-buffer () (beginning-of-buffer (point (win *application-frame*))))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs December 2004