Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv8063
Modified Files:
climacs.asd gui.lisp packages.lisp syntax.lisp
text-syntax.lisp
Added Files:
pane.lisp
Log Message:
Did a major overhaul of the syntax facility. The previous
functionality is now divided into three parts: the first one is the
real syntax, associated with the buffer instead of with the pane. The
second part is the cache management, now associated with the pane
instead of with the syntax. The third part is a CLIM view, associated
with the pane, which determines presentation parameters such as
highlighting.
modified the tabify/untabify code so that the space-width and
tab-width are no longer in the syntax, but in the view.
Factored out the climacs pane and displaying of text in the pane into
a new file, pane.lisp.
Date: Sat Jan 15 20:50:44 2005
Author: rstrandh
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.10 climacs/climacs.asd:1.11
--- climacs/climacs.asd:1.10 Fri Jan 14 14:07:39 2005
+++ climacs/climacs.asd Sat Jan 15 20:50:43 2005
@@ -58,6 +58,7 @@
"syntax"
"text-syntax"
"kill-ring"
+ "pane"
"gui")
#+asdf
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.69 climacs/gui.lisp:1.70
--- climacs/gui.lisp:1.69 Sat Jan 15 18:39:24 2005
+++ climacs/gui.lisp Sat Jan 15 20:50:43 2005
@@ -28,20 +28,8 @@
(in-package :climacs-gui)
-(defclass filename-mixin ()
- ((filename :initform nil :accessor filename)))
-
-(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)
- (point :initform nil :initarg :point :reader point)
- (syntax :initarg :syntax :accessor syntax)
- (mark :initform nil :initarg :mark :reader mark)
- ;; allows a certain number of commands to have some minimal memory
+(defclass extended-pane (climacs-pane)
+ (;; allows a certain number of commands to have some minimal memory
(previous-command :initform nil :accessor previous-command)
;; for next-line and previous-line commands
(goal-column :initform nil)
@@ -51,17 +39,6 @@
(dabbrev-expansion-mark :initform nil)
(overwrite-mode :initform nil)))
-(defmethod initialize-instance :after ((pane climacs-pane) &rest args)
- (declare (ignore args))
- (with-slots (buffer point syntax mark) pane
- (when (null point)
- (setf point (make-instance 'standard-right-sticky-mark
- :buffer buffer)))
- (when (null mark)
- (setf mark (make-instance 'standard-right-sticky-mark
- :buffer buffer)))
- (setf syntax (make-instance 'texinfo-syntax :pane pane))))
-
(defclass minibuffer-pane (application-pane) ())
(defmethod stream-accept :before ((pane minibuffer-pane) type &rest args)
@@ -71,7 +48,7 @@
(define-application-frame climacs ()
((win :reader win))
(:panes
- (win (make-pane 'climacs-pane
+ (win (make-pane 'extended-pane
:width 900 :height 400
:name 'win
:incremental-redisplay t
@@ -99,6 +76,11 @@
info)))
(:top-level (climacs-top-level)))
+(defmethod redisplay-frame-panes :before ((frame climacs) &rest args)
+ (declare (ignore args))
+ (let ((buffer (buffer (win frame))))
+ (update-syntax buffer (syntax buffer))))
+
(defmethod redisplay-frame-panes :after ((frame climacs) &rest args)
(declare (ignore args))
(clear-modify (buffer (win frame))))
@@ -117,7 +99,7 @@
(name-info (format nil " ~a ~a Syntax: ~a ~a"
(if (needs-saving buf) "**" "--")
(name buf)
- (name (syntax win))
+ (name (syntax buf))
(if (slot-value win 'overwrite-mode)
"Ovwrt"
""))))
@@ -242,10 +224,9 @@
(redisplay-frame-panes frame))))
(defun region-limits (pane)
- (with-slots (point mark) pane
- (if (< (offset mark) (offset point))
- (values mark point)
- (values point mark))))
+ (if (mark< (mark pane) (point pane))
+ (values (mark pane) (point pane))
+ (values (point pane) (mark pane))))
(defmacro define-named-command (command-name args &body body)
`(define-climacs-command ,(if (listp command-name)
@@ -419,12 +400,12 @@
(define-named-command com-tabify-region ()
(let ((pane (win *application-frame*)))
(multiple-value-bind (start end) (region-limits pane)
- (tabify-region start end (tab-space-count (syntax pane))))))
+ (tabify-region start end (tab-space-count (stream-default-view pane))))))
(define-named-command com-untabify-region ()
(let ((pane (win *application-frame*)))
(multiple-value-bind (start end) (region-limits pane)
- (untabify-region start end (tab-space-count (syntax pane))))))
+ (untabify-region start end (tab-space-count (stream-default-view pane))))))
(define-named-command com-toggle-layout ()
(setf (frame-current-layout *application-frame*)
@@ -518,20 +499,20 @@
(define-named-command com-find-file ()
(let ((filename (accept 'completable-pathname
- :prompt "Find File")))
- (with-slots (buffer point syntax) (win *application-frame*)
- (setf buffer (make-instance 'climacs-buffer)
- point (make-instance 'standard-right-sticky-mark :buffer buffer)
- syntax (make-instance 'texinfo-syntax :pane (win *application-frame*)))
- (with-open-file (stream filename :direction :input :if-does-not-exist :create)
- (input-from-stream stream buffer 0))
- (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*))))
+ :prompt "Find File"))
+ (buffer (make-instance 'climacs-buffer))
+ (pane (win *application-frame*)))
+ (setf (buffer (win *application-frame*)) 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))
+ (setf (filename buffer) filename
+ (name buffer) (pathname-filename filename)
+ (needs-saving buffer) nil)
+ (beginning-of-buffer (point pane))
+ ;; this one is needed so that the buffer modification protocol
+ ;; resets the low and high marks after redisplay
+ (redisplay-frame-panes *application-frame*)))
(define-named-command com-save-buffer ()
(let* ((buffer (buffer (win *application-frame*)))
@@ -569,11 +550,11 @@
(define-named-command com-page-down ()
(let ((pane (win *application-frame*)))
- (page-down pane (syntax pane))))
+ (page-down pane)))
(define-named-command com-page-up ()
(let ((pane (win *application-frame*)))
- (page-up pane (syntax pane))))
+ (page-up pane)))
(define-named-command com-end-of-buffer ()
(end-of-buffer (point (win *application-frame*))))
@@ -605,20 +586,19 @@
(accept 'url :prompt "Browse URL"))
(define-named-command com-set-mark ()
- (with-slots (point mark) (win *application-frame*)
- (setf mark (clone-mark point))))
+ (let ((pane (win *application-frame*)))
+ (setf (mark pane) (clone-mark (point pane)))))
(define-named-command com-exchange-point-and-mark ()
- (with-slots (point mark) (win *application-frame*)
- (psetf (offset mark) (offset point)
- (offset point) (offset mark))))
+ (let ((pane (win *application-frame*)))
+ (psetf (offset (mark pane)) (offset (point pane))
+ (offset (point pane)) (offset (mark pane)))))
(define-named-command com-set-syntax ()
(let* ((pane (win *application-frame*))
(buffer (buffer pane)))
- (setf (syntax (win *application-frame*))
- (make-instance (accept 'syntax :prompt "Set Syntax")
- :pane pane))
+ (setf (syntax buffer)
+ (make-instance (accept 'syntax :prompt "Set Syntax")))
(setf (offset (low-mark buffer)) 0
(offset (high-mark buffer)) (size buffer))))
@@ -637,9 +617,8 @@
;; Non destructively copies in buffer region to the kill ring
(define-named-command com-copy-out ()
- (with-slots (point mark)(win *application-frame*)
- (kill-ring-standard-push *kill-ring* (region-to-sequence point mark))))
-
+ (let ((pane (win *application-frame*)))
+ (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
(define-named-command com-rotate-yank ()
(let* ((pane (win *application-frame*))
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.31 climacs/packages.lisp:1.32
--- climacs/packages.lisp:1.31 Sat Jan 15 18:39:24 2005
+++ climacs/packages.lisp Sat Jan 15 20:50:43 2005
@@ -71,11 +71,8 @@
(defpackage :climacs-syntax
(:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain)
(:export #:syntax #:define-syntax
- #:tabify-mixin #:tab-space-count
- #:basic-syntax #:texinfo-syntax
- #:redisplay-pane #:redisplay-with-syntax #:full-redisplay
- #:page-down #:page-up
- #:url))
+ #:basic-syntax
+ #:update-syntax))
(defpackage :climacs-kill-ring
(:use :clim-lisp :flexichain)
@@ -83,6 +80,17 @@
#:reset-yank-position #:rotate-yank-position #:kill-ring-yank
#:kill-ring-standard-push #:kill-ring-concatenating-push))
+(defpackage :climacs-pane
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev
+ :climacs-syntax :flexichain)
+ (:export #:climacs-buffer #:needs-saving #:filename
+ #:climacs-pane #:point #:mark
+ #:redisplay-pane #:full-redisplay
+ #:page-down #:page-up
+ #:tab-space-count
+ #:url))
+
(defpackage :climacs-gui
- (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :climacs-kill-ring))
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax
+ :climacs-kill-ring :climacs-pane))
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.24 climacs/syntax.lisp:1.25
--- climacs/syntax.lisp:1.24 Sat Jan 15 18:39:24 2005
+++ climacs/syntax.lisp Sat Jan 15 20:50:43 2005
@@ -20,37 +20,11 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
-;;; A `syntax' is a CLOS object that determines how a buffer is to be
-;;; rendered. The `redisplay-with-syntax' functions are specialized
-;;; on the syntax.
-
(in-package :climacs-syntax)
(defclass syntax (name-mixin) ())
-(defgeneric redisplay-with-syntax (pane syntax))
-
-(defun redisplay-pane (pane)
- "redisplay the pane according to its syntax"
- (redisplay-with-syntax pane (syntax pane)))
-
-(defgeneric full-redisplay (pane syntax))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Tabify
-
-(defclass tabify-mixin ()
- ((space-width :initarg nil :reader space-width)
- (tab-width :initarg nil :reader tab-width)))
-
-(defgeneric tab-space-count (tabify))
-
-(defmethod tab-space-count (tabify)
- 1)
-
-(defmethod tab-space-count ((tabify tabify-mixin))
- (round (tab-width tabify) (space-width tabify)))
+(defgeneric update-syntax (buffer syntax))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -82,263 +56,8 @@
;;;
;;; Basic syntax
-(defun make-cache ()
- (let ((cache (make-instance 'standard-flexichain)))
- (insert* cache 0 nil)
- cache))
-
-(define-syntax basic-syntax ("Basic" (syntax tabify-mixin))
- ((top :reader top)
- (bot :reader bot)
- (scan :reader scan)
- (cursor-x :initform 2)
- (cursor-y :initform 2)
- (cache :initform (make-cache))))
-
-(defmethod initialize-instance :after ((syntax basic-syntax) &rest args &key pane)
- (declare (ignore args))
- (let ((buffer (buffer pane)))
- (with-slots (top bot scan space-width tab-width) syntax
- (setf top (make-instance 'standard-left-sticky-mark :buffer buffer)
- bot (make-instance 'standard-right-sticky-mark :buffer buffer))
- (let* ((medium (sheet-medium pane))
- (style (medium-text-style medium)))
- (setf space-width (text-style-width style medium)
- tab-width (* 8 space-width))))))
-
-(define-presentation-type url ()
- :inherit-from 'string)
-
-(defgeneric present-contents (contents pane syntax))
-
-(defmethod present-contents (contents pane (syntax basic-syntax))
- (unless (null contents)
- (present contents
- (if (and (>= (length contents) 7) (string= (subseq contents 0 7) "http://"))
- 'url
- 'string)
- :stream pane)))
-
-(defgeneric display-line (pane syntax line))
-
-(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-index)
- 0
- (* space-width (- index saved-index))))
- cursor-y y))
- 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 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))))))
-
-(defgeneric fill-cache (pane syntax)
- (:documentation "fill nil cache entries from the buffer"))
-
-(defmethod fill-cache (pane (syntax basic-syntax))
- (with-slots (top bot cache) syntax
- (let ((mark1 (clone-mark top))
- (mark2 (clone-mark top)))
- (loop for line from 0 below (nb-elements cache)
- do (beginning-of-line mark1)
- (end-of-line mark2)
- when (null (element* cache line))
- do (setf (element* cache line) (region-to-sequence mark1 mark2))
- unless (end-of-buffer-p mark2)
- do (setf (offset mark1) (1+ (offset mark2))
- (offset mark2) (offset mark1))))))
-
-(defun nb-lines-in-pane (pane)
- (let* ((medium (sheet-medium pane))
- (style (medium-text-style medium))
- (height (text-style-height style medium)))
- (multiple-value-bind (x y w h) (bounding-rectangle* pane)
- (declare (ignore x y w))
- (max 1 (floor h (+ height (stream-vertical-spacing pane)))))))
-
-;;; make the region on display fit the size of the pane as closely as
-;;; possible by adjusting bot leaving top intact. Also make the cache
-;;; size fit the size of the region on display.
-(defun adjust-cache-size-and-bot (pane syntax)
- (let ((nb-lines-in-pane (nb-lines-in-pane pane)))
- (with-slots (top bot cache) syntax
- (setf (offset bot) (offset top))
- (loop until (end-of-buffer-p bot)
- repeat (1- nb-lines-in-pane)
- do (forward-object bot)
- (end-of-line bot))
- (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot))))
- (loop repeat (- (nb-elements cache) nb-lines-on-display)
- do (pop-end cache))
- (loop repeat (- nb-lines-on-display (nb-elements cache))
- do (push-end cache nil))))))
-
-;;; put all-nil entries in the cache
-(defun empty-cache (cache)
- (loop for i from 0 below (nb-elements cache)
- do (setf (element* cache i) nil)))
-
-;;; empty the cache and try to put point close to the middle
-;;; of the pane by moving top half a pane-size up.
-(defun reposition-window (pane syntax)
- (let ((nb-lines-in-pane (nb-lines-in-pane pane)))
- (with-slots (top bot cache) syntax
- (empty-cache cache)
- (setf (offset top) (offset (point pane)))
- (loop do (beginning-of-line top)
- repeat (floor nb-lines-in-pane 2)
- until (beginning-of-buffer-p top)
- do (decf (offset top))
- (beginning-of-line top)))))
-
-;;; Make the cache reflect the contents of the buffer starting at top,
-;;; trying to preserve contents as much as possible, and inserting a
-;;; nil entry where buffer contents is unknonwn. The size of the
-;;; cache size at the end may be smaller than, equal to, or greater
-;;; than the number of lines in the pane.
-(defun adjust-cache (pane syntax)
- (let* ((buffer (buffer pane))
- (high-mark (high-mark buffer))
- (low-mark (low-mark buffer))
- (nb-lines-in-pane (nb-lines-in-pane pane)))
- (with-slots (top bot cache) syntax
- (beginning-of-line top)
- (end-of-line bot)
- (if (or (mark< (point pane) top)
- (>= (number-of-lines-in-region top (point pane)) nb-lines-in-pane)
- (and (mark< low-mark top)
- (>= (number-of-lines-in-region top high-mark) (nb-elements cache))))
- (reposition-window pane syntax)
- (when (mark>= high-mark low-mark)
- (let* ((n1 (number-of-lines-in-region top low-mark))
- (n2 (1+ (number-of-lines-in-region low-mark high-mark)))
- (n3 (number-of-lines-in-region high-mark bot))
- (diff (- (+ n1 n2 n3) (nb-elements cache))))
- (cond ((>= (+ n1 n2 n3) (+ (nb-elements cache) 20))
- (setf (offset bot) (offset top))
- (end-of-line bot)
- (loop for i from n1 below (nb-elements cache)
- do (setf (element* cache i) nil)))
- ((>= diff 0)
- (loop repeat diff do (insert* cache n1 nil))
- (loop for i from (+ n1 diff) below (+ n1 n2)
- do (setf (element* cache i) nil)))
- (t
- (loop repeat (- diff) do (delete* cache n1))
- (loop for i from n1 below (+ n1 n2)
- do (setf (element* cache i) nil)))))))))
- (adjust-cache-size-and-bot pane syntax))
-
-(defun page-down (pane syntax)
- (adjust-cache pane syntax)
- (with-slots (top bot cache) syntax
- (when (mark> (size (buffer bot)) bot)
- (empty-cache cache)
- (setf (offset top) (offset bot))
- (beginning-of-line top)
- (setf (offset (point pane)) (offset top)))))
-
-(defun page-up (pane syntax)
- (adjust-cache pane syntax)
- (with-slots (top bot cache) syntax
- (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
- while (> (offset top) 0)
- do (decf (offset top))
- (beginning-of-line top))
- (setf (offset (point pane)) (offset top))
- (adjust-cache pane syntax)
- (setf (offset (point pane)) (offset bot))
- (beginning-of-line (point pane))
- (empty-cache cache)))))
-
-(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
- (adjust-cache pane syntax)
- (fill-cache pane syntax)
- (loop with start-offset = (offset top)
- for id from 0 below (nb-elements cache)
- do (setf scan start-offset)
- (updating-output
- (pane :unique-id id
- :cache-value (if (<= start-offset
- (offset (point pane))
- (+ start-offset (length (element* cache id))))
- (cons nil nil)
- (element* cache id))
- :cache-test #'eq)
- (display-line pane syntax (element* cache id)))
- (incf start-offset (1+ (length (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-rectangle* pane
- (1- cursor-x) (- cursor-y (* 0.2 height))
- (+ cursor-x 2) (+ cursor-y (* 0.8 height))
- :ink +red+)))))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Texinfo syntax
-
-(define-syntax texinfo-syntax ("Texinfo" (basic-syntax)) ())
-
-(define-presentation-type texinfo-command ()
- :inherit-from 'string)
-
-(defmethod present-contents (contents pane (syntax texinfo-syntax))
- (unless (null contents)
- (if (char= (aref contents 0) #\@)
- (with-drawing-options (pane :ink +red+)
- (present contents 'texinfo-command :stream pane))
- (present contents 'string :stream pane))))
-
+(define-syntax basic-syntax ("Basic" (syntax))
+ ())
+(defmethod update-syntax (buffer (syntax basic-syntax))
+ nil)
Index: climacs/text-syntax.lisp
diff -u climacs/text-syntax.lisp:1.1 climacs/text-syntax.lisp:1.2
--- climacs/text-syntax.lisp:1.1 Fri Jan 14 14:07:39 2005
+++ climacs/text-syntax.lisp Sat Jan 15 20:50:43 2005
@@ -47,9 +47,8 @@
(define-syntax text-syntax ("Text" (basic-syntax))
((paragraphs :initform (make-instance 'standard-flexichain))))
-(defmethod redisplay-with-syntax :before (pane (syntax text-syntax))
- (let* ((buffer (buffer pane))
- (high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer)))
+(defmethod update-syntax (buffer (syntax text-syntax))
+ (let* ((high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer)))
(low-offset (max (- (offset (low-mark buffer)) 3) 0)))
(with-slots (paragraphs) syntax
(let* ((nb-paragraphs (nb-elements paragraphs))
