/[mcclim]/mcclim/Drei/delegating-buffer.lisp
ViewVC logotype

Contents of /mcclim/Drei/delegating-buffer.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sat Dec 8 08:53:50 2007 UTC (6 years, 4 months ago) by thenriksen
Branch: MAIN
CVS Tags: McCLIM-0-9-6, HEAD
Changes since 1.1: +60 -17 lines
Changed Drei to use a view-based paradigm, didn't make any significant
changes to ESA just yet.
1 ;;; -*- mode: lisp -*-
2 ;;;
3 ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic@yahoo.com)
4 ;;;
5
6 ;;; This library is free software; you can redistribute it and/or
7 ;;; modify it under the terms of the GNU Library General Public
8 ;;; License as published by the Free Software Foundation; either
9 ;;; version 2 of the License, or (at your option) any later version.
10 ;;;
11 ;;; This library is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 ;;; Library General Public License for more details.
15 ;;;
16 ;;; You should have received a copy of the GNU Library General Public
17 ;;; License along with this library; if not, write to the
18 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
19 ;;; Boston, MA 02111-1307 USA.
20
21 ;;; Buffer class that allows for specifying buffer implementation at run time.
22
23 (in-package :drei-buffer)
24
25 (defclass delegating-buffer (buffer)
26 ((%implementation :reader implementation
27 :initform (error "A delegating buffer must have an implementation")
28 :initarg :implementation))
29 (:documentation "Buffer class that delegates the buffer
30 protocol functionality to a buffer implementation object stored
31 in the `implementation' slot."))
32
33 (defmethod size ((buffer delegating-buffer))
34 (size (implementation buffer)))
35
36 (defmethod number-of-lines ((buffer delegating-buffer))
37 (number-of-lines (implementation buffer)))
38
39 (defmethod insert-buffer-object ((buffer delegating-buffer) offset object)
40 (insert-buffer-object (implementation buffer) offset object))
41
42 (defmethod insert-buffer-sequence ((buffer delegating-buffer) offset sequence)
43 (insert-buffer-sequence (implementation buffer) offset sequence))
44
45 (defmethod delete-buffer-range ((buffer delegating-buffer) offset n)
46 (delete-buffer-range (implementation buffer) offset n))
47
48 (defmethod buffer-object ((buffer delegating-buffer) offset)
49 (buffer-object (implementation buffer) offset))
50
51 (defmethod (setf buffer-object) (object (buffer delegating-buffer) offset)
52 (setf (buffer-object (implementation buffer) offset) object))
53
54 (defmethod buffer-sequence ((buffer delegating-buffer) offset1 offset2)
55 (buffer-sequence (implementation buffer) offset1 offset2))
56
57 (defmethod buffer-line-number ((buffer delegating-buffer) offset)
58 (buffer-line-number (implementation buffer) offset))
59
60 (defmethod buffer-column-number ((buffer delegating-buffer) offset)
61 (buffer-column-number (implementation buffer) offset))
62
63 (defclass delegating-mark (mark-mixin)
64 ((%implementation :reader implementation
65 :initform (error "A delegating mark must have an implementation")
66 :initarg :implementation))
67 (:documentation "Superclass for classes suitable for use in a
68 `delegating-buffer'."))
69
70 (defmethod offset ((mark delegating-mark))
71 (offset (implementation mark)))
72
73 (defmethod (setf offset) (new-value (mark delegating-mark))
74 (setf (offset (implementation mark)) new-value))
75
76 (defclass delegating-left-sticky-mark (left-sticky-mark delegating-mark)
77 ()
78 (:documentation "A `left-sticky-mark' subclass suitable for use
79 in a `delegating-buffer'."))
80
81 (defclass delegating-right-sticky-mark (right-sticky-mark delegating-mark)
82 ()
83 (:documentation "A `right-sticky-mark' subclass suitable for
84 use in a `delegating-buffer'."))
85
86 (defmethod clone-mark ((mark delegating-left-sticky-mark) &optional stick-to)
87 (cond ((or (null stick-to) (eq stick-to :left))
88 (make-instance 'delegating-left-sticky-mark
89 :implementation (clone-mark (implementation mark) :left)
90 :buffer (buffer mark)))
91 ((eq stick-to :right)
92 (make-instance 'delegating-right-sticky-mark
93 :implementation (clone-mark (implementation mark) :right)
94 :buffer (buffer mark)))
95 (t (error "invalid value for stick-to"))))
96
97 (defmethod clone-mark ((mark delegating-right-sticky-mark) &optional stick-to)
98 (cond ((or (null stick-to) (eq stick-to :right))
99 (make-instance 'delegating-right-sticky-mark
100 :implementation (clone-mark (implementation mark) :right)
101 :buffer (buffer mark)))
102 ((eq stick-to :left)
103 (make-instance 'delegating-left-sticky-mark
104 :implementation (clone-mark (implementation mark) :left)
105 :buffer (buffer mark)))
106 (t (error "invalid value for stick-to"))))
107
108 (defmethod make-buffer-mark ((buffer delegating-buffer)
109 &optional (offset 0) (stick-to :left))
110 (make-instance (ecase stick-to
111 (:left 'delegating-left-sticky-mark)
112 (:right 'delegating-right-sticky-mark))
113 :implementation (make-buffer-mark (implementation buffer)
114 offset stick-to)
115 :buffer buffer))

  ViewVC Help
Powered by ViewVC 1.1.5