January 2005 - climacs-cvs@common-lisp.net

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp
by mvilleneuve＠common-lisp.net 20 Jan '05

20 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19202 Modified Files: base.lisp gui.lisp Log Message: Fixed bug in fill-line with words longer than fill-column Date: Thu Jan 20 11:12:49 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.22 climacs/base.lisp:1.23 --- climacs/base.lisp:1.22 Wed Jan 19 12:04:39 2005 +++ climacs/base.lisp Thu Jan 20 11:12:48 2005 @@ -401,6 +401,7 @@ (let ((begin-mark (clone-mark mark))) (beginning-of-line begin-mark) (loop with column = 0 + with line-beginning-offset = (offset begin-mark) with walking-mark = (clone-mark begin-mark) while (mark< walking-mark mark) as object = (object-after walking-mark) @@ -413,13 +414,15 @@ (incf column (- tab-width (mod column tab-width)))) (t (incf column))) - (when (>= column fill-column) + (when (and (>= column fill-column) + (/= (offset begin-mark) line-beginning-offset)) (insert-object begin-mark #\Newline) (incf (offset begin-mark)) (let ((indentation (funcall syntax-line-indentation-function begin-mark))) (indent-line begin-mark indentation tab-width)) (beginning-of-line begin-mark) + (setf line-beginning-offset (offset begin-mark)) (setf (offset walking-mark) (offset begin-mark)) (setf column 0)) (incf (offset walking-mark))))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.88 climacs/gui.lisp:1.89 --- climacs/gui.lisp:1.88 Wed Jan 19 22:01:56 2005 +++ climacs/gui.lisp Thu Jan 20 11:12:48 2005 @@ -289,21 +289,7 @@ (with-slots (overwrite-mode) (current-window) (setf overwrite-mode (not overwrite-mode)))) -(defun insert-character (char) - (let* ((win (current-window)) - (point (point win))) - (unless (constituentp char) - (possibly-expand-abbrev point)) - (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point))) - (progn - (delete-range point) - (insert-object point char)) - (insert-object point char)))) - -(define-command com-self-insert () - (insert-character *current-gesture*)) - -(define-command com-self-filling-insert () +(defun possibly-fill-line () (let* ((pane (current-window)) (buffer (buffer pane))) (when (auto-fill-mode buffer) @@ -318,7 +304,22 @@ (lambda (mark) (syntax-line-indentation mark tab-width syntax)) fill-column - tab-width))))) + tab-width)))))) + +(defun insert-character (char) + (let* ((win (current-window)) + (point (point win))) + (unless (constituentp char) + (possibly-expand-abbrev point)) + (when (whitespacep char) + (possibly-fill-line)) + (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point))) + (progn + (delete-range point) + (insert-object point char)) + (insert-object point char)))) + +(define-command com-self-insert () (insert-character *current-gesture*)) (define-named-command com-beginning-of-line () @@ -967,11 +968,10 @@ (find :meta gesture)) (dead-escape-set-key (remove :meta gesture) command))) -(loop for code from (char-code #\!) to (char-code #\~) +(loop for code from (char-code #\Space) to (char-code #\~) do (global-set-key (code-char code) 'com-self-insert)) -(global-set-key #\Space 'com-self-filling-insert) -(global-set-key #\Newline 'com-self-filling-insert) +(global-set-key #\Newline 'com-self-insert) (global-set-key #\Tab 'com-indent-line) (global-set-key '(#\j :control) 'com-newline-and-indent) (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 20 Jan '05

20 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11314 Modified Files: gui.lisp Log Message: Fixed bug in keyboard macros. Date: Wed Jan 19 22:01:57 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.87 climacs/gui.lisp:1.88 --- climacs/gui.lisp:1.87 Wed Jan 19 17:22:19 2005 +++ climacs/gui.lisp Wed Jan 19 22:01:56 2005 @@ -173,10 +173,12 @@ (defun climacs-unread-gesture (gesture stream) (cond ((recordingp *application-frame*) - (pop (recorded-keys *application-frame*))) + (pop (recorded-keys *application-frame*)) + (unread-gesture gesture :stream stream)) ((executingp *application-frame*) - (push gesture (remaining-keys *application-frame*)))) - (unread-gesture gesture :stream stream)) + (push gesture (remaining-keys *application-frame*))) + (t + (unread-gesture gesture :stream stream)))) (defun read-numeric-argument (&key (stream *standard-input*)) (let ((gesture (climacs-read-gesture)))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/buffer-test.lisp
by abakic＠common-lisp.net 20 Jan '05

20 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29136 Modified Files: gui.lisp buffer-test.lisp Log Message: A note/comment about macro use and a few buffer performance tests. Date: Wed Jan 19 17:22:20 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.86 climacs/gui.lisp:1.87 --- climacs/gui.lisp:1.86 Wed Jan 19 12:04:39 2005 +++ climacs/gui.lisp Wed Jan 19 17:22:19 2005 @@ -85,7 +85,7 @@ int))) (:top-level (climacs-top-level))) -(defmacro current-window () +(defmacro current-window () ; shouldn't this be an inlined function? --amb `(car (windows *application-frame*))) (defmethod redisplay-frame-panes :around ((frame climacs) &rest args) @@ -284,9 +284,8 @@ (frame-exit *application-frame*)) (define-named-command com-toggle-overwrite-mode () - (let ((win (current-window))) - (setf (slot-value win 'overwrite-mode) - (not (slot-value win 'overwrite-mode))))) + (with-slots (overwrite-mode) (current-window) + (setf overwrite-mode (not overwrite-mode)))) (defun insert-character (char) (let* ((win (current-window)) Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.6 climacs/buffer-test.lisp:1.7 --- climacs/buffer-test.lisp:1.6 Tue Jan 18 10:59:51 2005 +++ climacs/buffer-test.lisp Wed Jan 19 17:22:19 2005 @@ -692,4 +692,118 @@ (error (c) (declare (ignore c)) 'caught)) - caught) \ No newline at end of file + caught) + + +;;;; performance tests + +(defmacro deftimetest (name form &rest results) + `(deftest ,name + (time + (progn + (format t "~&; Performance test ~a" ',name) + ,form)) + ,@results)) + +(deftimetest standard-buffer-performance.test-1 + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b 0 #\a) + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-1a + (let ((b (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b 0 #\a) + finally (return b)))) + (loop for i from 0 below 100000 + do (delete-buffer-range b 0 1) + finally (return (size b)))) + 0) + +(deftimetest standard-buffer-performance.test-1b + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b (size b) #\a) + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-1ba + (let ((b (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b (size b) #\a) + finally (return b)))) + (loop for i from 0 below 100000 + do (delete-buffer-range b 0 1) + finally (return (size b)))) + 0) + +(deftimetest standard-buffer-performance.test-1c + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b (floor (size b) 2) #\a) + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-1ca + (let ((b (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b (floor (size b) 2) #\a) + finally (return b)))) + (loop for i from 0 below 100000 + do (delete-buffer-range b 0 1) + finally (return (size b)))) + 0) + +(deftimetest standard-buffer-performance.test-1cb + (let ((b (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-object b (floor (size b) 2) #\a) + finally (return b)))) + (loop for i from 0 below 100000 + do (delete-buffer-range b (floor (size b) 2) 1) + finally (return (size b)))) + 0) + +(deftimetest standard-buffer-performance.test-2 + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b 0 "a") + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-2b + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b (size b) "a") + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-2c + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b (floor (size b) 2) "a") + finally (return (size b))) + 100000) + +(deftimetest standard-buffer-performance.test-3 + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b 0 "abcdefghij") + finally (return (size b))) + 1000000) + +(deftimetest standard-buffer-performance.test-3b + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b (size b) "abcdefghij") + finally (return (size b))) + 1000000) + +(deftimetest standard-buffer-performance.test-3c + (loop with b = (make-instance 'standard-buffer) + for i from 0 below 100000 + do (insert-buffer-sequence b (floor (size b) 2) "abcdefghij") + finally (return (size b))) + 1000000) \ No newline at end of file

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp
by mvilleneuve＠common-lisp.net 19 Jan '05

19 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12217 Modified Files: base.lisp gui.lisp packages.lisp pane.lisp Log Message: Added auto-fill mode Date: Wed Jan 19 12:04:39 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.21 climacs/base.lisp:1.22 --- climacs/base.lisp:1.21 Tue Jan 18 10:59:51 2005 +++ climacs/base.lisp Wed Jan 19 12:04:39 2005 @@ -114,7 +114,7 @@ count (eql (buffer-object buffer offset1) #\Newline) do (incf offset1))) -(defun buffer-display-column-number (buffer offset tab-width) +(defun buffer-display-column (buffer offset tab-width) (let ((line-start-offset (- offset (buffer-column-number buffer offset)))) (loop with column = 0 for i from line-start-offset below offset @@ -308,7 +308,7 @@ finally (return t)))) (loop for offset = offset1 then (1+ offset) until (>= offset offset2) - do (let* ((column (buffer-display-column-number + do (let* ((column (buffer-display-column buffer offset tab-width)) (count (- tab-width (mod column tab-width)))) (when (looking-at-spaces buffer offset count) @@ -336,8 +336,9 @@ (loop for offset = offset1 then (1+ offset) until (>= offset offset2) when (char= (buffer-object buffer offset) #\Tab) - do (let* ((column (buffer-display-column-number - buffer offset tab-width)) + 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 @@ -391,6 +392,37 @@ while (whitespacep (object-before mark)) do (delete-range mark -1)) (insert-object mark #\Space))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Auto fill + +(defun fill-line (mark syntax-line-indentation-function fill-column tab-width) + (let ((begin-mark (clone-mark mark))) + (beginning-of-line begin-mark) + (loop with column = 0 + with walking-mark = (clone-mark begin-mark) + while (mark< walking-mark mark) + as object = (object-after walking-mark) + do (case object + (#\Space + (setf (offset begin-mark) (offset walking-mark)) + (incf column)) + (#\Tab + (setf (offset begin-mark) (offset walking-mark)) + (incf column (- tab-width (mod column tab-width)))) + (t + (incf column))) + (when (>= column fill-column) + (insert-object begin-mark #\Newline) + (incf (offset begin-mark)) + (let ((indentation + (funcall syntax-line-indentation-function begin-mark))) + (indent-line begin-mark indentation tab-width)) + (beginning-of-line begin-mark) + (setf (offset walking-mark) (offset begin-mark)) + (setf column 0)) + (incf (offset walking-mark))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.85 climacs/gui.lisp:1.86 --- climacs/gui.lisp:1.85 Wed Jan 19 06:38:47 2005 +++ climacs/gui.lisp Wed Jan 19 12:04:39 2005 @@ -109,13 +109,16 @@ (declare (ignore frame)) (with-slots (climacs-pane) pane (let* ((buf (buffer climacs-pane)) - (name-info (format nil " ~a ~a Syntax: ~a ~a ~a" + (name-info (format nil " ~a ~a Syntax: ~a~a~a ~a" (if (needs-saving buf) "**" "--") (name buf) (name (syntax buf)) (if (slot-value climacs-pane 'overwrite-mode) - "Ovwrt" + " Ovwrt" "") + (if (auto-fill-mode buf) + " Fill" + "") (if (recordingp *application-frame*) "Def" "")))) @@ -285,16 +288,37 @@ (setf (slot-value win 'overwrite-mode) (not (slot-value win 'overwrite-mode))))) -(define-command com-self-insert () +(defun insert-character (char) (let* ((win (current-window)) (point (point win))) - (unless (constituentp *current-gesture*) + (unless (constituentp char) (possibly-expand-abbrev point)) (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point))) (progn (delete-range point) - (insert-object point *current-gesture*)) - (insert-object point *current-gesture*)))) + (insert-object point char)) + (insert-object point char)))) + +(define-command com-self-insert () + (insert-character *current-gesture*)) + +(define-command com-self-filling-insert () + (let* ((pane (current-window)) + (buffer (buffer pane))) + (when (auto-fill-mode buffer) + (let* ((fill-column (auto-fill-column buffer)) + (point (point pane)) + (offset (offset point)) + (tab-width (tab-space-count (stream-default-view pane))) + (syntax (syntax buffer))) + (when (>= (buffer-display-column buffer offset tab-width) + (1- (auto-fill-column buffer))) + (fill-line point + (lambda (mark) + (syntax-line-indentation mark tab-width syntax)) + fill-column + tab-width))))) + (insert-character *current-gesture*)) (define-named-command com-beginning-of-line () (beginning-of-line (point (current-window)))) @@ -475,6 +499,10 @@ (define-named-command com-delete-indentation () (delete-indentation (point (current-window)))) +(define-named-command com-auto-fill-mode () + (let ((buffer (buffer (current-window)))) + (setf (auto-fill-mode buffer) (not (auto-fill-mode buffer))))) + (define-command com-extended-command () (let ((item (accept 'command :prompt "Extended Command"))) (execute-frame-command *application-frame* item))) @@ -938,11 +966,12 @@ (find :meta gesture)) (dead-escape-set-key (remove :meta gesture) command))) -(loop for code from (char-code #\space) to (char-code #\~) +(loop for code from (char-code #\!) to (char-code #\~) do (global-set-key (code-char code) 'com-self-insert)) -(global-set-key #\newline 'com-self-insert) -(global-set-key #\tab 'com-indent-line) +(global-set-key #\Space 'com-self-filling-insert) +(global-set-key #\Newline 'com-self-filling-insert) +(global-set-key #\Tab 'com-indent-line) (global-set-key '(#\j :control) 'com-newline-and-indent) (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*)) (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*)) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.35 climacs/packages.lisp:1.36 --- climacs/packages.lisp:1.35 Mon Jan 17 15:10:24 2005 +++ climacs/packages.lisp Wed Jan 19 12:04:39 2005 @@ -51,6 +51,7 @@ #:open-line #:kill-line #:empty-line-p #:line-indentation + #:buffer-display-column #:number-of-lines-in-region #:constituentp #:whitespacep #:forward-word #:backward-word @@ -60,6 +61,7 @@ #:tabify-region #:untabify-region #:indent-line #:delete-indentation + #:fill-line #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-lookin-at #:looking-at @@ -95,6 +97,7 @@ #:page-down #:page-up #:tab-space-count #:indent-tabs-mode + #:auto-fill-mode #:auto-fill-column #:url)) (defpackage :climacs-gui Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.6 climacs/pane.lisp:1.7 --- climacs/pane.lisp:1.6 Tue Jan 18 21:21:16 2005 +++ climacs/pane.lisp Wed Jan 19 12:04:39 2005 @@ -58,7 +58,9 @@ ((needs-saving :initform nil :accessor needs-saving) (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t - :accessor indent-tabs-mode)) + :accessor indent-tabs-mode) + (auto-fill-mode :initform t :accessor auto-fill-mode) + (auto-fill-column :initform 70 :accessor auto-fill-column)) (:default-initargs :name "*scratch*"))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 19 Jan '05

19 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27404 Modified Files: gui.lisp Log Message: Implemented keyboard macros, except that there is a bug that do not have time to track down right now, leaving an extra 'e' in the buffer. Date: Wed Jan 19 06:38:48 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.84 climacs/gui.lisp:1.85 --- climacs/gui.lisp:1.84 Tue Jan 18 21:28:38 2005 +++ climacs/gui.lisp Wed Jan 19 06:38:47 2005 @@ -50,7 +50,11 @@ (define-application-frame climacs () ((windows :accessor windows) - (buffers :initform '() :accessor buffers)) + (buffers :initform '() :accessor buffers) + (recordingp :initform nil :accessor recordingp) + (executingp :initform nil :accessor executingp) + (recorded-keys :initform '() :accessor recorded-keys) + (remaining-keys :initform '() :accessor remaining-keys)) (:panes (win (let* ((extended-pane (make-pane 'extended-pane @@ -105,12 +109,15 @@ (declare (ignore frame)) (with-slots (climacs-pane) pane (let* ((buf (buffer climacs-pane)) - (name-info (format nil " ~a ~a Syntax: ~a ~a" + (name-info (format nil " ~a ~a Syntax: ~a ~a ~a" (if (needs-saving buf) "**" "--") (name buf) (name (syntax buf)) (if (slot-value climacs-pane 'overwrite-mode) "Ovwrt" + "") + (if (recordingp *application-frame*) + "Def" "")))) (princ name-info pane)))) @@ -139,8 +146,11 @@ :test #'event-matches-gesture-name-p)) (defun climacs-read-gesture () + (unless (null (remaining-keys *application-frame*)) + (return-from climacs-read-gesture + (pop (remaining-keys *application-frame*)))) (loop for gesture = (read-gesture :stream *standard-input*) - when (event-matches-gesture-name-p gesture '(#\g :control)) + when (event-matches-gesture-name-p gesture '(:keyboard #\g 512)) ; FIXME do (throw 'outer-loop nil) until (or (characterp gesture) (and (typep gesture 'keyboard-event) @@ -154,7 +164,16 @@ :hyper-left :hyper-right :shift-lock :caps-lock :alt-left :alt-right)))))) - finally (return gesture))) + finally (progn (when (recordingp *application-frame*) + (push gesture (recorded-keys *application-frame*))) + (return gesture)))) + +(defun climacs-unread-gesture (gesture stream) + (cond ((recordingp *application-frame*) + (pop (recorded-keys *application-frame*))) + ((executingp *application-frame*) + (push gesture (remaining-keys *application-frame*)))) + (unread-gesture gesture :stream stream)) (defun read-numeric-argument (&key (stream *standard-input*)) (let ((gesture (climacs-read-gesture))) @@ -163,7 +182,7 @@ (loop for gesture = (climacs-read-gesture) while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME do (setf numarg (* 4 numarg)) - finally (unread-gesture gesture :stream stream)) + finally (climacs-unread-gesture gesture stream)) (let ((gesture (climacs-read-gesture))) (cond ((and (characterp gesture) (digit-char-p gesture 10)) @@ -173,19 +192,19 @@ (digit-char-p gesture 10)) do (setf numarg (+ (* 10 numarg) (- (char-code gesture) (char-code #\0)))) - finally (unread-gesture gesture :stream stream) + finally (climacs-unread-gesture gesture stream) (return (values numarg t)))) (t - (unread-gesture gesture :stream stream) + (climacs-unread-gesture gesture stream) (values numarg t)))))) ((meta-digit gesture) (let ((numarg (meta-digit gesture))) (loop for gesture = (climacs-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) - finally (unread-gesture gesture :stream stream) + finally (climacs-unread-gesture gesture stream) (return (values numarg t))))) - (t (unread-gesture gesture :stream stream) + (t (climacs-unread-gesture gesture stream) (values 1 nil))))) ;;; we know the vbox pane has a scroller pane and an info @@ -237,12 +256,16 @@ (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame))) + (when (null (remaining-keys *application-frame*)) + (setf (executingp *application-frame*) nil) + (redisplay-frame-panes frame)))) (beep) (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame))))) + (when (null (remaining-keys *application-frame*)) + (setf (executingp *application-frame*) nil) + (redisplay-frame-panes frame)))))) (defun region-limits (pane) (if (mark< (mark pane) (point pane)) @@ -675,6 +698,25 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Keyboard macros + +(define-named-command com-start-kbd-macro () + (setf (recordingp *application-frame*) t) + (setf (recorded-keys *application-frame*) '())) + +(define-named-command com-end-kbd-macro () + (setf (recordingp *application-frame*) nil) + (setf (recorded-keys *application-frame*) + ;; this won't work if the command was invoked in any old way + (reverse (cddr (recorded-keys *application-frame*))))) + +(define-named-command com-call-last-kbd-macro () + (setf (remaining-keys *application-frame*) + (recorded-keys *application-frame*)) + (setf (executingp *application-frame*) t)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Commands for splitting windows (defun replace-constellation (constellation additional-constellation vertical-p) @@ -971,7 +1013,10 @@ (c-x-set-key '(#\0) 'com-delete-window) (c-x-set-key '(#\2) 'com-split-window-vertically) (c-x-set-key '(#\3) 'com-split-window-horizontally) +(c-x-set-key '(#\() 'com-start-kbd-macro) +(c-x-set-key '(#\)) 'com-end-kbd-macro) (c-x-set-key '(#\b) 'com-switch-to-buffer) +(c-x-set-key '(#\e) 'com-call-last-kbd-macro) (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\l :control) 'com-load-file)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 19 Jan '05

19 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32062 Modified Files: gui.lisp Log Message: find-file does not create the file if it does not exist. (thanks to Lawrence Mitchell) Date: Tue Jan 18 21:28:38 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.83 climacs/gui.lisp:1.84 --- climacs/gui.lisp:1.83 Tue Jan 18 21:21:16 2005 +++ climacs/gui.lisp Tue Jan 18 21:28:38 2005 @@ -546,8 +546,10 @@ (push buffer (buffers *application-frame*)) (setf (buffer (current-window)) buffer) (setf (syntax buffer) (make-instance 'basic-syntax)) - (with-open-file (stream filename :direction :input :if-does-not-exist :create) - (input-from-stream stream buffer 0)) + ;; Don't want to create the file if it doesn't exist. + (when (probe-file filename) + (with-open-file (stream filename :direction :input) + (input-from-stream stream buffer 0))) (setf (filename buffer) filename (name buffer) (pathname-filename filename) (needs-saving buffer) nil)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp
by rstrandh＠common-lisp.net 19 Jan '05

19 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32010 Modified Files: gui.lisp pane.lisp Log Message: implemented preliminary multi-window support. C-x 2 splits the window vertically, C-x splits horizontally. C-x 0 deletes the current window. This is still preliminary code. One annoying problem is that the entire frame gets resized whenever a new window is added or deleted. Date: Tue Jan 18 21:21:17 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.82 climacs/gui.lisp:1.83 --- climacs/gui.lisp:1.82 Tue Jan 18 10:59:51 2005 +++ climacs/gui.lisp Tue Jan 18 21:21:16 2005 @@ -49,7 +49,7 @@ (window-clear pane)) (define-application-frame climacs () - ((win :reader win) + ((windows :accessor windows) (buffers :initform '() :accessor buffers)) (:panes (win (let* ((extended-pane @@ -82,14 +82,16 @@ (:top-level (climacs-top-level))) (defmacro current-window () - `(win *application-frame*)) + `(car (windows *application-frame*))) (defmethod redisplay-frame-panes :around ((frame climacs) &rest args) (declare (ignore args)) - (let ((buffer (buffer (win frame)))) - (update-syntax buffer (syntax buffer)) + (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame))))) + (loop for buffer in buffers + do (update-syntax buffer (syntax buffer))) (call-next-method) - (clear-modify buffer))) + (loop for buffer in buffers + do (clear-modify buffer)))) (defun climacs () "Starts up a climacs session" @@ -115,7 +117,7 @@ (defun display-win (frame pane) "The display function used by the climacs application frame." (declare (ignore frame)) - (redisplay-pane pane)) + (redisplay-pane pane (eq pane (car (windows *application-frame*))))) (defun find-gestures (gestures start-table) (loop with table = (find-command-table start-table) @@ -200,10 +202,10 @@ command-parser command-unparser partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser prompt)) - (with-slots (win) frame - (setf win (find-climacs-pane (find-pane-named frame 'win))) - (push (buffer win) (buffers frame)) - (let ((*standard-output* win) + (with-slots (windows) frame + (setf windows (list (find-climacs-pane (find-pane-named frame 'win)))) + (push (buffer (car windows)) (buffers frame)) + (let ((*standard-output* (car windows)) (*standard-input* (find-pane-named frame 'int)) (*print-pretty* nil) (*abort-gestures* nil)) @@ -232,12 +234,12 @@ command)) (return))) (t nil)))) - (let ((buffer (buffer (win frame)))) + (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) (redisplay-frame-panes frame))) (beep) - (let ((buffer (buffer (win frame)))) + (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) (redisplay-frame-panes frame))))) @@ -673,32 +675,106 @@ ;;; ;;; Commands for splitting windows +(defun replace-constellation (constellation additional-constellation vertical-p) + (let* ((parent (sheet-parent constellation)) + (children (sheet-children parent)) + (first (first children)) + (second (second children))) + (assert (member constellation children)) + (cond ((eq constellation first) + (sheet-disown-child parent constellation) + (let ((new (if vertical-p + (vertically () constellation additional-constellation) + (horizontally () constellation additional-constellation)))) + (sheet-adopt-child parent new) + (reorder-sheets parent (list new second)))) + (t + (sheet-disown-child parent constellation) + (let ((new (if vertical-p + (vertically () constellation additional-constellation) + (horizontally () constellation additional-constellation)))) + (sheet-adopt-child parent new) + (reorder-sheets parent (list first new))))))) + +(defun parent3 (sheet) + (sheet-parent (sheet-parent (sheet-parent sheet)))) + +(defun make-pane-constellation () + "make a vbox containing a scroller pane as its first child and an +info pane as its second child. The scroller pane contains a viewport +which contains an extended pane. Return the vbox and the extended pane +as two values" + (let* ((extended-pane + (make-pane 'extended-pane + :width 900 :height 400 + :name 'win + :incremental-redisplay t + :display-function 'display-win)) + (vbox + (vertically () + (scrolling () extended-pane) + (make-pane 'info-pane + :climacs-pane extended-pane + :width 900 :height 20 + :max-height 20 :min-height 20 + ::background +gray85+ + :scroll-bars nil + :borders nil + :incremental-redisplay t + :display-function 'display-info)))) + (values vbox extended-pane))) + (define-named-command com-split-window-vertically () (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) - (let* ((pane (current-window)) - (new-pane (make-pane 'extended-pane - :width 900 :height 400 - :name 'win - :incremental-redisplay t - :display-function 'display-win)) - (parent (sheet-parent (sheet-parent (sheet-parent pane))))) - (setf (buffer new-pane) (buffer pane)) - (sheet-adopt-child parent - (vertically () - (scrolling () new-pane) - (make-pane 'info-pane - :climacs-pane new-pane - :width 900 :height 20 - :max-height 20 :min-height 20 - ::background +gray85+ - :scroll-bars nil - :borders nil - :incremental-redisplay t - :display-function 'display-info))) - (setf (sheet-enabled-p new-pane) t) - (full-redisplay pane) - (full-redisplay new-pane)))) + (multiple-value-bind (vbox new-pane) (make-pane-constellation) + (let* ((current-window (current-window)) + (constellation-root (parent3 current-window))) + (setf (buffer new-pane) (buffer current-window)) + (push new-pane (windows *application-frame*)) + (replace-constellation constellation-root vbox t) + (full-redisplay current-window) + (full-redisplay new-pane))))) + +(define-named-command com-split-window-horizontally () + (with-look-and-feel-realization + ((frame-manager *application-frame*) *application-frame*) + (multiple-value-bind (vbox new-pane) (make-pane-constellation) + (let* ((current-window (current-window)) + (constellation-root (parent3 current-window))) + (setf (buffer new-pane) (buffer current-window)) + (push new-pane (windows *application-frame*)) + (replace-constellation constellation-root vbox nil) + (full-redisplay current-window) + (full-redisplay new-pane))))) + +(define-named-command com-other-window () + (setf (windows *application-frame*) + (append (cdr (windows *application-frame*)) + (list (car (windows *application-frame*)))))) + +(define-named-command com-delete-window () + (unless (null (cdr (windows *application-frame*))) + (let* ((constellation (parent3 (current-window))) + (box (sheet-parent constellation)) + (box-children (sheet-children box)) + (other (if (eq constellation (first box-children)) + (second box-children) + (first box-children))) + (parent (sheet-parent box)) + (children (sheet-children parent)) + (first (first children)) + (second (second children))) + (pop (windows *application-frame*)) + (sheet-disown-child box other) + (cond ((eq box first) + (sheet-disown-child parent box) + (sheet-adopt-child parent other) + (reorder-sheets parent (list other second))) + (t + (sheet-disown-child parent box) + (sheet-adopt-child parent other) + (reorder-sheets parent (list first other))))))) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands @@ -890,11 +966,14 @@ (add-command-to-command-table command 'c-x-climacs-table :keystroke gesture :errorp nil)) +(c-x-set-key '(#\0) 'com-delete-window) (c-x-set-key '(#\2) 'com-split-window-vertically) +(c-x-set-key '(#\3) 'com-split-window-horizontally) (c-x-set-key '(#\b) 'com-switch-to-buffer) (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\l :control) 'com-load-file) +(c-x-set-key '(#\o) 'com-other-window) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.5 climacs/pane.lisp:1.6 --- climacs/pane.lisp:1.5 Tue Jan 18 02:11:29 2005 +++ climacs/pane.lisp Tue Jan 18 21:21:16 2005 @@ -304,7 +304,7 @@ (beginning-of-line (point pane)) (empty-cache cache))))) -(defun display-cache (pane) +(defun display-cache (pane cursor-ink) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) (height (text-style-height style medium))) @@ -331,18 +331,18 @@ (draw-rectangle* pane (1- cursor-x) (- cursor-y (* 0.2 height)) (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink +red+))))) + :ink cursor-ink))))) -(defgeneric redisplay-pane (pane)) +(defgeneric redisplay-pane (pane current-p)) -(defmethod redisplay-pane ((pane climacs-pane)) +(defmethod redisplay-pane ((pane climacs-pane) current-p) (if (full-redisplay-p pane) (progn (reposition-window pane) (adjust-cache-size-and-bot pane) (setf (full-redisplay-p pane) nil)) (adjust-cache pane)) (fill-cache pane) - (display-cache pane)) + (display-cache pane (if current-p +red+ +blue+))) (defgeneric full-redisplay (pane))

1 0

[climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
by abakic＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv32053/Doc Modified Files: climacs-internals.texi Log Message: Rudi's change to delete-region (the relative order of marks should not matter) and one more related to insertions at the end of buffer. Date: Tue Jan 18 10:59:55 2005 Author: abakic Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.7 climacs/Doc/climacs-internals.texi:1.8 --- climacs/Doc/climacs-internals.texi:1.7 Fri Jan 7 22:04:21 2005 +++ climacs/Doc/climacs-internals.texi Tue Jan 18 10:59:54 2005 @@ -307,13 +307,12 @@ @deffn {Generic Function} {delete-region} mark1 mark2 -Delete the objects in the buffer that are after mark1 and before -mark2. An error is signaled if the two marks are positioned in -different buffers. If mark1 is positioned at an offset equal to or -greater than that of mark2, no objects are deleted. If objects are -to be deleted, this function calls delete-buffer-range with the -appropriate arguments. It is acceptable to pass an offset in place -of one of the marks. +Delete the objects in the buffer that are +between mark1 and 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. + +This function calls delete-buffer-range with the appropriate arguments. @end deffn @section Getting objects out of the buffer

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/buffer-test.lisp climacs/buffer.lisp climacs/gui.lisp
by abakic＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32053 Modified Files: base.lisp buffer-test.lisp buffer.lisp gui.lisp Log Message: Rudi's change to delete-region (the relative order of marks should not matter) and one more related to insertions at the end of buffer. Date: Tue Jan 18 10:59:52 2005 Author: abakic Index: climacs/base.lisp diff -u climacs/base.lisp:1.20 climacs/base.lisp:1.21 --- climacs/base.lisp:1.20 Tue Jan 18 05:53:28 2005 +++ climacs/base.lisp Tue Jan 18 10:59:51 2005 @@ -182,13 +182,13 @@ "Delete until the end of the word" (let ((mark2 (clone-mark mark))) (forward-word mark2) - (delete-range mark (- (offset mark2) (offset mark))))) + (delete-region mark mark2))) (defun backward-delete-word (mark) "Delete until the beginning of the word" (let ((mark2 (clone-mark mark))) (backward-word mark2) - (delete-range mark (- (offset mark2) (offset mark))))) + (delete-region mark mark2))) (defun previous-word (mark) "Return a freshly allocated sequence, that is word before the mark" Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.5 climacs/buffer-test.lisp:1.6 --- climacs/buffer-test.lisp:1.5 Sun Jan 16 09:58:13 2005 +++ climacs/buffer-test.lisp Tue Jan 18 10:59:51 2005 @@ -4,9 +4,9 @@ ;;; (cl:defpackage :climacs-tests - (:use :rtest :climacs-buffer #+cmu :cl)) + (:use :rtest :climacs-buffer :cl)) -(in-package :climacs-tests) +(cl:in-package :climacs-tests) (deftest standard-buffer-make-instance.test-1 (let* ((buffer (make-instance 'standard-buffer)) @@ -302,13 +302,13 @@ (m2 (make-instance 'standard-left-sticky-mark :buffer buffer :offset 5))) (delete-region m2 m) - (and (= (size buffer) 7) + (and (= (size buffer) 5) (eq (buffer m) buffer) (eq (buffer m2) buffer) (= (offset m) 3) - (= (offset m2) 5) - (buffer-sequence buffer 0 7)))) - "climacs") + (= (offset m2) 3) + (buffer-sequence buffer 0 5)))) + "clics") (deftest standard-buffer-delete-region.test-4 (let ((buffer (make-instance 'standard-buffer))) @@ -318,13 +318,13 @@ (m2 (make-instance 'standard-right-sticky-mark :buffer buffer :offset 5))) (delete-region m2 m) - (and (= (size buffer) 7) + (and (= (size buffer) 5) (eq (buffer m) buffer) (eq (buffer m2) buffer) (= (offset m) 3) - (= (offset m2) 5) - (buffer-sequence buffer 0 7)))) - "climacs") + (= (offset m2) 3) + (buffer-sequence buffer 0 5)))) + "clics") (deftest standard-buffer-delete-region.test-5 (handler-case Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.22 climacs/buffer.lisp:1.23 --- climacs/buffer.lisp:1.22 Tue Jan 18 02:11:29 2005 +++ climacs/buffer.lisp Tue Jan 18 10:59:51 2005 @@ -124,15 +124,9 @@ returned. Otherwise type is the name of a class (subclass of the mark class) to be used as a class of the clone.")) -(defmethod clone-mark ((mark standard-left-sticky-mark) &optional type) - (unless type - (setf type 'standard-left-sticky-mark)) - (make-instance type :buffer (buffer mark) :offset (offset mark))) - -(defmethod clone-mark ((mark standard-right-sticky-mark) &optional type) - (unless type - (setf type 'standard-right-sticky-mark)) - (make-instance type :buffer (buffer mark) :offset (offset mark))) +(defmethod clone-mark ((mark mark) &optional type) + (make-instance (or type (class-of mark)) + :buffer (buffer mark) :offset (offset mark))) (define-condition no-such-offset (simple-error) ((offset :reader condition-offset :initarg :offset)) @@ -392,32 +386,30 @@ (t nil))) (defgeneric delete-region (mark1 mark2) - (:documentation "Delete the objects in the buffer that are after mark1 and before -mark2. An error is signaled if the two marks are positioned in -different buffers. If mark1 is positioned at an offset equal to or -greater than that of mark2, no objects are deleted. If objects are -to be deleted, this function calls delete-buffer-range with the -appropriate arguments. It is acceptable to pass an offset in place -of one of the marks.")) + (:documentation "Delete the objects in the buffer that are +between mark1 and 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 delete-region ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) - (when (> (offset mark2) (offset mark1)) - (delete-buffer-range (buffer mark1) - (offset mark1) - (- (offset mark2) (offset mark1))))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1)))) (defmethod delete-region ((mark1 mark-mixin) offset2) - (when (> offset2 (offset mark1)) - (delete-buffer-range (buffer mark1) - (offset mark1) - (- offset2 (offset mark1))))) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1)))) (defmethod delete-region (offset1 (mark2 mark-mixin)) - (when (> (offset mark2) offset1) - (delete-buffer-range (buffer mark2) - offset1 - (- (offset mark2) offset1)))) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1)))) (defgeneric buffer-object (buffer offset) (:documentation "Return the object at the offset in the buffer. The first object Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.81 climacs/gui.lisp:1.82 --- climacs/gui.lisp:1.81 Mon Jan 17 22:55:47 2005 +++ climacs/gui.lisp Tue Jan 18 10:59:51 2005 @@ -340,10 +340,10 @@ ;; 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. - (when (progn (end-of-line point) - (end-of-buffer-p point)) + (end-of-line point) + (when (end-of-buffer-p point) (insert-object point #\Newline)) - (next-line point) + (next-line point 0) (insert-sequence point line) (insert-object point #\Newline))))

1 0

[climacs-cvs] CVS update: climacs/base.lisp
by rstrandh＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16261 Modified Files: base.lisp Log Message: Fixes for indent commands. (thanks to Rudi Schlatte) Date: Tue Jan 18 05:53:28 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.19 climacs/base.lisp:1.20 --- climacs/base.lisp:1.19 Mon Jan 17 15:10:23 2005 +++ climacs/base.lisp Tue Jan 18 05:53:28 2005 @@ -124,11 +124,14 @@ finally (return column)))) (defgeneric number-of-lines-in-region (mark1 mark2) - (:documentation "Return the number of lines (or rather the number of -Newline characters) in the region between MARK and MARK2. It is -acceptable to pass an offset in place of one of the marks")) + (:documentation "Return the number of lines (or rather the +number of Newline characters) in the region between MARK and +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 number-of-lines-in-region ((mark1 mark) (mark2 mark)) + (assert (eq (buffer mark1) (buffer mark2))) (buffer-number-of-lines-in-region (buffer mark1) (offset mark1) (offset mark2))) (defmethod number-of-lines-in-region ((offset integer) (mark mark)) @@ -177,21 +180,15 @@ (defun delete-word (mark) "Delete until the end of the word" - (loop until (end-of-buffer-p mark) - until (constituentp (object-after mark)) - do (delete-range mark)) - (loop until (end-of-buffer-p mark) - while (constituentp (object-after mark)) - do (delete-range mark))) + (let ((mark2 (clone-mark mark))) + (forward-word mark2) + (delete-range mark (- (offset mark2) (offset 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 (delete-range mark -1)) - (loop until (beginning-of-buffer-p mark) - while (constituentp (object-before mark)) - do (delete-range mark -1))) + (let ((mark2 (clone-mark mark))) + (backward-word mark2) + (delete-range mark (- (offset mark2) (offset mark))))) (defun previous-word (mark) "Return a freshly allocated sequence, that is word before the mark" @@ -388,10 +385,10 @@ (beginning-of-line mark) (unless (beginning-of-buffer-p mark) (loop until (end-of-buffer-p mark) - until (constituentp (object-after mark)) + while (whitespacep (object-after mark)) do (delete-range mark 1)) (loop until (beginning-of-buffer-p mark) - until (constituentp (object-before mark)) + while (whitespacep (object-before mark)) do (delete-range mark -1)) (insert-object mark #\Space)))

1 0