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

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

01 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28467 Modified Files: gui.lisp Log Message: Committed fix for bug found by Christophe Rhodes. Thanks. Date: Sat Jan 1 13:55:02 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.40 climacs/gui.lisp:1.41 --- climacs/gui.lisp:1.40 Sat Jan 1 11:43:39 2005 +++ climacs/gui.lisp Sat Jan 1 13:55:01 2005 @@ -264,7 +264,7 @@ (let ((item (accept 'command :prompt "Extended Command"))) (execute-frame-command *application-frame* item))) -(eval-when (:compile-toplevel) +(eval-when (:compile-toplevel :load-toplevel) (define-presentation-type completable-pathname () :inherit-from 'pathname))

1 0

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

01 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21597 Modified Files: syntax.lisp Log Message: minor stuff. Date: Sat Jan 1 11:49:27 2005 Author: rstrandh Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.16 climacs/syntax.lisp:1.17 --- climacs/syntax.lisp:1.16 Sat Jan 1 11:43:39 2005 +++ climacs/syntax.lisp Sat Jan 1 11:49:26 2005 @@ -238,8 +238,8 @@ (defun page-up (pane syntax) (position-window pane syntax) (with-slots (top bot cache) syntax - (let ((nb-lines-in-region (number-of-lines-in-region top bot))) - (when (> (offset top) 0) + (when (> (offset top) 0) + (let ((nb-lines-in-region (number-of-lines-in-region top bot))) (setf (offset bot) (offset top)) (end-of-line bot) (loop repeat nb-lines-in-region

1 0

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

01 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20869 Modified Files: gui.lisp packages.lisp syntax.lisp Log Message: Implemented page-down (M-v). Date: Sat Jan 1 11:43:39 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.39 climacs/gui.lisp:1.40 --- climacs/gui.lisp:1.39 Sat Jan 1 11:06:21 2005 +++ climacs/gui.lisp Sat Jan 1 11:43:39 2005 @@ -394,6 +394,10 @@ (let ((pane (win *application-frame*))) (page-down pane (syntax pane)))) +(define-named-command com-page-up () + (let ((pane (win *application-frame*))) + (page-up pane (syntax pane)))) + (define-named-command com-end-of-buffer () (end-of-buffer (point (win *application-frame*)))) @@ -508,6 +512,7 @@ (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only (global-set-key '(#\w :meta) 'com-copy-out) (global-set-key '(#\v :control) 'com-page-down) +(global-set-key '(#\v :meta) 'com-page-up) (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) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.18 climacs/packages.lisp:1.19 --- climacs/packages.lisp:1.18 Sat Jan 1 11:06:21 2005 +++ climacs/packages.lisp Sat Jan 1 11:43:39 2005 @@ -60,7 +60,7 @@ (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:basic-syntax #:texinfo-syntax #:redisplay-pane #:redisplay-with-syntax #:full-redisplay - #:page-down + #:page-down #:page-up #:url)) (defpackage :climacs-kill-ring Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.15 climacs/syntax.lisp:1.16 --- climacs/syntax.lisp:1.15 Sat Jan 1 11:06:21 2005 +++ climacs/syntax.lisp Sat Jan 1 11:43:39 2005 @@ -199,7 +199,6 @@ (declare (ignore x y w)) (let ((nb-lines-in-pane (max 1 (floor h (+ height (stream-vertical-spacing pane))))) (nb-lines-on-display (1+ (number-of-lines-in-region top bot)))) - (format *query-io* "~a ~a~%" (offset top) (offset bot)) ;; adjust the region on display to fit the pane (loop repeat (- nb-lines-on-display nb-lines-in-pane) do (beginning-of-line bot) @@ -235,6 +234,23 @@ (beginning-of-line top) (setf (offset (point pane)) (offset top)) (setf cache nil)))) + +(defun page-up (pane syntax) + (position-window pane syntax) + (with-slots (top bot cache) syntax + (let ((nb-lines-in-region (number-of-lines-in-region top bot))) + (when (> (offset top) 0) + (setf (offset bot) (offset top)) + (end-of-line bot) + (loop repeat nb-lines-in-region + while (> (offset top) 0) + do (decf (offset top)) + (beginning-of-line top)) + (setf (offset (point pane)) (offset top)) + (position-window pane syntax) + (setf (offset (point pane)) (offset bot)) + (beginning-of-line (point pane)) + (setf cache nil))))) ;;; this one should not be necessary. (defun round-up (x)

1 0

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

01 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19337 Modified Files: gui.lisp packages.lisp syntax.lisp Log Message: Implemented page-down (C-v). Date: Sat Jan 1 11:06:22 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.38 climacs/gui.lisp:1.39 --- climacs/gui.lisp:1.38 Sat Jan 1 10:34:25 2005 +++ climacs/gui.lisp Sat Jan 1 11:06:21 2005 @@ -390,6 +390,10 @@ (define-named-command com-beginning-of-buffer () (beginning-of-buffer (point (win *application-frame*)))) +(define-named-command com-page-down () + (let ((pane (win *application-frame*))) + (page-down pane (syntax pane)))) + (define-named-command com-end-of-buffer () (end-of-buffer (point (win *application-frame*)))) @@ -503,6 +507,7 @@ (global-set-key '(#\x :meta) 'com-extended-command) (global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only (global-set-key '(#\w :meta) 'com-copy-out) +(global-set-key '(#\v :control) 'com-page-down) (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) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.17 climacs/packages.lisp:1.18 --- climacs/packages.lisp:1.17 Sat Jan 1 10:34:25 2005 +++ climacs/packages.lisp Sat Jan 1 11:06:21 2005 @@ -60,6 +60,7 @@ (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:basic-syntax #:texinfo-syntax #:redisplay-pane #:redisplay-with-syntax #:full-redisplay + #:page-down #:url)) (defpackage :climacs-kill-ring Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.14 climacs/syntax.lisp:1.15 --- climacs/syntax.lisp:1.14 Sat Jan 1 10:34:25 2005 +++ climacs/syntax.lisp Sat Jan 1 11:06:21 2005 @@ -199,6 +199,7 @@ (declare (ignore x y w)) (let ((nb-lines-in-pane (max 1 (floor h (+ height (stream-vertical-spacing pane))))) (nb-lines-on-display (1+ (number-of-lines-in-region top bot)))) + (format *query-io* "~a ~a~%" (offset top) (offset bot)) ;; adjust the region on display to fit the pane (loop repeat (- nb-lines-on-display nb-lines-in-pane) do (beginning-of-line bot) @@ -226,6 +227,14 @@ do (incf (offset bot)) (end-of-line bot)))))))) +(defun page-down (pane syntax) + (position-window pane syntax) + (with-slots (top bot cache) syntax + (when (mark> (size (buffer bot)) bot) + (setf (offset top) (offset bot)) + (beginning-of-line top) + (setf (offset (point pane)) (offset top)) + (setf cache nil)))) ;;; this one should not be necessary. (defun round-up (x)

1 0

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

01 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv17852 Modified Files: base.lisp gui.lisp packages.lisp syntax.lisp Log Message: Factored aspects of named objects (currently buffers and syntaxes) into a syntax-mixin class in base.lisp. Updated packages.lisp accordingly. Implemented syntax completion (i.e., the possibility to use CLIM completion to determine the name of a syntax). I Implemented an extended command "Set Syntax" using the completion. Currently, it does not invalidate the CLIM output history, because I need to think a bit more about how to do that properly. Date: Sat Jan 1 10:34:26 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.8 climacs/base.lisp:1.9 --- climacs/base.lisp:1.8 Thu Dec 30 06:28:21 2004 +++ climacs/base.lisp Sat Jan 1 10:34:25 2005 @@ -135,3 +135,12 @@ while (constituentp (object-before mark)) do (delete-range mark -1))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Named objects + +(defgeneric name (obj)) + +(defclass name-mixin () + ((name :initarg :name :accessor name))) + Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.37 climacs/gui.lisp:1.38 --- climacs/gui.lisp:1.37 Fri Dec 31 14:33:06 2004 +++ climacs/gui.lisp Sat Jan 1 10:34:25 2005 @@ -27,9 +27,10 @@ (defclass filename-mixin () ((filename :initform nil :accessor filename))) -(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin) - ((name :initform "*scratch*" :accessor name) - (needs-saving :initform nil :accessor needs-saving))) +(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin) + ((needs-saving :initform nil :accessor needs-saving)) + (:default-initargs :name "*scratch*")) + (defclass climacs-pane (application-pane) ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) @@ -94,9 +95,10 @@ (defun display-info (frame pane) (let* ((win (win frame)) (buf (buffer win)) - (name-info (format nil " ~a ~a" + (name-info (format nil " ~a ~a Syntax: ~a" (if (needs-saving buf) "**" "--") - (name buf)))) + (name buf) + (name (syntax win))))) (princ name-info pane))) (defun display-win (frame pane) @@ -420,6 +422,11 @@ (define-named-command com-set-mark () (with-slots (point mark) (win *application-frame*) (setf mark (clone-mark point)))) + +(define-named-command com-set-syntax () + (setf (syntax (win *application-frame*)) + (make-instance (accept 'syntax :prompt "Set Syntax") + :pane (win *application-frame*)))) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.16 climacs/packages.lisp:1.17 --- climacs/packages.lisp:1.16 Fri Dec 31 14:33:06 2004 +++ climacs/packages.lisp Sat Jan 1 10:34:25 2005 @@ -48,7 +48,8 @@ #:constituentp #:whitespacep #:forward-word #:backward-word #:delete-word #:backward-delete-word - #:input-from-stream #:output-to-stream)) + #:input-from-stream #:output-to-stream + #:name-mixin #:name)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.13 climacs/syntax.lisp:1.14 --- climacs/syntax.lisp:1.13 Fri Dec 31 14:33:06 2004 +++ climacs/syntax.lisp Sat Jan 1 10:34:25 2005 @@ -24,7 +24,7 @@ (in-package :climacs-syntax) -(defclass syntax () ()) +(defclass syntax (name-mixin) ()) (defgeneric redisplay-with-syntax (pane syntax)) @@ -34,7 +34,37 @@ (defgeneric full-redisplay (pane syntax)) -(defclass basic-syntax (syntax) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Syntax completion + +(defparameter *syntaxes* '()) + +(defmacro define-syntax (class-name (name superclasses) &body body) + `(progn (push '(,name . ,class-name) *syntaxes*) + (defclass ,class-name ,superclasses + ,@body + (:default-initargs :name ,name)))) + +(define-presentation-method accept + ((type syntax) stream (view textual-view) &key) + (multiple-value-bind (pathname success string) + (complete-input stream + (lambda (so-far action) + (complete-from-possibilities + so-far *syntaxes* '() :action action + :name-key #'car + :value-key #'cdr)) + :partial-completers '(#\Space) + :allow-any-input t) + (declare (ignore success)) + (or pathname string))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Basic syntax + +(define-syntax basic-syntax ("Basic" (syntax)) ((top :reader top) (bot :reader bot) (scan :reader scan) @@ -58,6 +88,8 @@ (define-presentation-type url () :inherit-from 'string) +(defgeneric present-contents (contenst pane syntax)) + (defmethod present-contents (contents pane (syntax basic-syntax)) (unless (null contents) (present contents @@ -66,6 +98,8 @@ 'string) :stream pane))) +(defgeneric display-line (pane syntax line)) + (defmethod display-line (pane (syntax basic-syntax) line) (let ((saved-index nil) (id 0)) @@ -117,6 +151,8 @@ (terpri pane) (incf scan)))))) +(defgeneric compute-cache (pane syntax)) + (defmethod compute-cache (pane (syntax basic-syntax)) (with-slots (top bot cache) syntax (let* ((buffer (buffer pane)) @@ -225,7 +261,7 @@ ;;; ;;; Texinfo syntax -(defclass texinfo-syntax (basic-syntax) ()) +(define-syntax texinfo-syntax ("Texinfo" (basic-syntax)) ()) (define-presentation-type texinfo-command () :inherit-from 'string) @@ -236,4 +272,5 @@ (with-drawing-options (pane :ink +red+) (present contents 'texinfo-command :stream pane)) (present contents 'string :stream pane)))) +

1 0

[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