Commit 81970993 authored by Aleksandar Bakic's avatar Aleksandar Bakic

package.lisp, pane.lisp: Added delegation-buffer class, allowing for

dynamic buffer implementation choices. Modified climacs-buffer
accordingly and added two extended buffer implementation classes and a
few methods delegating undo and syntax functionality. Removed
hard-coded uses of standard-buffer and standard mark classes. Modified
:buffer arguments to syntax creation to make sure they are buffer
implementations.

gui.lisp: Removed obsolete region-limits. Modified :buffer arguments
to syntax creation to make sure they are buffer
implementations. Removed hard-coded uses of standard-buffer and
standard mark classes.

kill-ring.lisp: Fixed parameter order in (setf kill-ring-max-size).

buffer-test.lisp, base-test.lisp: Added tests for
delegating-standard-buffer. Replaced all but two mark instantiations
with calls to clone-mark.
parent cd4a450b
This diff is collapsed.
This diff is collapsed.
......@@ -65,6 +65,7 @@
"cl-syntax"
"kill-ring"
"undo"
"delegating-buffer"
"pane"
"gui"
;;---- optional ----
......
......@@ -346,11 +346,6 @@
,@end-clauses))
(redisplay-frame-panes *application-frame*)))))
(defun region-limits (pane)
(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)
`(,@command-name :name t)
......@@ -546,13 +541,13 @@
(define-named-command com-tabify-region ()
(let ((pane (current-window)))
(multiple-value-bind (start end) (region-limits pane)
(tabify-region start end (tab-space-count (stream-default-view pane))))))
(tabify-region
(mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
(define-named-command com-untabify-region ()
(let ((pane (current-window)))
(multiple-value-bind (start end) (region-limits pane)
(untabify-region start end (tab-space-count (stream-default-view pane))))))
(untabify-region
(mark pane) (point pane) (tab-space-count (stream-default-view pane)))))
(defun indent-current-line (pane point)
(let* ((buffer (buffer pane))
......@@ -698,7 +693,8 @@
(pane (current-window)))
(push buffer (buffers *application-frame*))
(setf (buffer (current-window)) buffer)
(setf (syntax buffer) (make-instance 'basic-syntax :buffer buffer))
(setf (syntax buffer) (make-instance
'basic-syntax :buffer (buffer (point pane))))
;; Don't want to create the file if it doesn't exist.
(when (probe-file filename)
(with-open-file (stream filename :direction :input)
......@@ -775,11 +771,13 @@
(define-named-command com-switch-to-buffer ()
(let ((buffer (accept 'buffer
:prompt "Switch to buffer")))
(setf (buffer (current-window)) buffer)
(setf (syntax buffer) (make-instance 'basic-syntax :buffer buffer))
(beginning-of-buffer (point (current-window)))
(full-redisplay (current-window))))
:prompt "Switch to buffer"))
(pane (current-window)))
(setf (buffer pane) buffer)
(setf (syntax buffer) (make-instance
'basic-syntax :buffer (buffer (point pane))))
(beginning-of-buffer (point pane))
(full-redisplay pane)))
(define-named-command com-kill-buffer ()
(with-slots (buffers) *application-frame*
......@@ -834,8 +832,11 @@
(return-from com-goto-position nil))))))
(define-named-command com-goto-line ()
(loop with mark = (make-instance 'standard-right-sticky-mark ;PB
:buffer (buffer (current-window)))
(loop with mark = (let ((m (clone-mark
(low-mark (buffer (current-window)))
:right)))
(beginning-of-buffer m)
m)
do (end-of-line mark)
until (end-of-buffer-p mark)
repeat (handler-case (accept 'integer :prompt "Goto Line")
......@@ -868,7 +869,7 @@
(progn (beep)
(display-message "No such syntax")
(return-from com-set-syntax nil)))
:buffer buffer))
:buffer (buffer (point pane))))
(setf (offset (low-mark buffer)) 0
(offset (high-mark buffer)) (size buffer))))
......@@ -1021,9 +1022,10 @@ as two values"
;; Destructively cut a given buffer region into the kill-ring
(define-named-command com-cut-out ()
(multiple-value-bind (start end) (region-limits (current-window))
(kill-ring-standard-push *kill-ring* (region-to-sequence start end))
(delete-region (offset start) end)))
(let ((pane (current-window)))
(kill-ring-standard-push
*kill-ring* (region-to-sequence (mark pane) (point pane)))
(delete-region (mark pane) (point pane))))
;; Non destructively copies in buffer region to the kill ring
(define-named-command com-copy-out ()
......
......@@ -87,7 +87,7 @@ is reached."))
(with-slots (max-size) kr
max-size))
(defmethod (setf kill-ring-max-size) ((kr kill-ring) size)
(defmethod (setf kill-ring-max-size) (size (kr kill-ring))
(unless (typep size 'integer)
(error "Error, ~S, is not an integer value" size))
(if (< size 5)
......
......@@ -48,7 +48,9 @@
#:low-mark #:high-mark #:modified-p #:clear-modify
#:binseq-buffer #:obinseq-buffer
#:persistent-left-sticky-mark #:persistent-right-sticky-mark))
#:persistent-left-sticky-mark #:persistent-right-sticky-mark
#:delegating-buffer #:implementation))
(defpackage :climacs-base
(:use :clim-lisp :climacs-buffer)
......
......@@ -135,6 +135,23 @@
(mapc #'flip-undo-record records)
(setf records (nreverse records))))
;;; undo-mixin delegation (here because of the package)
(defmethod undo-tree ((buffer delegating-buffer))
(undo-tree (implementation buffer)))
(defmethod undo-accumulate ((buffer delegating-buffer))
(undo-accumulate (implementation buffer)))
(defmethod (setf undo-accumulate) (object (buffer delegating-buffer))
(setf (undo-accumulate (implementation buffer)) object))
(defmethod performing-undo ((buffer delegating-buffer))
(performing-undo (implementation buffer)))
(defmethod (setf performing-undo) (object (buffer delegating-buffer))
(setf (performing-undo (implementation buffer)) object))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Isearch
......@@ -165,17 +182,36 @@
;(defgeneric indent-tabs-mode (climacs-buffer))
(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin) ;PB
;;; syntax delegation
(defmethod update-syntax ((buffer delegating-buffer) syntax)
(update-syntax (implementation buffer) syntax))
(defmethod update-syntax-for-redisplay ((buffer delegating-buffer) syntax from to)
(update-syntax-for-redisplay (implementation buffer) syntax from to))
;;; buffers
(defclass extended-standard-buffer (standard-buffer undo-mixin abbrev-mixin) ()
(:documentation "Extensions accessible via marks."))
(defclass extended-obinseq-buffer (obinseq-buffer undo-mixin abbrev-mixin) ()
(:documentation "Extensions accessible via marks."))
(defclass climacs-buffer (delegating-buffer filename-mixin name-mixin)
((needs-saving :initform nil :accessor needs-saving)
(syntax :accessor syntax)
(indent-tabs-mode :initarg indent-tabs-mode :initform t
:accessor indent-tabs-mode))
(:default-initargs :name "*scratch*"))
(:default-initargs
:name "*scratch*"
:implementation (make-instance 'extended-standard-buffer)))
(defmethod initialize-instance :after ((buffer climacs-buffer) &rest args)
(declare (ignore args))
(with-slots (syntax) buffer
(setf syntax (make-instance 'basic-syntax :buffer buffer))))
(setf syntax (make-instance
'basic-syntax :buffer (implementation buffer)))))
(defclass climacs-pane (application-pane)
((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
......@@ -210,14 +246,12 @@
(declare (ignore args))
(with-slots (buffer point mark) pane
(when (null point)
(setf point (make-instance 'standard-right-sticky-mark ;PB
:buffer buffer)))
(setf point (clone-mark (low-mark buffer) :right)))
(when (null mark)
(setf mark (make-instance 'standard-right-sticky-mark ;PB
:buffer buffer))))
(setf mark (clone-mark (low-mark buffer) :right))))
(with-slots (buffer top bot scan) pane
(setf top (make-instance 'standard-left-sticky-mark :buffer buffer) ;PB
bot (make-instance 'standard-right-sticky-mark :buffer buffer))) ;PB
(setf top (clone-mark (low-mark buffer) :left)
bot (clone-mark (high-mark buffer) :right)))
(setf (stream-default-view pane) (make-instance 'climacs-textual-view))
(with-slots (space-width tab-width) (stream-default-view pane)
(let* ((medium (sheet-medium pane))
......@@ -227,12 +261,10 @@
(defmethod (setf buffer) :after (buffer (pane climacs-pane))
(with-slots (point mark top bot) pane
(setf point (make-instance 'standard-right-sticky-mark ;PB
:buffer buffer)
mark (make-instance 'standard-right-sticky-mark ;PB
:buffer buffer)
top (make-instance 'standard-left-sticky-mark :buffer buffer) ;PB
bot (make-instance 'standard-right-sticky-mark :buffer buffer)))) ;PB
(setf point (clone-mark (low-mark (implementation buffer)) :right)
mark (clone-mark (low-mark (implementation buffer)) :right)
top (clone-mark (low-mark (implementation buffer)) :left)
bot (clone-mark (high-mark (implementation buffer)) :right))))
(define-presentation-type url ()
:inherit-from 'string)
......@@ -470,4 +502,4 @@
(defgeneric full-redisplay (pane))
(defmethod full-redisplay ((pane climacs-pane))
(setf (full-redisplay-p pane) t))
\ No newline at end of file
(setf (full-redisplay-p pane) t))
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment