From rstrandh at common-lisp.net Wed Feb 2 07:59:43 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Wed, 2 Feb 2005 08:59:43 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/climacs.asd climacs/gui.lisp
climacs/packages.lisp climacs/pane.lisp climacs/syntax.lisp
Message-ID: <20050202075943.89F898802C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv19199
Modified Files:
climacs.asd gui.lisp packages.lisp pane.lisp syntax.lisp
Log Message:
Fixed the display-message function so that it actually displays a message
in the minibuffer.
Implemented an incremental Earley parser for the syntax module.
Date: Wed Feb 2 08:59:41 2005
Author: rstrandh
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.16 climacs/climacs.asd:1.17
--- climacs/climacs.asd:1.16 Wed Jan 26 17:10:40 2005
+++ climacs/climacs.asd Wed Feb 2 08:59:41 2005
@@ -61,6 +61,7 @@
"abbrev"
"syntax"
"text-syntax"
+ "html-syntax"
"kill-ring"
"undo"
"pane"
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.105 climacs/gui.lisp:1.106
--- climacs/gui.lisp:1.105 Sun Jan 30 23:17:30 2005
+++ climacs/gui.lisp Wed Feb 2 08:59:41 2005
@@ -77,6 +77,7 @@
info-pane)))
(int (make-pane 'minibuffer-pane
:width 900 :height 20 :max-height 20 :min-height 20
+ :display-function 'display-minibuffer
:scroll-bars nil)))
(:layouts
(default
@@ -85,6 +86,18 @@
int)))
(:top-level (climacs-top-level)))
+(defparameter *message* nil)
+
+(defun display-message (format-string &rest format-args)
+ (setf *message*
+ (apply #'format nil format-string format-args)))
+
+(defun display-minibuffer (frame pane)
+ (declare (ignore frame))
+ (unless (null *message*)
+ (princ *message* pane)
+ (setf *message* nil)))
+
(defmacro current-window () ; shouldn't this be an inlined function? --amb
`(car (windows *application-frame*)))
@@ -107,9 +120,6 @@
(let ((frame (make-application-frame 'climacs)))
(run-frame-top-level frame)))
-(defun display-message (format-string &rest format-args)
- (apply #'format *standard-input* format-string format-args))
-
(defun display-info (frame pane)
(declare (ignore frame))
(with-slots (climacs-pane) pane
@@ -649,7 +659,7 @@
(pane (current-window)))
(push buffer (buffers *application-frame*))
(setf (buffer (current-window)) buffer)
- (setf (syntax buffer) (make-instance 'basic-syntax))
+ (setf (syntax buffer) (make-instance 'basic-syntax :buffer buffer))
;; Don't want to create the file if it doesn't exist.
(when (probe-file filename)
(with-open-file (stream filename :direction :input)
@@ -722,7 +732,7 @@
(let ((buffer (accept 'buffer
:prompt "Switch to buffer")))
(setf (buffer (current-window)) buffer)
- (setf (syntax buffer) (make-instance 'basic-syntax))
+ (setf (syntax buffer) (make-instance 'basic-syntax :buffer buffer))
(beginning-of-buffer (point (current-window)))
(full-redisplay (current-window))))
@@ -800,7 +810,8 @@
(let* ((pane (current-window))
(buffer (buffer pane)))
(setf (syntax buffer)
- (make-instance (accept 'syntax :prompt "Set Syntax")))
+ (make-instance (accept 'syntax :prompt "Set Syntax")
+ :buffer buffer))
(setf (offset (low-mark buffer)) 0
(offset (high-mark buffer)) (size buffer))))
@@ -1242,6 +1253,18 @@
(point (point pane))
(syntax (syntax (buffer pane))))
(end-of-paragraph point syntax)))
+
+(define-named-command com-backward-to-error ()
+ (let* ((pane (current-window))
+ (point (point pane))
+ (syntax (syntax (buffer pane))))
+ (display-message "~a" (backward-to-error point syntax))))
+
+(define-named-command com-forward-to-error ()
+ (let* ((pane (current-window))
+ (point (point pane))
+ (syntax (syntax (buffer pane))))
+ (display-message "~a" (forward-to-error point syntax))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.44 climacs/packages.lisp:1.45
--- climacs/packages.lisp:1.44 Sun Jan 30 23:17:31 2005
+++ climacs/packages.lisp Wed Feb 2 08:59:41 2005
@@ -86,7 +86,8 @@
#:basic-syntax
#:update-syntax
#:syntax-line-indentation
- #:beginning-of-paragraph #:end-of-paragraph))
+ #:beginning-of-paragraph #:end-of-paragraph
+ #:forward-to-error #:backward-to-error))
(defpackage :climacs-kill-ring
(:use :clim-lisp :flexichain)
Index: climacs/pane.lisp
diff -u climacs/pane.lisp:1.16 climacs/pane.lisp:1.17
--- climacs/pane.lisp:1.16 Sun Jan 30 23:17:31 2005
+++ climacs/pane.lisp Wed Feb 2 08:59:41 2005
@@ -167,11 +167,15 @@
(defclass climacs-buffer (standard-buffer abbrev-mixin filename-mixin name-mixin undo-mixin) ;PB
((needs-saving :initform nil :accessor needs-saving)
- (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax)
+ (syntax :accessor syntax)
(indent-tabs-mode :initarg indent-tabs-mode :initform t
:accessor indent-tabs-mode))
(:default-initargs :name "*scratch*"))
+(defmethod initialize-instance :after ((buffer climacs-buffer) &rest args)
+ (declare (ignore args))
+ (with-slots (syntax) buffer
+ (setf syntax (make-instance 'basic-syntax :buffer buffer))))
(defclass climacs-pane (application-pane)
((buffer :initform (make-instance 'climacs-buffer) :accessor buffer)
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.28 climacs/syntax.lisp:1.29
--- climacs/syntax.lisp:1.28 Tue Jan 18 00:10:24 2005
+++ climacs/syntax.lisp Wed Feb 2 08:59:41 2005
@@ -22,7 +22,8 @@
(in-package :climacs-syntax)
-(defclass syntax (name-mixin) ())
+(defclass syntax (name-mixin)
+ ((buffer :initarg :buffer)))
(defgeneric update-syntax (buffer syntax))
@@ -70,3 +71,217 @@
(defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax))
(declare (ignore mark tab-width))
0)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Incremental Earley parser
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; grammar
+
+(defclass rule ()
+ ((left-hand-side :initarg :left-hand-side :reader left-hand-side)
+ (right-hand-side :initarg :right-hand-side :reader right-hand-side)
+ (symbols :initarg :symbols :reader symbols)))
+
+(defclass grammar ()
+ ((rules :initarg :rules :reader rules)))
+
+(defmacro grammar (&body body)
+ (labels ((var-of (arg)
+ (if (symbolp arg)
+ arg
+ (car arg)))
+ (sym-of (arg)
+ (cond ((symbolp arg) arg)
+ ((= (length arg) 3) (cadr arg))
+ ((symbolp (cadr arg)) (cadr arg))
+ (t (car arg))))
+ (test-of (arg)
+ (cond ((symbolp arg) t)
+ ((= (length arg) 3) (caddr arg))
+ ((symbolp (cadr arg)) t)
+ (t (cadr arg))))
+ (build-rule (arglist body)
+ (if (null arglist)
+ body
+ (let ((arg (car arglist)))
+ `(lambda (,(var-of arg))
+ (when (and (typep ,(var-of arg) ',(sym-of arg))
+ ,(test-of arg))
+ ,(build-rule (cdr arglist) body))))))
+ (make-rule (rule)
+ `(make-instance 'rule
+ :left-hand-side ',(car rule)
+ :right-hand-side
+ ,(build-rule (caddr rule)
+ (if (or (= (length rule) 3)
+ (symbolp (cadddr rule)))
+ `(make-instance ',(car rule) ,@(cdddr rule))
+ `(progn ,@(cdddr rule))))
+ :symbols ,(coerce (mapcar #'sym-of (caddr rule)) 'vector))))
+ `(make-instance 'grammar
+ :rules (list ,@(mapcar #'make-rule body)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; parser
+
+(defclass parser ()
+ ((grammar :initarg :grammar)
+ (target :initarg :target :reader target)
+ (initial-state :reader initial-state)
+ (lexer :initarg :lexer)))
+
+(defclass rule-item () ())
+
+(defclass incomplete-item (rule-item)
+ ((rule :initarg :rule :reader rule)
+ (dot-position :initarg :dot-position :reader dot-position)
+ (parse-trees :initarg :parse-trees :reader parse-trees)
+ (suffix :initarg :suffix :reader suffix)))
+
+(defmethod print-object ((item incomplete-item) stream)
+ (format stream "[~a ->" (left-hand-side (rule item)))
+ (loop for i from 0 below (dot-position item)
+ do (format stream " ~a" (aref (symbols (rule item)) i)))
+ (format stream " *")
+ (loop for i from (dot-position item) below (length (symbols (rule item)))
+ do (format stream " ~a" (aref (symbols (rule item)) i)))
+ (format stream "]"))
+
+(defclass complete-item (rule-item)
+ ((parse-tree :initarg :parse-tree :reader parse-tree)))
+
+(defmethod print-object ((item complete-item) stream)
+ (format stream "[~a]" (parse-tree item)))
+
+(defgeneric derive-item (prev-item parse-tree))
+
+(defmethod derive-item ((prev-item incomplete-item) parse-tree)
+ (let ((remaining (funcall (suffix prev-item) parse-tree)))
+ (cond ((null remaining)
+ nil)
+ ((functionp remaining)
+ (make-instance 'incomplete-item
+ :rule (rule prev-item)
+ :dot-position (1+ (dot-position prev-item))
+ :parse-trees (cons parse-tree (parse-trees prev-item))
+ :suffix remaining))
+ (t
+ (make-instance 'complete-item
+ :parse-tree remaining)))))
+
+(defgeneric item-equal (item1 item2))
+
+(defgeneric parse-tree-equal (tree1 tree2))
+
+(defmethod item-equal ((item1 rule-item) (item2 rule-item))
+ nil)
+
+(defmethod item-equal ((item1 incomplete-item) (item2 incomplete-item))
+ (and (eq (rule item1) (rule item2))
+ (eq (length (parse-trees item1)) (length (parse-trees item2)))
+ (every #'parse-tree-equal (parse-trees item1) (parse-trees item2))))
+
+(defmethod parse-tree-equal (tree1 tree2)
+ (eq (class-of tree1) (class-of tree2)))
+
+(defgeneric parse-tree-better (tree1 tree2))
+
+(defmethod parse-tree-better (tree1 tree2)
+ nil)
+
+(defclass parser-state ()
+ ((grammar :initarg :grammar :reader state-grammar)
+ (incomplete-items :initform (make-hash-table :test #'eq)
+ :reader incomplete-items)
+ (parse-trees :initform (make-hash-table :test #'eq)
+ :reader parse-trees)))
+
+(defun map-over-incomplete-items (state fun)
+ (maphash (lambda (key incomplete-items)
+ (loop for incomplete-item in incomplete-items
+ do (funcall fun key incomplete-item)))
+ (incomplete-items state)))
+
+(defgeneric handle-item (item orig-state to-state))
+
+(defun potentially-handle-parse-tree (parse-tree from-state to-state)
+ (let ((parse-trees (parse-trees to-state)))
+ (flet ((handle-parse-tree ()
+ (map-over-incomplete-items from-state
+ (lambda (orig-state incomplete-item)
+ (handle-item (derive-item incomplete-item parse-tree)
+ orig-state to-state)))))
+ (cond ((find parse-tree (gethash from-state parse-trees)
+ :test #'parse-tree-better)
+ (setf (gethash from-state parse-trees)
+ (cons parse-tree
+ (remove parse-tree (gethash from-state parse-trees)
+ :test #'parse-tree-better)))
+ (handle-parse-tree))
+ ((find parse-tree (gethash from-state parse-trees)
+ :test (lambda (x y) (or (parse-tree-better y x) (parse-tree-equal y x))))
+ nil)
+ (t (push parse-tree (gethash from-state parse-trees))
+ (handle-parse-tree))))))
+
+(defmethod handle-item ((item (eql nil)) orig-state to-state)
+ nil)
+
+(defmethod handle-item ((item incomplete-item) orig-state to-state)
+ (cond ((find item (gethash orig-state (incomplete-items to-state))
+ :test #'item-equal)
+ nil)
+ (t
+ (push item (gethash orig-state (incomplete-items to-state)))
+ (loop for rule in (rules (state-grammar to-state))
+ do (when (let ((sym1 (aref (symbols (rule item)) (dot-position item)))
+ (sym2 (left-hand-side rule)))
+ (or (subtypep sym1 sym2) (subtypep sym2 sym1)))
+ (handle-item (if (functionp (right-hand-side rule))
+ (make-instance 'incomplete-item
+ :rule rule
+ :dot-position 0
+ :parse-trees '()
+ :suffix (right-hand-side rule))
+ (make-instance 'complete-item
+ :parse-tree (right-hand-side rule)))
+ to-state to-state)))
+ (loop for parse-tree in (gethash to-state (parse-trees to-state))
+ do (handle-item (derive-item item parse-tree)
+ to-state to-state)))))
+
+(defmethod handle-item ((item complete-item) orig-state to-state)
+ (potentially-handle-parse-tree (parse-tree item) orig-state to-state))
+
+(defmethod initialize-instance :after ((parser parser) &rest args)
+ (declare (ignore args))
+ (with-slots (grammar initial-state) parser
+ (setf initial-state (make-instance 'parser-state :grammar grammar))
+ (loop for rule in (rules grammar)
+ do (when (let ((sym (left-hand-side rule)))
+ (or (subtypep (target parser) sym)
+ (subtypep sym (target parser))))
+ (handle-item (if (functionp (right-hand-side rule))
+ (make-instance 'incomplete-item
+ :rule rule
+ :dot-position 0
+ :parse-trees '()
+ :suffix (right-hand-side rule))
+ (make-instance 'complete-item
+ :parse-tree (right-hand-side rule)))
+ initial-state initial-state)))))
+
+(defun advance-parse (parser tokens state)
+ (with-slots (grammar) parser
+ (let ((new-state (make-instance 'parser-state :grammar grammar)))
+ (loop for token in tokens
+ do (potentially-handle-parse-tree token state new-state))
+ new-state)))
+
+(defclass lexer () ())
+
+(defgeneric lex (lexer))
From rstrandh at common-lisp.net Wed Feb 2 08:01:31 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Wed, 2 Feb 2005 09:01:31 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
Message-ID: <20050202080131.475708802C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv19383
Added Files:
html-syntax.lisp
Log Message:
Implemented an embryonic html-syntax module that uses the incremental
Earley parser.
Implemented a command (backward-to-error) to illustrate how
the module can be used. I am not happy with my syntax yet, though.
It reports too many errors.
Date: Wed Feb 2 09:01:30 2005
Author: rstrandh
From rstrandh at common-lisp.net Wed Feb 2 15:20:19 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Wed, 2 Feb 2005 16:20:19 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
Message-ID: <20050202152019.2E8708865F@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Doc
In directory common-lisp.net:/tmp/cvs-serv10569
Modified Files:
climacs-internals.texi
Log Message:
Fixing the syntax protocol according to the IRC discuccion with
Christophe Rhodes.
Date: Wed Feb 2 16:20:18 2005
Author: rstrandh
Index: climacs/Doc/climacs-internals.texi
diff -u climacs/Doc/climacs-internals.texi:1.9 climacs/Doc/climacs-internals.texi:1.10
--- climacs/Doc/climacs-internals.texi:1.9 Sat Jan 22 06:15:50 2005
+++ climacs/Doc/climacs-internals.texi Wed Feb 2 16:20:17 2005
@@ -601,27 +601,40 @@
particular point beyond which the structure of the buffer does not
need to be known.
-There are two situations where updating might be needed:
+There are three situations where updating might be needed:
@itemize @bullet
- at item before redisplay is about to show the contents of part of the
-buffer in a pane.
+ at item once, before any panes are displayed to inform the syntax module
+that some part of the buffer has been altered,
+ at item once for each pane on display, before redisplay is about to show
+the contents of part of the buffer in a pane to inform the syntax
+module that its syntax must be valid in the particular region on
+display,
@item as a result of a command that exploits the syntactic entities of
the buffer contents.
@end itemize
The first case is handled by the redisplay invoking the following
-generic function before proceeding to display the buffer contents in a
-pane:
+generic function:
- at deffn {Generic Function} {update-syntax} buffer syntax mark
+ at deffn {Generic Function} {update-syntax} buffer syntax
Inform the syntax module that it must update its view of the buffer
-contents up to the point indicated by the mark. It is acceptable to
-pass an offset instead of the mark.
+The low-mark and the high-mark of the buffer indicate what region has
+been updated. It is acceptable to pass an offset instead of the mark.
@end deffn
-The second case is handled by the syntax module itself when needed in
+The second case is handled by the following generic function:
+
+ at deffn {Generic Function} {update-syntax-for-display} buffer syntax from to
+
+Inform the syntax module that it must update its syntactic analysis to
+cover the region between the two marks from and to. It is acceptable
+to pass and offset instead of a mark for either or both of the last
+two arguments.
+ at end deffn
+
+The third case is handled by the syntax module itself when needed in
order to correctly compute the effects of a command.
It is important to realize that the syntax module is not directly
From rstrandh at common-lisp.net Sat Feb 5 06:25:31 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sat, 5 Feb 2005 07:25:31 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
Message-ID: <20050205062531.1CF90880A8@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv18556
Modified Files:
html-syntax.lisp
Log Message:
Improvements to HTML syntax.
Date: Sat Feb 5 07:25:30 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.1 climacs/html-syntax.lisp:1.2
--- climacs/html-syntax.lisp:1.1 Wed Feb 2 09:01:30 2005
+++ climacs/html-syntax.lisp Sat Feb 5 07:25:29 2005
@@ -128,25 +128,9 @@
(defparameter *html-grammar*
(grammar
(html -> ( head body ))
- ( -> (html-sym) :badness 5 :message "substituted ")
- ( -> (html-sym) :badness 5 :message "substituted ")
- ( -> () :badness 10 :message "missing inserted")
- ( -> () :badness 10 :message "missing inserted")
(head -> ( title ))
- ( -> (html-sym) :badness 5 :message "substituted ")
- ( -> (html-sym) :badness 5 :message "substituted ")
- ( -> () :badness 10 :message "missing inserted")
- ( -> () :badness 10 :message "missing inserted")
(title -> ( texts ))
- ( -> (html-sym) :badness 5 :message "substituted <title>")
- ( -> (html-sym) :badness 5 :message "substituted ")
- ( -> () :badness 10 :message "missing <title> inserted")
- ( -> () :badness 10 :message "missing inserted")
(body -> ( texts ))
- ( -> (html-sym) :badness 5 :message "substituted ")
- ( -> (html-sym) :badness 5 :message "substituted ")
- ( -> () :badness 10 :message "missing inserted")
- ( -> () :badness 10 :message "missing inserted")
(texts -> ())
(texts -> (texts text))))
@@ -178,7 +162,11 @@
do (let ((token (lex lexer)))
(push (cons (clone-mark mark)
(advance-parse parser (list token) (cdar states)))
- states))))))))
+ states)))))
+ (print (find 'html (gethash (initial-state parser) (parse-trees (cdar states)))
+ :key #'type-of)
+ *query-io*)
+ (finish-output *query-io*))))
(defgeneric forward-to-error (point syntax))
(defgeneric backward-to-error (point syntax))
@@ -193,11 +181,31 @@
(return-from find-bad-parse-tree parse-tree))))
(parse-trees state)))
+(defmethod empty-state-p (state)
+ (maphash (lambda (key val)
+ (declare (ignore key))
+ (loop for parse-tree in val
+ do (return-from empty-state-p nil)))
+ (parse-trees state))
+ (maphash (lambda (key val)
+ (declare (ignore key))
+ (loop for parse-tree in val
+ do (return-from empty-state-p nil)))
+ (incomplete-items state)))
+
(defmethod backward-to-error (point (syntax html-syntax))
(let ((states (slot-value syntax 'states)))
+ ;; find the last state before point
(loop until (or (null states)
(mark< (caar states) point))
do (pop states))
+ (when (null states)
+ (return-from backward-to-error "no more errors"))
+ (when (empty-state-p (cdar states))
+ (loop for ((m1 . s1) (m2 . s2)) on states
+ until (not (empty-state-p s2))
+ finally (setf (offset point) (offset m1)))
+ (return-from backward-to-error "no valid parse from this point"))
(loop for (mark . state) in states
for tree = (find-bad-parse-tree state)
when tree
From rstrandh at common-lisp.net Sat Feb 5 06:49:55 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sat, 5 Feb 2005 07:49:55 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/html-syntax.lisp
climacs/packages.lisp climacs/pane.lisp climacs/syntax.lisp
Message-ID: <20050205064955.8F5A7880A8@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv20065
Modified Files:
html-syntax.lisp packages.lisp pane.lisp syntax.lisp
Log Message:
Implemented the new buffer-modification protocol with both
update-syntax and update-syntax-for-display.
Date: Sat Feb 5 07:49:53 2005
Author: rstrandh
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.2 climacs/html-syntax.lisp:1.3
--- climacs/html-syntax.lisp:1.2 Sat Feb 5 07:25:29 2005
+++ climacs/html-syntax.lisp Sat Feb 5 07:49:53 2005
@@ -181,6 +181,8 @@
(return-from find-bad-parse-tree parse-tree))))
(parse-trees state)))
+(defgeneric empty-state-p (state))
+
(defmethod empty-state-p (state)
(maphash (lambda (key val)
(declare (ignore key))
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.45 climacs/packages.lisp:1.46
--- climacs/packages.lisp:1.45 Wed Feb 2 08:59:41 2005
+++ climacs/packages.lisp Sat Feb 5 07:49:53 2005
@@ -84,7 +84,7 @@
(:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain)
(:export #:syntax #:define-syntax
#:basic-syntax
- #:update-syntax
+ #:update-syntax #:update-syntax-for-display
#:syntax-line-indentation
#:beginning-of-paragraph #:end-of-paragraph
#:forward-to-error #:backward-to-error))
Index: climacs/pane.lisp
diff -u climacs/pane.lisp:1.17 climacs/pane.lisp:1.18
--- climacs/pane.lisp:1.17 Wed Feb 2 08:59:41 2005
+++ climacs/pane.lisp Sat Feb 5 07:49:53 2005
@@ -464,6 +464,7 @@
(setf (full-redisplay-p pane) nil))
(adjust-cache pane))
(fill-cache pane)
+ (update-syntax-for-display (buffer pane) (syntax (buffer pane)) (top pane) (bot pane))
(display-cache pane (if current-p +red+ +blue+)))
(defgeneric full-redisplay (pane))
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.29 climacs/syntax.lisp:1.30
--- climacs/syntax.lisp:1.29 Wed Feb 2 08:59:41 2005
+++ climacs/syntax.lisp Sat Feb 5 07:49:53 2005
@@ -27,6 +27,8 @@
(defgeneric update-syntax (buffer syntax))
+(defgeneric update-syntax-for-display (buffer syntax from to))
+
(defgeneric syntax-line-indentation (mark tab-width syntax)
(:documentation "Return the correct indentation for the line containing
the mark, according to the specified syntax."))
@@ -66,6 +68,10 @@
(defmethod update-syntax (buffer (syntax basic-syntax))
(declare (ignore buffer))
+ nil)
+
+(defmethod update-syntax-for-display (buffer (syntax basic-syntax) from to)
+ (declare (ignore buffer from to))
nil)
(defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax))
From rstrandh at common-lisp.net Sat Feb 5 07:04:06 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sat, 5 Feb 2005 08:04:06 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/buffer.lisp
climacs/packages.lisp
Message-ID: <20050205070406.9E49B880A8@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv20634
Modified Files:
base.lisp buffer.lisp packages.lisp
Log Message:
Moved forward-object and backward-object to the buffer protocol.
Updated buffer.lisp and base.lisp accordingly. Also added the
documentation of these functions to the Texinfo documentation.
Date: Sat Feb 5 08:04:04 2005
Author: rstrandh
Index: climacs/base.lisp
diff -u climacs/base.lisp:1.30 climacs/base.lisp:1.31
--- climacs/base.lisp:1.30 Sun Jan 30 20:56:53 2005
+++ climacs/base.lisp Sat Feb 5 08:04:03 2005
@@ -39,16 +39,6 @@
(loop for ,offset from ,offset1 below ,offset2
do , at body)))
-(defgeneric backward-object (mark &optional count))
-
-(defmethod backward-object ((mark mark) &optional (count 1))
- (decf (offset mark) count))
-
-(defgeneric forward-object (mark &optional count))
-
-(defmethod forward-object ((mark mark) &optional (count 1))
- (incf (offset mark) count))
-
(defun previous-line (mark &optional column)
"Move a mark up one line conserving horizontal position."
(unless column
Index: climacs/buffer.lisp
diff -u climacs/buffer.lisp:1.24 climacs/buffer.lisp:1.25
--- climacs/buffer.lisp:1.24 Wed Jan 26 17:10:40 2005
+++ climacs/buffer.lisp Sat Feb 5 08:04:03 2005
@@ -86,6 +86,16 @@
(make-condition 'no-such-offset :offset new-offset))
(setf (cursor-pos (cursor mark)) new-offset))
+(defgeneric backward-object (mark &optional count))
+
+(defmethod backward-object ((mark mark) &optional (count 1))
+ (decf (offset mark) count))
+
+(defgeneric forward-object (mark &optional count))
+
+(defmethod forward-object ((mark mark) &optional (count 1))
+ (incf (offset mark) count))
+
(defclass standard-left-sticky-mark (left-sticky-mark mark-mixin) ()
(:documentation "A left-sticky-mark subclass suitable for use in a standard-buffer"))
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.46 climacs/packages.lisp:1.47
--- climacs/packages.lisp:1.46 Sat Feb 5 07:49:53 2005
+++ climacs/packages.lisp Sat Feb 5 08:04:03 2005
@@ -29,6 +29,7 @@
#:standard-left-sticky-mark #:standard-right-sticky-mark
#:clone-mark #:no-such-offset #:size #:number-of-lines
#:offset #:mark< #:mark<= #:mark= #:mark> #:mark>=
+ #:forward-object #:backward-object
#:beginning-of-buffer #:end-of-buffer
#:beginning-of-buffer-p #:end-of-buffer-p
#:beginning-of-line #:end-of-line
@@ -49,7 +50,6 @@
(defpackage :climacs-base
(:use :clim-lisp :climacs-buffer)
(:export #:do-buffer-region
- #:forward-object #:backward-object
#:previous-line #:next-line
#:open-line #:kill-line
#:empty-line-p
From rstrandh at common-lisp.net Sat Feb 5 07:04:08 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sat, 5 Feb 2005 08:04:08 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
Message-ID: <20050205070408.A2749880A8@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Doc
In directory common-lisp.net:/tmp/cvs-serv20634/Doc
Modified Files:
climacs-internals.texi
Log Message:
Moved forward-object and backward-object to the buffer protocol.
Updated buffer.lisp and base.lisp accordingly. Also added the
documentation of these functions to the Texinfo documentation.
Date: Sat Feb 5 08:04:07 2005
Author: rstrandh
Index: climacs/Doc/climacs-internals.texi
diff -u climacs/Doc/climacs-internals.texi:1.10 climacs/Doc/climacs-internals.texi:1.11
--- climacs/Doc/climacs-internals.texi:1.10 Wed Feb 2 16:20:17 2005
+++ climacs/Doc/climacs-internals.texi Sat Feb 5 08:04:06 2005
@@ -157,6 +157,22 @@
the size of the buffer.
@end deffn
+ at deffn {Generic Function} {forward-object} mark &optional (count 1)
+
+Move the mark forward the number of positions indicated by count.
+This function could be implemented by an incf on the offset of the
+mark, but many buffer implementations can implement this function much
+more efficiently in a different way.
+ at end deffn
+
+ at deffn {Generic Function} {backward-object} mark &optional (count 1)
+
+Move the mark backward the number of positions indicated by count.
+This function could be implemented by a decf on the offset of the
+mark, but many buffer implementations can implement this function much
+more efficiently in a different way.
+ at end deffn
+
@deffn {Generic Function} {mark<} mark1 mark2
Return t if the offset of mark1 is strictly less than that of mark2.
From abakic at common-lisp.net Sat Feb 5 13:49:22 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 5 Feb 2005 14:49:22 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/buffer-test.lisp
climacs/buffer.lisp
Message-ID: <20050205134922.7195D88690@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv9690
Modified Files:
buffer-test.lisp buffer.lisp
Log Message:
Changed region-to-sequence to be symmetrical wrt. marks.
Date: Sat Feb 5 14:49:21 2005
Author: abakic
Index: climacs/buffer-test.lisp
diff -u climacs/buffer-test.lisp:1.10 climacs/buffer-test.lisp:1.11
--- climacs/buffer-test.lisp:1.10 Fri Jan 28 19:47:29 2005
+++ climacs/buffer-test.lisp Sat Feb 5 14:49:20 2005
@@ -710,6 +710,14 @@
(and (not (eq seq seq2)) seq2)))
"climacs")
+(deftest standard-buffer-region-to-sequence.test-1aa
+ (let ((seq "climacs")
+ (buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 seq)
+ (let ((seq2 (region-to-sequence (high-mark buffer) 0)))
+ (and (not (eq seq seq2)) seq2)))
+ "climacs")
+
(deftest standard-buffer-region-to-sequence.test-1b
(let ((seq "climacs")
(buffer (make-instance 'standard-buffer)))
@@ -718,12 +726,20 @@
(and (not (eq seq seq2)) seq2)))
"climacs")
+(deftest standard-buffer-region-to-sequence.test-1ba
+ (let ((seq "climacs")
+ (buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 seq)
+ (let ((seq2 (region-to-sequence 7 (low-mark buffer))))
+ (and (not (eq seq seq2)) seq2)))
+ "climacs")
+
(deftest standard-buffer-region-to-sequence.test-2
(let ((seq "climacs")
(buffer (make-instance 'standard-buffer)))
(insert-buffer-sequence buffer 0 seq)
(region-to-sequence (high-mark buffer) (low-mark buffer)))
- #())
+ "climacs")
(deftest standard-buffer-region-to-sequence.test-3
(handler-case
@@ -847,4 +863,4 @@
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
+ 1000000)
Index: climacs/buffer.lisp
diff -u climacs/buffer.lisp:1.25 climacs/buffer.lisp:1.26
--- climacs/buffer.lisp:1.25 Sat Feb 5 08:04:03 2005
+++ climacs/buffer.lisp Sat Feb 5 14:49:20 2005
@@ -488,13 +488,23 @@
(defmethod region-to-sequence ((mark1 mark-mixin) (mark2 mark-mixin))
(assert (eq (buffer mark1) (buffer mark2)))
- (buffer-sequence (buffer mark1) (offset mark1) (offset mark2)))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (buffer-sequence (buffer mark1) offset1 offset2)))
-(defmethod region-to-sequence ((offset integer) (mark mark-mixin))
- (buffer-sequence (buffer mark) offset (offset mark)))
+(defmethod region-to-sequence ((offset1 integer) (mark2 mark-mixin))
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (buffer-sequence (buffer mark2) offset1 offset2)))
-(defmethod region-to-sequence ((mark mark-mixin) (offset integer))
- (buffer-sequence (buffer mark) (offset mark) offset))
+(defmethod region-to-sequence ((mark1 mark-mixin) (offset2 integer))
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (buffer-sequence (buffer mark1) offset1 offset2)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
From abakic at common-lisp.net Sat Feb 5 13:49:23 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 5 Feb 2005 14:49:23 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
Message-ID: <20050205134923.9CD6188691@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Doc
In directory common-lisp.net:/tmp/cvs-serv9690/Doc
Modified Files:
climacs-internals.texi
Log Message:
Changed region-to-sequence to be symmetrical wrt. marks.
Date: Sat Feb 5 14:49:22 2005
Author: abakic
Index: climacs/Doc/climacs-internals.texi
diff -u climacs/Doc/climacs-internals.texi:1.11 climacs/Doc/climacs-internals.texi:1.12
--- climacs/Doc/climacs-internals.texi:1.11 Sat Feb 5 08:04:06 2005
+++ climacs/Doc/climacs-internals.texi Sat Feb 5 14:49:22 2005
@@ -323,10 +323,10 @@
@deffn {Generic Function} {delete-region} mark1 mark2
-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.
+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
@@ -349,7 +349,7 @@
offset1, an empty sequence will be returned.
@end deffn
- at deffn {Generic Function} {objecct-before} mark
+ at deffn {Generic Function} {object-before} mark
Return the object that is immediately before the mark. If mark is at
the beginning of the buffer, a no-such-offset condition is signaled.
@@ -357,7 +357,7 @@
of the buffer, a newline character is returned.
@end deffn
- at deffn {Generic Function} {objecct-after} mark
+ at deffn {Generic Function} {object-after} mark
Return the object that is immediately after the mark. If mark is at
the end of the buffer, a no-such-offset condition is signaled. If
@@ -367,11 +367,10 @@
@deffn {Generic Function} {region-to-sequence} mark1 mark2
-Return a freshly allocated sequence of the objects 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, an empty sequence is returned. It is
-acceptable to pass an offset in place of one of the marks.
+Return a freshly allocated sequence of the objects 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.
@end deffn
@section Implementation hints
From abakic at common-lisp.net Sat Feb 5 13:49:25 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 5 Feb 2005 14:49:25 +0100 (CET)
Subject: [climacs-cvs] CVS update:
climacs/Persistent/persistent-buffer-test.lisp
Message-ID: <20050205134925.227C288690@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv9690/Persistent
Modified Files:
persistent-buffer-test.lisp
Log Message:
Changed region-to-sequence to be symmetrical wrt. marks.
Date: Sat Feb 5 14:49:23 2005
Author: abakic
Index: climacs/Persistent/persistent-buffer-test.lisp
diff -u climacs/Persistent/persistent-buffer-test.lisp:1.3 climacs/Persistent/persistent-buffer-test.lisp:1.4
--- climacs/Persistent/persistent-buffer-test.lisp:1.3 Fri Jan 28 19:47:34 2005
+++ climacs/Persistent/persistent-buffer-test.lisp Sat Feb 5 14:49:23 2005
@@ -724,6 +724,14 @@
(and (not (eq seq seq2)) seq2)))
"climacs")
+(deftest binseq-buffer-region-to-sequence.test-1aa
+ (let ((seq "climacs")
+ (buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 seq)
+ (let ((seq2 (region-to-sequence (high-mark buffer) 0)))
+ (and (not (eq seq seq2)) seq2)))
+ "climacs")
+
(deftest binseq-buffer-region-to-sequence.test-1b
(let ((seq "climacs")
(buffer (make-instance 'binseq-buffer)))
@@ -732,12 +740,20 @@
(and (not (eq seq seq2)) seq2)))
"climacs")
+(deftest binseq-buffer-region-to-sequence.test-1ba
+ (let ((seq "climacs")
+ (buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 seq)
+ (let ((seq2 (region-to-sequence 7 (low-mark buffer))))
+ (and (not (eq seq seq2)) seq2)))
+ "climacs")
+
(deftest binseq-buffer-region-to-sequence.test-2
(let ((seq "climacs")
(buffer (make-instance 'binseq-buffer)))
(insert-buffer-sequence buffer 0 seq)
(region-to-sequence (high-mark buffer) (low-mark buffer)))
- #())
+ "climacs")
(deftest binseq-buffer-region-to-sequence.test-3
(handler-case
@@ -1453,6 +1469,14 @@
(and (not (eq seq seq2)) seq2)))
"climacs")
+(deftest obinseq-buffer-region-to-sequence.test-1aa
+ (let ((seq "climacs")
+ (buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 seq)
+ (let ((seq2 (region-to-sequence (high-mark buffer) 0)))
+ (and (not (eq seq seq2)) seq2)))
+ "climacs")
+
(deftest obinseq-buffer-region-to-sequence.test-1b
(let ((seq "climacs")
(buffer (make-instance 'obinseq-buffer)))
@@ -1461,12 +1485,20 @@
(and (not (eq seq seq2)) seq2)))
"climacs")
+(deftest obinseq-buffer-region-to-sequence.test-1ba
+ (let ((seq "climacs")
+ (buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 seq)
+ (let ((seq2 (region-to-sequence 7 (low-mark buffer))))
+ (and (not (eq seq seq2)) seq2)))
+ "climacs")
+
(deftest obinseq-buffer-region-to-sequence.test-2
(let ((seq "climacs")
(buffer (make-instance 'obinseq-buffer)))
(insert-buffer-sequence buffer 0 seq)
(region-to-sequence (high-mark buffer) (low-mark buffer)))
- #())
+ "climacs")
(deftest obinseq-buffer-region-to-sequence.test-3
(handler-case
@@ -1696,4 +1728,4 @@
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
+ 1000000)
From abakic at common-lisp.net Sat Feb 5 20:59:52 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 5 Feb 2005 21:59:52 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/buffer-test.lisp
climacs/buffer.lisp
Message-ID: <20050205205952.76E1C884FE@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv1016
Modified Files:
buffer-test.lisp buffer.lisp
Log Message:
Introduced p-mark-mixin class to separate methods related to the
standard-buffer and its marks, from those related to the persistent
buffers and their marks.
Also added a few tests for (setf buffer-object).
Date: Sat Feb 5 21:59:50 2005
Author: abakic
Index: climacs/buffer-test.lisp
diff -u climacs/buffer-test.lisp:1.11 climacs/buffer-test.lisp:1.12
--- climacs/buffer-test.lisp:1.11 Sat Feb 5 14:49:20 2005
+++ climacs/buffer-test.lisp Sat Feb 5 21:59:49 2005
@@ -459,6 +459,29 @@
(= (climacs-buffer::condition-offset c) 8)))
t)
+(deftest standard-buffer-setf-buffer-object.test-1
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (setf (buffer-object buffer 0) #\C)
+ (buffer-sequence buffer 0 (size buffer)))
+ "Climacs")
+
+(deftest standard-buffer-setf-buffer-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'standard-buffer)))
+ (setf (buffer-object buffer 0) #\a))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) 0)))
+ t)
+
+(deftest standard-buffer-setf-buffer-object.test-3
+ (handler-case
+ (let ((buffer (make-instance 'standard-buffer)))
+ (setf (buffer-object buffer -1) #\a))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) -1)))
+ t)
+
(deftest standard-buffer-mark<.test-1
(handler-case
(let ((buffer (make-instance 'standard-buffer))
Index: climacs/buffer.lisp
diff -u climacs/buffer.lisp:1.26 climacs/buffer.lisp:1.27
--- climacs/buffer.lisp:1.26 Sat Feb 5 14:49:20 2005
+++ climacs/buffer.lisp Sat Feb 5 21:59:50 2005
@@ -88,12 +88,12 @@
(defgeneric backward-object (mark &optional count))
-(defmethod backward-object ((mark mark) &optional (count 1))
+(defmethod backward-object ((mark mark-mixin) &optional (count 1))
(decf (offset mark) count))
(defgeneric forward-object (mark &optional count))
-(defmethod forward-object ((mark mark) &optional (count 1))
+(defmethod forward-object ((mark mark-mixin) &optional (count 1))
(incf (offset mark) count))
(defclass standard-left-sticky-mark (left-sticky-mark mark-mixin) ()
@@ -297,7 +297,7 @@
either immediately before the closest following newline character, or
at the end of the buffer if no following newline character exists."))
-(defmethod end-of-line ((mark mark-mixin)) ;PB
+(defmethod end-of-line ((mark mark-mixin))
(let* ((offset (offset mark))
(buffer (buffer mark))
(chain (slot-value buffer 'contents))
From abakic at common-lisp.net Sat Feb 5 21:00:08 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 5 Feb 2005 22:00:08 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Persistent/README
climacs/Persistent/persistent-buffer-test.lisp
climacs/Persistent/persistent-buffer.lisp
Message-ID: <20050205210008.1A82F884FE@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv1016/Persistent
Modified Files:
README persistent-buffer-test.lisp persistent-buffer.lisp
Log Message:
Introduced p-mark-mixin class to separate methods related to the
standard-buffer and its marks, from those related to the persistent
buffers and their marks.
Also added a few tests for (setf buffer-object).
Date: Sat Feb 5 21:59:52 2005
Author: abakic
Index: climacs/Persistent/README
diff -u climacs/Persistent/README:1.2 climacs/Persistent/README:1.3
--- climacs/Persistent/README:1.2 Fri Jan 28 19:47:34 2005
+++ climacs/Persistent/README Sat Feb 5 21:59:51 2005
@@ -8,21 +8,6 @@
all other places marked with "PB" comments, substitute "standard" for
"persistent" in order to use the corresponding mark classes.
-Also, end-of-line method in buffer.lisp has to be fixed and look like:
-
-(defmethod end-of-line ((mark mark-mixin))
- (let* ((offset (offset mark))
- (buffer (buffer mark))
- (size (size buffer)))
- (loop until (or (= offset size)
- (eql (buffer-object buffer offset) #\Newline))
- do (incf offset))
- (setf (offset mark) offset)))
-
-(It is currently "broken" for performance reasons.) Until then,
-(o)binseq-end-of-line, (o)binseq-next-line and (o)binseq-kill-line
-tests will fail (20 of them).
-
NOTE: There is a dependency of Persistent/persistent-buffer.lisp on
Flexichain/utilities.lisp (the weak pointer handling).
Index: climacs/Persistent/persistent-buffer-test.lisp
diff -u climacs/Persistent/persistent-buffer-test.lisp:1.4 climacs/Persistent/persistent-buffer-test.lisp:1.5
--- climacs/Persistent/persistent-buffer-test.lisp:1.4 Sat Feb 5 14:49:23 2005
+++ climacs/Persistent/persistent-buffer-test.lisp Sat Feb 5 21:59:51 2005
@@ -473,6 +473,29 @@
(= (climacs-buffer::condition-offset c) 8)))
t)
+(deftest binseq-buffer-setf-buffer-object.test-1
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (setf (buffer-object buffer 0) #\C)
+ (buffer-sequence buffer 0 (size buffer)))
+ "Climacs")
+
+(deftest binseq-buffer-setf-buffer-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (setf (buffer-object buffer 0) #\a))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) 0)))
+ t)
+
+(deftest binseq-buffer-setf-buffer-object.test-3
+ (handler-case
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (setf (buffer-object buffer -1) #\a))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) -1)))
+ t)
+
(deftest binseq-buffer-mark<.test-1
(handler-case
(let ((buffer (make-instance 'binseq-buffer))
@@ -1216,6 +1239,29 @@
(setf (offset m) 8)))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 8)))
+ t)
+
+(deftest obinseq-buffer-setf-buffer-object.test-1
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (setf (buffer-object buffer 0) #\C)
+ (buffer-sequence buffer 0 (size buffer)))
+ "Climacs")
+
+(deftest obinseq-buffer-setf-buffer-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (setf (buffer-object buffer 0) #\a))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) 0)))
+ t)
+
+(deftest obinseq-buffer-setf-buffer-object.test-3
+ (handler-case
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (setf (buffer-object buffer -1) #\a))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) -1)))
t)
(deftest obinseq-buffer-mark<.test-1
Index: climacs/Persistent/persistent-buffer.lisp
diff -u climacs/Persistent/persistent-buffer.lisp:1.3 climacs/Persistent/persistent-buffer.lisp:1.4
--- climacs/Persistent/persistent-buffer.lisp:1.3 Fri Jan 28 19:47:36 2005
+++ climacs/Persistent/persistent-buffer.lisp Sat Feb 5 21:59:51 2005
@@ -87,11 +87,31 @@
uses an optimized binary sequence (only non-nil atoms are allowed as
elements) for the CONTENTS."))
-(defclass persistent-left-sticky-mark (left-sticky-mark mark-mixin) ()
+(defclass p-mark-mixin ()
+ ((buffer :initarg :buffer :reader buffer)
+ (cursor :reader cursor))
+ (:documentation "A mixin class used in the initialization of a mark
+that is used in a PERSISTENT-BUFFER."))
+
+(defmethod backward-object ((mark p-mark-mixin) &optional (count 1))
+ (decf (offset mark) count))
+
+(defmethod forward-object ((mark p-mark-mixin) &optional (count 1))
+ (incf (offset mark) count))
+
+(defmethod offset ((mark p-mark-mixin))
+ (cursor-pos (cursor mark)))
+
+(defmethod (setf offset) (new-offset (mark p-mark-mixin))
+ (assert (<= 0 new-offset (size (buffer mark))) ()
+ (make-condition 'no-such-offset :offset new-offset))
+ (setf (cursor-pos (cursor mark)) new-offset))
+
+(defclass persistent-left-sticky-mark (left-sticky-mark p-mark-mixin) ()
(:documentation "A LEFT-STICKY-MARK subclass suitable for use in a
PERSISTENT-BUFFER."))
-(defclass persistent-right-sticky-mark (right-sticky-mark mark-mixin) ()
+(defclass persistent-right-sticky-mark (right-sticky-mark p-mark-mixin) ()
(:documentation "A RIGHT-STICKY-MARK subclass suitable for use in a
PERSISTENT-BUFFER."))
@@ -145,16 +165,105 @@
(loop for offset from 0 below (size buffer)
count (eql (buffer-object buffer offset) #\Newline)))
+(defmethod mark< ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (< (offset mark1) (offset mark2)))
+
+(defmethod mark< ((mark1 p-mark-mixin) (mark2 integer))
+ (< (offset mark1) mark2))
+
+(defmethod mark< ((mark1 integer) (mark2 p-mark-mixin))
+ (< mark1 (offset mark2)))
+
+(defmethod mark<= ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (<= (offset mark1) (offset mark2)))
+
+(defmethod mark<= ((mark1 p-mark-mixin) (mark2 integer))
+ (<= (offset mark1) mark2))
+
+(defmethod mark<= ((mark1 integer) (mark2 p-mark-mixin))
+ (<= mark1 (offset mark2)))
+
+(defmethod mark= ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (= (offset mark1) (offset mark2)))
+
+(defmethod mark= ((mark1 p-mark-mixin) (mark2 integer))
+ (= (offset mark1) mark2))
+
+(defmethod mark= ((mark1 integer) (mark2 p-mark-mixin))
+ (= mark1 (offset mark2)))
+
+(defmethod mark> ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (> (offset mark1) (offset mark2)))
+
+(defmethod mark> ((mark1 p-mark-mixin) (mark2 integer))
+ (> (offset mark1) mark2))
+
+(defmethod mark> ((mark1 integer) (mark2 p-mark-mixin))
+ (> mark1 (offset mark2)))
+
+(defmethod mark>= ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (>= (offset mark1) (offset mark2)))
+
+(defmethod mark>= ((mark1 p-mark-mixin) (mark2 integer))
+ (>= (offset mark1) mark2))
+
+(defmethod mark>= ((mark1 integer) (mark2 p-mark-mixin))
+ (>= mark1 (offset mark2)))
+
+(defmethod beginning-of-buffer ((mark p-mark-mixin))
+ (setf (offset mark) 0))
+
+(defmethod end-of-buffer ((mark p-mark-mixin))
+ (setf (offset mark) (size (buffer mark))))
+
+(defmethod beginning-of-buffer-p ((mark p-mark-mixin))
+ (zerop (offset mark)))
+
+(defmethod end-of-buffer-p ((mark p-mark-mixin))
+ (= (offset mark) (size (buffer mark))))
+
+(defmethod beginning-of-line-p ((mark p-mark-mixin))
+ (or (beginning-of-buffer-p mark)
+ (eql (object-before mark) #\Newline)))
+
+(defmethod end-of-line-p ((mark p-mark-mixin))
+ (or (end-of-buffer-p mark)
+ (eql (object-after mark) #\Newline)))
+
+(defmethod beginning-of-line ((mark p-mark-mixin))
+ (loop until (beginning-of-line-p mark)
+ do (decf (offset mark))))
+
+(defmethod end-of-line ((mark p-mark-mixin))
+ (let* ((offset (offset mark))
+ (buffer (buffer mark))
+ (size (size buffer)))
+ (loop until (or (= offset size)
+ (eql (buffer-object buffer offset) #\Newline))
+ do (incf offset))
+ (setf (offset mark) offset)))
+
(defmethod buffer-line-number ((buffer persistent-buffer) (offset integer))
(loop for i from 0 below offset
count (eql (buffer-object buffer i) #\Newline)))
+(defmethod line-number ((mark p-mark-mixin))
+ (buffer-line-number (buffer mark) (offset mark)))
+
(defmethod buffer-column-number ((buffer persistent-buffer) (offset integer))
(loop for i downfrom offset
while (> i 0)
until (eql (buffer-object buffer (1- i)) #\Newline)
count t))
+(defmethod column-number ((mark p-mark-mixin))
+ (buffer-column-number (buffer mark) (offset mark)))
+
;;; the old value of the CONTENTS slot is dropped upon modification
;;; it can be saved for UNDO purposes in a history tree, by an UNDOABLE-BUFFER
@@ -170,6 +279,9 @@
(setf (slot-value buffer 'contents)
(obinseq-insert (slot-value buffer 'contents) offset object)))
+(defmethod insert-object ((mark p-mark-mixin) object)
+ (insert-buffer-object (buffer mark) (offset mark) object))
+
(defmethod insert-buffer-sequence ((buffer binseq-buffer) offset sequence)
(let ((binseq (list-binseq (loop for e across sequence collect e))))
(setf (slot-value buffer 'contents)
@@ -180,6 +292,9 @@
(setf (slot-value buffer 'contents)
(obinseq-insert* (slot-value buffer 'contents) offset obinseq))))
+(defmethod insert-sequence ((mark p-mark-mixin) sequence)
+ (insert-buffer-sequence (buffer mark) (offset mark) sequence))
+
(defmethod delete-buffer-range ((buffer binseq-buffer) offset n)
(assert (<= 0 offset (size buffer)) ()
(make-condition 'no-such-offset :offset offset))
@@ -192,6 +307,32 @@
(setf (slot-value buffer 'contents)
(obinseq-remove* (slot-value buffer 'contents) offset n)))
+(defmethod delete-range ((mark p-mark-mixin) &optional (n 1))
+ (cond
+ ((plusp n) (delete-buffer-range (buffer mark) (offset mark) n))
+ ((minusp n) (delete-buffer-range (buffer mark) (+ (offset mark) n) (- n)))
+ (t nil)))
+
+(defmethod delete-region ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (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 p-mark-mixin) offset2)
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1))))
+
+(defmethod delete-region (offset1 (mark2 p-mark-mixin))
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1))))
+
(defmethod buffer-object ((buffer binseq-buffer) offset)
(assert (<= 0 offset (1- (size buffer))) ()
(make-condition 'no-such-offset :offset offset))
@@ -240,6 +381,43 @@
nil))
'vector))
+(defmethod object-before ((mark p-mark-mixin))
+ (buffer-object (buffer mark) (1- (offset mark))))
+
+(defmethod object-after ((mark p-mark-mixin))
+ (buffer-object (buffer mark) (offset mark)))
+
+(defmethod region-to-sequence ((mark1 p-mark-mixin) (mark2 p-mark-mixin))
+ (assert (eq (buffer mark1) (buffer mark2)))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (buffer-sequence (buffer mark1) offset1 offset2)))
+
+(defmethod region-to-sequence ((offset1 integer) (mark2 p-mark-mixin))
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (buffer-sequence (buffer mark2) offset1 offset2)))
+
+(defmethod region-to-sequence ((mark1 p-mark-mixin) (offset2 integer))
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (buffer-sequence (buffer mark1) offset1 offset2)))
+
+;;; Buffer modification protocol
+
+(defmethod (setf buffer-object)
+ :before (object (buffer persistent-buffer) offset)
+ (declare (ignore object))
+ (setf (offset (low-mark buffer))
+ (min (offset (low-mark buffer)) offset))
+ (setf (offset (high-mark buffer))
+ (max (offset (high-mark buffer)) offset))
+ (setf (slot-value buffer 'modified) t))
+
(defmethod insert-buffer-object
:before ((buffer persistent-buffer) offset object)
(declare (ignore object))
@@ -309,4 +487,4 @@
(defmethod delete-buffer-range
:after ((buffer persistent-buffer) offset n)
(with-slots (cursors) buffer
- (setf cursors (adjust-cursors-on-delete buffer offset n))))
\ No newline at end of file
+ (setf cursors (adjust-cursors-on-delete buffer offset n))))
From abakic at common-lisp.net Sat Feb 5 21:34:44 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 5 Feb 2005 22:34:44 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/buffer-test.lisp
Message-ID: <20050205213444.3292A884FE@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv3430
Modified Files:
buffer-test.lisp
Log Message:
Added a few tests for forward/backward-object.
Date: Sat Feb 5 22:34:43 2005
Author: abakic
Index: climacs/buffer-test.lisp
diff -u climacs/buffer-test.lisp:1.12 climacs/buffer-test.lisp:1.13
--- climacs/buffer-test.lisp:1.12 Sat Feb 5 21:59:49 2005
+++ climacs/buffer-test.lisp Sat Feb 5 22:34:43 2005
@@ -459,6 +459,52 @@
(= (climacs-buffer::condition-offset c) 8)))
t)
+(deftest standard-buffer-backward-object.test-1
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 4))
+ (m2 (clone-mark m1)))
+ (backward-object m1 2)
+ (region-to-sequence m1 m2)))
+ "im")
+
+(deftest standard-buffer-backward-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 2))
+ (m2 (clone-mark m1)))
+ (backward-object m1 3)
+ (region-to-sequence m1 m2)))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) -1)))
+ t)
+
+(deftest standard-buffer-forward-object.test-1
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 4))
+ (m2 (clone-mark m1)))
+ (forward-object m1 2)
+ (region-to-sequence m1 m2)))
+ "ac")
+
+(deftest standard-buffer-forward-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 6))
+ (m2 (clone-mark m1)))
+ (forward-object m1 3)
+ (region-to-sequence m1 m2)))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) 9)))
+ t)
+
(deftest standard-buffer-setf-buffer-object.test-1
(let ((buffer (make-instance 'standard-buffer)))
(insert-buffer-sequence buffer 0 "climacs")
From abakic at common-lisp.net Sat Feb 5 21:34:46 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sat, 5 Feb 2005 22:34:46 +0100 (CET)
Subject: [climacs-cvs] CVS update:
climacs/Persistent/persistent-buffer-test.lisp
Message-ID: <20050205213446.4DCA288661@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv3430/Persistent
Modified Files:
persistent-buffer-test.lisp
Log Message:
Added a few tests for forward/backward-object.
Date: Sat Feb 5 22:34:44 2005
Author: abakic
Index: climacs/Persistent/persistent-buffer-test.lisp
diff -u climacs/Persistent/persistent-buffer-test.lisp:1.5 climacs/Persistent/persistent-buffer-test.lisp:1.6
--- climacs/Persistent/persistent-buffer-test.lisp:1.5 Sat Feb 5 21:59:51 2005
+++ climacs/Persistent/persistent-buffer-test.lisp Sat Feb 5 22:34:44 2005
@@ -496,6 +496,52 @@
(= (climacs-buffer::condition-offset c) -1)))
t)
+(deftest binseq-buffer-backward-object.test-1
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 4))
+ (m2 (clone-mark m1)))
+ (backward-object m1 2)
+ (region-to-sequence m1 m2)))
+ "im")
+
+(deftest binseq-buffer-backward-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 2))
+ (m2 (clone-mark m1)))
+ (backward-object m1 3)
+ (region-to-sequence m1 m2)))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) -1)))
+ t)
+
+(deftest binseq-buffer-forward-object.test-1
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 4))
+ (m2 (clone-mark m1)))
+ (forward-object m1 2)
+ (region-to-sequence m1 m2)))
+ "ac")
+
+(deftest binseq-buffer-forward-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 6))
+ (m2 (clone-mark m1)))
+ (forward-object m1 3)
+ (region-to-sequence m1 m2)))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) 9)))
+ t)
+
(deftest binseq-buffer-mark<.test-1
(handler-case
(let ((buffer (make-instance 'binseq-buffer))
@@ -1262,6 +1308,52 @@
(setf (buffer-object buffer -1) #\a))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) -1)))
+ t)
+
+(deftest obinseq-buffer-backward-object.test-1
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 4))
+ (m2 (clone-mark m1)))
+ (backward-object m1 2)
+ (region-to-sequence m1 m2)))
+ "im")
+
+(deftest obinseq-buffer-backward-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 2))
+ (m2 (clone-mark m1)))
+ (backward-object m1 3)
+ (region-to-sequence m1 m2)))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) -1)))
+ t)
+
+(deftest obinseq-buffer-forward-object.test-1
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 4))
+ (m2 (clone-mark m1)))
+ (forward-object m1 2)
+ (region-to-sequence m1 m2)))
+ "ac")
+
+(deftest obinseq-buffer-forward-object.test-2
+ (handler-case
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs")
+ (let* ((m1 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 6))
+ (m2 (clone-mark m1)))
+ (forward-object m1 3)
+ (region-to-sequence m1 m2)))
+ (climacs-buffer::no-such-offset (c)
+ (= (climacs-buffer::condition-offset c) 9)))
t)
(deftest obinseq-buffer-mark<.test-1
From abakic at common-lisp.net Sun Feb 6 00:03:30 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 6 Feb 2005 01:03:30 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/base-test.lisp climacs/base.lisp
climacs/buffer-test.lisp
Message-ID: <20050206000330.356E7884FE@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv12175
Modified Files:
base-test.lisp base.lisp buffer-test.lisp
Log Message:
Changes to (un)tabify-*region methods, and corresponding tests.
Initial tests for indent-line.
Date: Sun Feb 6 01:03:26 2005
Author: abakic
Index: climacs/base-test.lisp
diff -u climacs/base-test.lisp:1.4 climacs/base-test.lisp:1.5
--- climacs/base-test.lisp:1.4 Sat Jan 29 23:23:08 2005
+++ climacs/base-test.lisp Sun Feb 6 01:03:26 2005
@@ -770,3 +770,107 @@
(buffer-sequence buffer 0 (size buffer))
(offset m))))
"Cli Ma Cs climacs" 9)
+
+(deftest standard-buffer-tabify-buffer-region.test-1
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::tabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest standard-buffer-tabify-buffer-region.test-2
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::tabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest standard-buffer-tabify-region.test-1
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 7)))
+ (tabify-region m2 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest standard-buffer-tabify-region.test-2
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 3)))
+ (tabify-region 7 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest standard-buffer-tabify-region.test-3
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 7)))
+ (tabify-region 3 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest standard-buffer-untabify-buffer-region.test-1
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::untabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest standard-buffer-untabify-buffer-region.test-2
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::untabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest standard-buffer-untabify-region.test-1
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 5)))
+ (untabify-region m2 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest standard-buffer-untabify-region.test-2
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 3)))
+ (untabify-region 5 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest standard-buffer-untabify-region.test-3
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 5)))
+ (untabify-region 3 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest standard-buffer-indent-line.test-1
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 0)))
+ (indent-line m 4 nil)
+ (buffer-sequence buffer 0 (size buffer))))
+ " climacs ")
+
+(deftest standard-buffer-indent-line.test-2
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 0)))
+ (indent-line m 5 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ " climacs ")
Index: climacs/base.lisp
diff -u climacs/base.lisp:1.31 climacs/base.lisp:1.32
--- climacs/base.lisp:1.31 Sat Feb 5 08:04:03 2005
+++ climacs/base.lisp Sun Feb 6 01:03:26 2005
@@ -382,14 +382,23 @@
(defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width)
(assert (eq (buffer mark1) (buffer mark2)))
- (tabify-buffer-region (buffer mark1) (offset mark1) (offset mark2)
- tab-width))
-
-(defmethod tabify-region ((offset integer) (mark mark) tab-width)
- (tabify-buffer-region (buffer mark) offset (offset mark) tab-width))
-
-(defmethod tabify-region ((mark mark) (offset integer) tab-width)
- (tabify-buffer-region (buffer mark) (offset mark) offset tab-width))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
+
+(defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width)
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width)))
+
+(defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width)
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
(defun untabify-buffer-region (buffer offset1 offset2 tab-width)
(loop for offset = offset1 then (1+ offset)
@@ -411,14 +420,23 @@
(defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width)
(assert (eq (buffer mark1) (buffer mark2)))
- (untabify-buffer-region (buffer mark1) (offset mark1) (offset mark2)
- tab-width))
-
-(defmethod untabify-region ((offset integer) (mark mark) tab-width)
- (untabify-buffer-region (buffer mark) offset (offset mark) tab-width))
-
-(defmethod untabify-region ((mark mark) (offset integer) tab-width)
- (untabify-buffer-region (buffer mark) (offset mark) offset tab-width))
+ (let ((offset1 (offset mark1))
+ (offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
+
+(defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width)
+ (let ((offset2 (offset mark2)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width)))
+
+(defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width)
+ (let ((offset1 (offset mark1)))
+ (when (> offset1 offset2)
+ (rotatef offset1 offset2))
+ (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
Index: climacs/buffer-test.lisp
diff -u climacs/buffer-test.lisp:1.13 climacs/buffer-test.lisp:1.14
--- climacs/buffer-test.lisp:1.13 Sat Feb 5 22:34:43 2005
+++ climacs/buffer-test.lisp Sun Feb 6 01:03:26 2005
@@ -234,11 +234,14 @@
(let ((buffer (make-instance 'standard-buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(let ((m (make-instance 'standard-left-sticky-mark
- :buffer buffer :offset 3)))
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 5)))
(insert-sequence m "ClimacS")
(and (= (size buffer) 14)
(eq (buffer m) buffer)
(= (offset m) 3)
+ (= (offset m2) 12)
(buffer-sequence buffer 0 14))))
"cliClimacSmacs")
@@ -246,11 +249,14 @@
(let ((buffer (make-instance 'standard-buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(let ((m (make-instance 'standard-right-sticky-mark
- :buffer buffer :offset 3)))
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 5)))
(insert-sequence m "ClimacS")
(and (= (size buffer) 14)
(eq (buffer m) buffer)
(= (offset m) 10)
+ (= (offset m2) 12)
(buffer-sequence buffer 0 14))))
"cliClimacSmacs")
From abakic at common-lisp.net Sun Feb 6 00:03:33 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 6 Feb 2005 01:03:33 +0100 (CET)
Subject: [climacs-cvs] CVS update:
climacs/Persistent/persistent-base-test.lisp
climacs/Persistent/persistent-buffer-test.lisp
climacs/Persistent/persistent-buffer.lisp
Message-ID: <20050206000333.4732F884FE@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv12175/Persistent
Modified Files:
persistent-base-test.lisp persistent-buffer-test.lisp
persistent-buffer.lisp
Log Message:
Changes to (un)tabify-*region methods, and corresponding tests.
Initial tests for indent-line.
Date: Sun Feb 6 01:03:30 2005
Author: abakic
Index: climacs/Persistent/persistent-base-test.lisp
diff -u climacs/Persistent/persistent-base-test.lisp:1.4 climacs/Persistent/persistent-base-test.lisp:1.5
--- climacs/Persistent/persistent-base-test.lisp:1.4 Sat Jan 29 23:23:14 2005
+++ climacs/Persistent/persistent-base-test.lisp Sun Feb 6 01:03:29 2005
@@ -768,6 +768,110 @@
(offset m))))
"Cli Ma Cs climacs" 9)
+(deftest binseq-buffer-tabify-buffer-region.test-1
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::tabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest binseq-buffer-tabify-buffer-region.test-2
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::tabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest binseq-buffer-tabify-region.test-1
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 7)))
+ (tabify-region m2 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest binseq-buffer-tabify-region.test-2
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 3)))
+ (tabify-region 7 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest binseq-buffer-tabify-region.test-3
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 7)))
+ (tabify-region 3 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest binseq-buffer-untabify-buffer-region.test-1
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::untabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest binseq-buffer-untabify-buffer-region.test-2
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::untabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest binseq-buffer-untabify-region.test-1
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 5)))
+ (untabify-region m2 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest binseq-buffer-untabify-region.test-2
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 3)))
+ (untabify-region 5 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest binseq-buffer-untabify-region.test-3
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 5)))
+ (untabify-region 3 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest binseq-buffer-indent-line.test-1
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 0)))
+ (indent-line m 4 nil)
+ (buffer-sequence buffer 0 (size buffer))))
+ " climacs ")
+
+(deftest binseq-buffer-indent-line.test-2
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 0)))
+ (indent-line m 5 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ " climacs ")
+
;;; obinseq tests
(deftest obinseq-buffer-previous-line.test-1
@@ -1514,4 +1618,108 @@
(values
(buffer-sequence buffer 0 (size buffer))
(offset m))))
- "Cli Ma Cs" 9)
\ No newline at end of file
+ "Cli Ma Cs" 9)
+
+(deftest obinseq-buffer-tabify-buffer-region.test-1
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::tabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest obinseq-buffer-tabify-buffer-region.test-2
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::tabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest obinseq-buffer-tabify-region.test-1
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 7)))
+ (tabify-region m2 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest obinseq-buffer-tabify-region.test-2
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 3)))
+ (tabify-region 7 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest obinseq-buffer-tabify-region.test-3
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 7)))
+ (tabify-region 3 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest obinseq-buffer-untabify-buffer-region.test-1
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::untabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest obinseq-buffer-untabify-buffer-region.test-2
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "c l im acs")
+ (climacs-base::untabify-buffer-region buffer 0 (size buffer) 8)
+ (buffer-sequence buffer 0 (size buffer)))
+ "c l im acs")
+
+(deftest obinseq-buffer-untabify-region.test-1
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 5)))
+ (untabify-region m2 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest obinseq-buffer-untabify-region.test-2
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 3)))
+ (untabify-region 5 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest obinseq-buffer-untabify-region.test-3
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "clim acs")
+ (let ((m1 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 5)))
+ (untabify-region 3 m1 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ "clim acs")
+
+(deftest obinseq-buffer-indent-line.test-1
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 0)))
+ (indent-line m 4 nil)
+ (buffer-sequence buffer 0 (size buffer))))
+ " climacs ")
+
+(deftest obinseq-buffer-indent-line.test-2
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 0)))
+ (indent-line m 5 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ " climacs ")
Index: climacs/Persistent/persistent-buffer-test.lisp
diff -u climacs/Persistent/persistent-buffer-test.lisp:1.6 climacs/Persistent/persistent-buffer-test.lisp:1.7
--- climacs/Persistent/persistent-buffer-test.lisp:1.6 Sat Feb 5 22:34:44 2005
+++ climacs/Persistent/persistent-buffer-test.lisp Sun Feb 6 01:03:29 2005
@@ -248,11 +248,14 @@
(let ((buffer (make-instance 'binseq-buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(let ((m (make-instance 'persistent-left-sticky-mark
- :buffer buffer :offset 3)))
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 5)))
(insert-sequence m "ClimacS")
(and (= (size buffer) 14)
(eq (buffer m) buffer)
(= (offset m) 3)
+ (= (offset m2) 12)
(buffer-sequence buffer 0 14))))
"cliClimacSmacs")
@@ -260,11 +263,14 @@
(let ((buffer (make-instance 'binseq-buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(let ((m (make-instance 'persistent-right-sticky-mark
- :buffer buffer :offset 3)))
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 5)))
(insert-sequence m "ClimacS")
(and (= (size buffer) 14)
(eq (buffer m) buffer)
(= (offset m) 10)
+ (= (offset m2) 12)
(buffer-sequence buffer 0 14))))
"cliClimacSmacs")
@@ -1062,11 +1068,14 @@
(let ((buffer (make-instance 'obinseq-buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(let ((m (make-instance 'persistent-left-sticky-mark
- :buffer buffer :offset 3)))
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 5)))
(insert-sequence m "ClimacS")
(and (= (size buffer) 14)
(eq (buffer m) buffer)
(= (offset m) 3)
+ (= (offset m2) 12)
(buffer-sequence buffer 0 14))))
"cliClimacSmacs")
@@ -1074,11 +1083,14 @@
(let ((buffer (make-instance 'obinseq-buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(let ((m (make-instance 'persistent-right-sticky-mark
- :buffer buffer :offset 3)))
+ :buffer buffer :offset 3))
+ (m2 (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 5)))
(insert-sequence m "ClimacS")
(and (= (size buffer) 14)
(eq (buffer m) buffer)
(= (offset m) 10)
+ (= (offset m2) 12)
(buffer-sequence buffer 0 14))))
"cliClimacSmacs")
Index: climacs/Persistent/persistent-buffer.lisp
diff -u climacs/Persistent/persistent-buffer.lisp:1.4 climacs/Persistent/persistent-buffer.lisp:1.5
--- climacs/Persistent/persistent-buffer.lisp:1.4 Sat Feb 5 21:59:51 2005
+++ climacs/Persistent/persistent-buffer.lisp Sun Feb 6 01:03:29 2005
@@ -145,15 +145,15 @@
(setf high-mark (make-instance 'persistent-right-sticky-mark
:buffer buffer))))
-(defmethod clone-mark ((mark persistent-left-sticky-mark) &optional type)
- (unless type
- (setf type 'persistent-left-sticky-mark))
- (make-instance type :buffer (buffer mark) :offset (offset mark)))
+;; (defmethod clone-mark ((mark persistent-left-sticky-mark) &optional type)
+;; (unless type
+;; (setf type 'persistent-left-sticky-mark))
+;; (make-instance type :buffer (buffer mark) :offset (offset mark)))
-(defmethod clone-mark ((mark persistent-right-sticky-mark) &optional type)
- (unless type
- (setf type 'persistent-right-sticky-mark))
- (make-instance type :buffer (buffer mark) :offset (offset mark)))
+;; (defmethod clone-mark ((mark persistent-right-sticky-mark) &optional type)
+;; (unless type
+;; (setf type 'persistent-right-sticky-mark))
+;; (make-instance type :buffer (buffer mark) :offset (offset mark)))
(defmethod size ((buffer binseq-buffer))
(binseq-length (slot-value buffer 'contents)))
From abakic at common-lisp.net Sun Feb 6 16:33:52 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 6 Feb 2005 17:33:52 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/base-test.lisp climacs/base.lisp
Message-ID: <20050206163352.E3C4C88663@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv31702
Modified Files:
base-test.lisp base.lisp
Log Message:
Changes to indent-line, copyrights. Tests for indent-line.
Date: Sun Feb 6 17:33:50 2005
Author: abakic
Index: climacs/base-test.lisp
diff -u climacs/base-test.lisp:1.5 climacs/base-test.lisp:1.6
--- climacs/base-test.lisp:1.5 Sun Feb 6 01:03:26 2005
+++ climacs/base-test.lisp Sun Feb 6 17:33:50 2005
@@ -869,6 +869,15 @@
(deftest standard-buffer-indent-line.test-2
(let ((buffer (make-instance 'standard-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 0)))
+ (indent-line m 5 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ " climacs ")
+
+(deftest standard-buffer-indent-line.test-3
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'standard-right-sticky-mark
:buffer buffer :offset 0)))
(indent-line m 5 4)
Index: climacs/base.lisp
diff -u climacs/base.lisp:1.32 climacs/base.lisp:1.33
--- climacs/base.lisp:1.32 Sun Feb 6 01:03:26 2005
+++ climacs/base.lisp Sun Feb 6 17:33:50 2005
@@ -6,6 +6,8 @@
;;; Elliott Johnson (ejohnson at fasl.info)
;;; (c) copyright 2005 by
;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr)
+;;; (c) copyright 2005 by
+;;; Aleksandar Bakic (a_bakic at yahoo.com)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
@@ -442,22 +444,33 @@
;;;
;;; Indentation
-(defun indent-line (mark indentation tab-width)
- "Indent the line containing mark with indentation spaces. Use tabs and spaces
-if tab-width is not nil, otherwise use spaces only."
+(defgeneric indent-line (mark indentation tab-width)
+ (:documentation "Indent the line containing mark with indentation
+spaces. Use tabs and spaces if tab-width is not nil, otherwise use
+spaces only."))
+
+(defun indent-line* (mark indentation tab-width left)
(let ((mark2 (clone-mark mark)))
(beginning-of-line mark2)
(loop until (end-of-buffer-p mark2)
- as object = (object-after mark2)
- while (or (eql object #\Space) (eql object #\Tab))
- do (delete-range mark2 1))
+ as object = (object-after mark2)
+ while (or (eql object #\Space) (eql object #\Tab))
+ do (delete-range mark2 1))
(loop until (zerop indentation)
- do (cond ((and tab-width (>= indentation tab-width))
- (insert-object mark2 #\Tab)
- (decf indentation tab-width))
- (t
- (insert-object mark2 #\Space)
- (decf indentation))))))
+ do (cond ((and tab-width (>= indentation tab-width))
+ (insert-object mark2 #\Tab)
+ (when left ; spaces must follow tabs
+ (forward-object mark2))
+ (decf indentation tab-width))
+ (t
+ (insert-object mark2 #\Space)
+ (decf indentation))))))
+
+(defmethod indent-line ((mark left-sticky-mark) indentation tab-width)
+ (indent-line* mark indentation tab-width t))
+
+(defmethod indent-line ((mark right-sticky-mark) indentation tab-width)
+ (indent-line* mark indentation tab-width nil))
(defun delete-indentation (mark)
(beginning-of-line mark)
From abakic at common-lisp.net Sun Feb 6 16:33:58 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 6 Feb 2005 17:33:58 +0100 (CET)
Subject: [climacs-cvs] CVS update:
climacs/Persistent/persistent-base-test.lisp
climacs/Persistent/persistent-buffer.lisp
Message-ID: <20050206163358.D078B88663@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv31702/Persistent
Modified Files:
persistent-base-test.lisp persistent-buffer.lisp
Log Message:
Changes to indent-line, copyrights. Tests for indent-line.
Date: Sun Feb 6 17:33:52 2005
Author: abakic
Index: climacs/Persistent/persistent-base-test.lisp
diff -u climacs/Persistent/persistent-base-test.lisp:1.5 climacs/Persistent/persistent-base-test.lisp:1.6
--- climacs/Persistent/persistent-base-test.lisp:1.5 Sun Feb 6 01:03:29 2005
+++ climacs/Persistent/persistent-base-test.lisp Sun Feb 6 17:33:52 2005
@@ -866,6 +866,15 @@
(deftest binseq-buffer-indent-line.test-2
(let ((buffer (make-instance 'binseq-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 0)))
+ (indent-line m 5 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ " climacs ")
+
+(deftest binseq-buffer-indent-line.test-3
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'persistent-right-sticky-mark
:buffer buffer :offset 0)))
(indent-line m 5 4)
@@ -1716,6 +1725,15 @@
" climacs ")
(deftest obinseq-buffer-indent-line.test-2
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 0)))
+ (indent-line m 5 4)
+ (buffer-sequence buffer 0 (size buffer))))
+ " climacs ")
+
+(deftest obinseq-buffer-indent-line.test-3
(let ((buffer (make-instance 'obinseq-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'persistent-right-sticky-mark
Index: climacs/Persistent/persistent-buffer.lisp
diff -u climacs/Persistent/persistent-buffer.lisp:1.5 climacs/Persistent/persistent-buffer.lisp:1.6
--- climacs/Persistent/persistent-buffer.lisp:1.5 Sun Feb 6 01:03:29 2005
+++ climacs/Persistent/persistent-buffer.lisp Sun Feb 6 17:33:52 2005
@@ -145,16 +145,6 @@
(setf high-mark (make-instance 'persistent-right-sticky-mark
:buffer buffer))))
-;; (defmethod clone-mark ((mark persistent-left-sticky-mark) &optional type)
-;; (unless type
-;; (setf type 'persistent-left-sticky-mark))
-;; (make-instance type :buffer (buffer mark) :offset (offset mark)))
-
-;; (defmethod clone-mark ((mark persistent-right-sticky-mark) &optional type)
-;; (unless type
-;; (setf type 'persistent-right-sticky-mark))
-;; (make-instance type :buffer (buffer mark) :offset (offset mark)))
-
(defmethod size ((buffer binseq-buffer))
(binseq-length (slot-value buffer 'contents)))
From abakic at common-lisp.net Sun Feb 6 17:38:32 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 6 Feb 2005 18:38:32 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/base-test.lisp
Message-ID: <20050206173832.B877A88663@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv3178
Modified Files:
base-test.lisp
Log Message:
Extended tests of indent-line and added one test of delete-indentation.
Date: Sun Feb 6 18:38:31 2005
Author: abakic
Index: climacs/base-test.lisp
diff -u climacs/base-test.lisp:1.6 climacs/base-test.lisp:1.7
--- climacs/base-test.lisp:1.6 Sun Feb 6 17:33:50 2005
+++ climacs/base-test.lisp Sun Feb 6 18:38:31 2005
@@ -861,25 +861,44 @@
(let ((buffer (make-instance 'standard-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'standard-left-sticky-mark
- :buffer buffer :offset 0)))
+ :buffer buffer :offset 3)))
(indent-line m 4 nil)
- (buffer-sequence buffer 0 (size buffer))))
- " climacs ")
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 " climacs ")
(deftest standard-buffer-indent-line.test-2
(let ((buffer (make-instance 'standard-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'standard-left-sticky-mark
- :buffer buffer :offset 0)))
+ :buffer buffer :offset 4)))
(indent-line m 5 4)
- (buffer-sequence buffer 0 (size buffer))))
- " climacs ")
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 3 " climacs ")
(deftest standard-buffer-indent-line.test-3
(let ((buffer (make-instance 'standard-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'standard-right-sticky-mark
- :buffer buffer :offset 0)))
+ :buffer buffer :offset 3)))
(indent-line m 5 4)
- (buffer-sequence buffer 0 (size buffer))))
- " climacs ")
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 2 " climacs ")
+
+(deftest standard-buffer-delete-indentation.test-1
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "
+ climacs ")
+ (let ((m (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 3)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 1 "
+ climacs ")
From abakic at common-lisp.net Sun Feb 6 17:38:44 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 6 Feb 2005 18:38:44 +0100 (CET)
Subject: [climacs-cvs] CVS update:
climacs/Persistent/persistent-base-test.lisp
Message-ID: <20050206173844.412678869D@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv3178/Persistent
Modified Files:
persistent-base-test.lisp
Log Message:
Extended tests of indent-line and added one test of delete-indentation.
Date: Sun Feb 6 18:38:32 2005
Author: abakic
Index: climacs/Persistent/persistent-base-test.lisp
diff -u climacs/Persistent/persistent-base-test.lisp:1.6 climacs/Persistent/persistent-base-test.lisp:1.7
--- climacs/Persistent/persistent-base-test.lisp:1.6 Sun Feb 6 17:33:52 2005
+++ climacs/Persistent/persistent-base-test.lisp Sun Feb 6 18:38:32 2005
@@ -858,28 +858,34 @@
(let ((buffer (make-instance 'binseq-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'persistent-left-sticky-mark
- :buffer buffer :offset 0)))
+ :buffer buffer :offset 3)))
(indent-line m 4 nil)
- (buffer-sequence buffer 0 (size buffer))))
- " climacs ")
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 " climacs ")
(deftest binseq-buffer-indent-line.test-2
(let ((buffer (make-instance 'binseq-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'persistent-left-sticky-mark
- :buffer buffer :offset 0)))
+ :buffer buffer :offset 4)))
(indent-line m 5 4)
- (buffer-sequence buffer 0 (size buffer))))
- " climacs ")
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 3 " climacs ")
(deftest binseq-buffer-indent-line.test-3
(let ((buffer (make-instance 'binseq-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'persistent-right-sticky-mark
- :buffer buffer :offset 0)))
+ :buffer buffer :offset 3)))
(indent-line m 5 4)
- (buffer-sequence buffer 0 (size buffer))))
- " climacs ")
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 2 " climacs ")
;;; obinseq tests
@@ -1719,25 +1725,31 @@
(let ((buffer (make-instance 'obinseq-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'persistent-left-sticky-mark
- :buffer buffer :offset 0)))
+ :buffer buffer :offset 3)))
(indent-line m 4 nil)
- (buffer-sequence buffer 0 (size buffer))))
- " climacs ")
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 " climacs ")
(deftest obinseq-buffer-indent-line.test-2
(let ((buffer (make-instance 'obinseq-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'persistent-left-sticky-mark
- :buffer buffer :offset 0)))
+ :buffer buffer :offset 4)))
(indent-line m 5 4)
- (buffer-sequence buffer 0 (size buffer))))
- " climacs ")
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 3 " climacs ")
(deftest obinseq-buffer-indent-line.test-3
(let ((buffer (make-instance 'obinseq-buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
(let ((m (make-instance 'persistent-right-sticky-mark
- :buffer buffer :offset 0)))
+ :buffer buffer :offset 3)))
(indent-line m 5 4)
- (buffer-sequence buffer 0 (size buffer))))
- " climacs ")
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 2 " climacs ")
From rstrandh at common-lisp.net Mon Feb 7 15:26:42 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Mon, 7 Feb 2005 16:26:42 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/cl-syntax.lisp
climacs/climacs.asd climacs/packages.lisp
Message-ID: <20050207152642.2DC6E884FE@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv7778
Modified Files:
climacs.asd packages.lisp
Added Files:
cl-syntax.lisp
Log Message:
Beginning of a Common Lisp syntax that will be extended during the
spring by our group of students.
For now, it contains an incremental lexer that maintains the entire
buffer as a flexichain of `elements', i.e., syntactic elements that
are going to be meaningful to the incremental parser.
Date: Mon Feb 7 16:26:41 2005
Author: rstrandh
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.17 climacs/climacs.asd:1.18
--- climacs/climacs.asd:1.17 Wed Feb 2 08:59:41 2005
+++ climacs/climacs.asd Mon Feb 7 16:26:41 2005
@@ -62,6 +62,7 @@
"syntax"
"text-syntax"
"html-syntax"
+ "cl-syntax"
"kill-ring"
"undo"
"pane"
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.47 climacs/packages.lisp:1.48
--- climacs/packages.lisp:1.47 Sat Feb 5 08:04:03 2005
+++ climacs/packages.lisp Mon Feb 7 16:26:41 2005
@@ -89,6 +89,10 @@
#:beginning-of-paragraph #:end-of-paragraph
#:forward-to-error #:backward-to-error))
+(defpackage :climacs-cl-syntax
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain :climacs-syntax)
+ (:export))
+
(defpackage :climacs-kill-ring
(:use :clim-lisp :flexichain)
(:export #:kill-ring #:kill-ring-length #:kill-ring-max-size
From abakic at common-lisp.net Mon Feb 7 22:13:39 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Mon, 7 Feb 2005 23:13:39 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/base-test.lisp climacs/base.lisp
Message-ID: <20050207221339.728F288692@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv30269
Modified Files:
base-test.lisp base.lisp
Log Message:
Fixes to delete-indentation, tests.
Date: Mon Feb 7 23:13:38 2005
Author: abakic
Index: climacs/base-test.lisp
diff -u climacs/base-test.lisp:1.7 climacs/base-test.lisp:1.8
--- climacs/base-test.lisp:1.7 Sun Feb 6 18:38:31 2005
+++ climacs/base-test.lisp Mon Feb 7 23:13:37 2005
@@ -900,5 +900,66 @@
(values
(offset m)
(buffer-sequence buffer 0 (size buffer)))))
+ 0 "climacs ")
+
+(deftest standard-buffer-delete-indentation.test-2
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "
+ climacs ")
+ (let ((m (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 7)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 "climacs ")
+
+(deftest standard-buffer-delete-indentation.test-3
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'standard-left-sticky-mark
+ :buffer buffer :offset 7)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 " climacs ")
+
+(deftest standard-buffer-delete-indentation.test-4
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs
+ climacs ")
+ (let ((m (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 12)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 8 "climacs climacs ")
+
+(deftest standard-buffer-delete-indentation.test-5
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "
+
+ climacs ")
+ (let ((m (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 12)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
1 "
- climacs ")
+climacs ")
+
+(deftest standard-buffer-fill-line.test-1
+ (let ((buffer (make-instance 'standard-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs climacs climacs")
+ (let ((m (make-instance 'standard-right-sticky-mark
+ :buffer buffer :offset 25)))
+ (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 27 "climacs
+ climacs
+ climacs")
Index: climacs/base.lisp
diff -u climacs/base.lisp:1.33 climacs/base.lisp:1.34
--- climacs/base.lisp:1.33 Sun Feb 6 17:33:50 2005
+++ climacs/base.lisp Mon Feb 7 23:13:37 2005
@@ -475,13 +475,16 @@
(defun delete-indentation (mark)
(beginning-of-line mark)
(unless (beginning-of-buffer-p mark)
+ (delete-range mark -1)
(loop until (end-of-buffer-p mark)
while (whitespacep (object-after mark))
do (delete-range mark 1))
(loop until (beginning-of-buffer-p mark)
while (whitespacep (object-before mark))
do (delete-range mark -1))
- (insert-object mark #\Space)))
+ (when (and (not (beginning-of-buffer-p mark))
+ (constituentp (object-before mark)))
+ (insert-object mark #\Space))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -505,7 +508,7 @@
(t
(incf column)))
(when (and (>= column fill-column)
- (/= (offset begin-mark) line-beginning-offset))
+ (/= (offset begin-mark) line-beginning-offset))
(insert-object begin-mark #\Newline)
(incf (offset begin-mark))
(let ((indentation
From abakic at common-lisp.net Mon Feb 7 22:13:42 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Mon, 7 Feb 2005 23:13:42 +0100 (CET)
Subject: [climacs-cvs] CVS update:
climacs/Persistent/persistent-base-test.lisp
Message-ID: <20050207221342.0ECFB886A3@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv30269/Persistent
Modified Files:
persistent-base-test.lisp
Log Message:
Fixes to delete-indentation, tests.
Date: Mon Feb 7 23:13:39 2005
Author: abakic
Index: climacs/Persistent/persistent-base-test.lisp
diff -u climacs/Persistent/persistent-base-test.lisp:1.7 climacs/Persistent/persistent-base-test.lisp:1.8
--- climacs/Persistent/persistent-base-test.lisp:1.7 Sun Feb 6 18:38:32 2005
+++ climacs/Persistent/persistent-base-test.lisp Mon Feb 7 23:13:39 2005
@@ -887,6 +887,67 @@
(buffer-sequence buffer 0 (size buffer)))))
2 " climacs ")
+(deftest binseq-buffer-delete-indentation.test-1
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "
+ climacs ")
+ (let ((m (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 3)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 "climacs ")
+
+(deftest binseq-buffer-delete-indentation.test-2
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "
+ climacs ")
+ (let ((m (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 7)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 "climacs ")
+
+(deftest binseq-buffer-delete-indentation.test-3
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 7)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 " climacs ")
+
+(deftest binseq-buffer-delete-indentation.test-4
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs
+ climacs ")
+ (let ((m (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 12)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 8 "climacs climacs ")
+
+(deftest binseq-buffer-delete-indentation.test-5
+ (let ((buffer (make-instance 'binseq-buffer)))
+ (insert-buffer-sequence buffer 0 "
+
+ climacs ")
+ (let ((m (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 12)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 1 "
+climacs ")
+
;;; obinseq tests
(deftest obinseq-buffer-previous-line.test-1
@@ -1753,3 +1814,64 @@
(offset m)
(buffer-sequence buffer 0 (size buffer)))))
2 " climacs ")
+
+(deftest obinseq-buffer-delete-indentation.test-1
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "
+ climacs ")
+ (let ((m (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 3)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 "climacs ")
+
+(deftest obinseq-buffer-delete-indentation.test-2
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "
+ climacs ")
+ (let ((m (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 7)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 "climacs ")
+
+(deftest obinseq-buffer-delete-indentation.test-3
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 " climacs ")
+ (let ((m (make-instance 'persistent-left-sticky-mark
+ :buffer buffer :offset 7)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 0 " climacs ")
+
+(deftest obinseq-buffer-delete-indentation.test-4
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "climacs
+ climacs ")
+ (let ((m (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 12)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 8 "climacs climacs ")
+
+(deftest obinseq-buffer-delete-indentation.test-5
+ (let ((buffer (make-instance 'obinseq-buffer)))
+ (insert-buffer-sequence buffer 0 "
+
+ climacs ")
+ (let ((m (make-instance 'persistent-right-sticky-mark
+ :buffer buffer :offset 12)))
+ (delete-indentation m)
+ (values
+ (offset m)
+ (buffer-sequence buffer 0 (size buffer)))))
+ 1 "
+climacs ")
From abakic at common-lisp.net Tue Feb 8 00:39:36 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Tue, 8 Feb 2005 01:39:36 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/TODO
Message-ID: <20050208003936.706EE88692@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv6109
Added Files:
TODO
Log Message:
Initial TODO file.
Date: Tue Feb 8 01:39:35 2005
Author: abakic
From rstrandh at common-lisp.net Tue Feb 8 05:25:07 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Tue, 8 Feb 2005 06:25:07 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/TODO
Message-ID: <20050208052507.55D7088692@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv21119
Modified Files:
TODO
Log Message:
A few more major items.
Date: Tue Feb 8 06:25:06 2005
Author: rstrandh
Index: climacs/TODO
diff -u climacs/TODO:1.1 climacs/TODO:1.2
--- climacs/TODO:1.1 Tue Feb 8 01:39:33 2005
+++ climacs/TODO Tue Feb 8 06:25:05 2005
@@ -6,3 +6,9 @@
upgrade it to an undoable buffer
- refactor tests
+
+- handle wrapped lines instead of making McCLIM handle them
+
+- replace the use of the scroller pane by custom pane
+
+- invoke redisplay after resize
From abakic at common-lisp.net Thu Feb 10 00:27:14 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Thu, 10 Feb 2005 01:27:14 +0100 (CET)
Subject: [climacs-cvs] CVS update:
climacs/Persistent/persistent-base-test.lisp
climacs/Persistent/persistent-buffer-test.lisp
Message-ID: <20050210002714.D44D38864C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv27993/Persistent
Removed Files:
persistent-base-test.lisp persistent-buffer-test.lisp
Log Message:
Test refactoring.
Date: Thu Feb 10 01:27:11 2005
Author: abakic
From abakic at common-lisp.net Thu Feb 10 00:27:11 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Thu, 10 Feb 2005 01:27:11 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/TODO climacs/base-test.lisp
climacs/buffer-test.lisp climacs/climacs.asd
Message-ID: <20050210002711.DCAC98864C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv27993
Modified Files:
TODO base-test.lisp buffer-test.lisp climacs.asd
Log Message:
Test refactoring.
Date: Thu Feb 10 01:27:07 2005
Author: abakic
Index: climacs/TODO
diff -u climacs/TODO:1.2 climacs/TODO:1.3
--- climacs/TODO:1.2 Tue Feb 8 06:25:05 2005
+++ climacs/TODO Thu Feb 10 01:27:07 2005
@@ -5,8 +5,6 @@
one sequence type for lines, the other for line contents), then
upgrade it to an undoable buffer
-- refactor tests
-
- handle wrapped lines instead of making McCLIM handle them
- replace the use of the scroller pane by custom pane
Index: climacs/base-test.lisp
diff -u climacs/base-test.lisp:1.8 climacs/base-test.lisp:1.9
--- climacs/base-test.lisp:1.8 Mon Feb 7 23:13:37 2005
+++ climacs/base-test.lisp Thu Feb 10 01:27:07 2005
@@ -5,288 +5,288 @@
(in-package :climacs-tests)
-(deftest standard-buffer-previous-line.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest previous-line.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 8)))
(previous-line mark)
(offset mark)))
0)
-(deftest standard-buffer-previous-line.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest previous-line.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 11)))
(previous-line mark 2)
(offset mark)))
2)
-(deftest standard-buffer-previous-line.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest previous-line.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 7)))
(previous-line mark)
(offset mark)))
7)
-(deftest standard-buffer-previous-line.test-4
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest previous-line.test-4
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 7)))
(previous-line mark 2)
(offset mark)))
2)
-(deftest standard-buffer-previous-line.test-5
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest previous-line.test-5
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 0)))
(previous-line mark)
(offset mark)))
0)
-(deftest standard-buffer-previous-line.test-6
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest previous-line.test-6
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 0)))
(previous-line mark 2)
(offset mark)))
2)
-(deftest standard-buffer-previous-line.test-7
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest previous-line.test-7
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs2")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 15)))
(previous-line mark)
(offset mark)))
7)
-(deftest standard-buffer-next-line.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest next-line.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 6)))
(next-line mark)
(offset mark)))
14)
-(deftest standard-buffer-next-line.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest next-line.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 3)))
(next-line mark 2)
(offset mark)))
10)
-(deftest standard-buffer-next-line.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest next-line.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 8)))
(next-line mark)
(offset mark)))
8)
-(deftest standard-buffer-next-line.test-4
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest next-line.test-4
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 8)))
(next-line mark 2)
(offset mark)))
10)
-(deftest standard-buffer-next-line.test-5
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest next-line.test-5
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 15)))
(next-line mark)
(offset mark)))
15)
-(deftest standard-buffer-next-line.test-6
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest next-line.test-6
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 15)))
(next-line mark 2)
(offset mark)))
10)
-(deftest standard-buffer-next-line.test-7
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest next-line.test-7
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 0)))
(next-line mark)
(offset mark)))
8)
-(deftest standard-buffer-open-line.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest open-line.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 0)))
(open-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"
climacs" 0)
-(deftest standard-buffer-open-line.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest open-line.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 0)))
(open-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"
climacs" 0)
-(deftest standard-buffer-open-line.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest open-line.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 7)))
(open-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacs
" 7)
-(deftest standard-buffer-open-line.test-4
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest open-line.test-4
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 7)))
(open-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacs
" 7)
-(deftest standard-buffer-kill-line.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest kill-line.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 0)))
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
#() 0)
-(deftest standard-buffer-kill-line.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest kill-line.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 0)))
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
#() 0)
-(deftest standard-buffer-kill-line.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest kill-line.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 7)))
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacs" 7)
-(deftest standard-buffer-kill-line.test-4
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest kill-line.test-4
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 7)))
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacs" 7)
-(deftest standard-buffer-kill-line.test-5
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest kill-line.test-5
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-left-sticky-mark
+ (let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 7)))
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacsclimacs" 7)
-(deftest standard-buffer-kill-line.test-6
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest kill-line.test-6
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance 'standard-right-sticky-mark
+ (let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 7)))
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacsclimacs" 7)
-(deftest standard-buffer-empty-line-p.test-1
- (let* ((buffer (make-instance 'standard-buffer))
- (m1 (make-instance 'standard-left-sticky-mark :buffer buffer))
- (m2 (make-instance 'standard-right-sticky-mark :buffer buffer)))
+(defmultitest empty-line-p.test-1
+ (let* ((buffer (make-instance %%buffer))
+ (m1 (make-instance %%left-sticky-mark :buffer buffer))
+ (m2 (make-instance %%right-sticky-mark :buffer buffer)))
(values (empty-line-p m1) (empty-line-p m2)))
t t)
-(deftest standard-buffer-empty-line-p.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest empty-line-p.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-object buffer 0 #\a)
- (let ((m1 (make-instance 'standard-left-sticky-mark :buffer buffer))
- (m2 (make-instance 'standard-right-sticky-mark :buffer buffer)))
+ (let ((m1 (make-instance %%left-sticky-mark :buffer buffer))
+ (m2 (make-instance %%right-sticky-mark :buffer buffer)))
(values (empty-line-p m1) (empty-line-p m2))))
nil nil)
-(deftest standard-buffer-empty-line-p.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest empty-line-p.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-object buffer 0 #\a)
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 1))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 1)))
(values (empty-line-p m1) (empty-line-p m2))))
nil nil)
-(deftest standard-buffer-empty-line-p.test-4
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest empty-line-p.test-4
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "a
b")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 1))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 1)))
(values (empty-line-p m1) (empty-line-p m2))))
nil nil)
-(deftest standard-buffer-line-indentation.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest line-indentation.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 0))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 0))
- (m3 (make-instance 'standard-left-sticky-mark
+ (m3 (make-instance %%left-sticky-mark
:buffer buffer :offset 10))
- (m4 (make-instance 'standard-right-sticky-mark
+ (m4 (make-instance %%right-sticky-mark
:buffer buffer :offset 10)))
(values
(line-indentation m1 8)
@@ -299,16 +299,16 @@
(offset m4))))
10 10 10 10 0 0 10 10)
-(deftest standard-buffer-line-indentation.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest line-indentation.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 0))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 0))
- (m3 (make-instance 'standard-left-sticky-mark
+ (m3 (make-instance %%left-sticky-mark
:buffer buffer :offset 11))
- (m4 (make-instance 'standard-right-sticky-mark
+ (m4 (make-instance %%right-sticky-mark
:buffer buffer :offset 11)))
(values
(line-indentation m1 8)
@@ -321,16 +321,16 @@
(offset m4))))
18 18 18 18 0 0 11 11)
-(deftest standard-buffer-line-indentation.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest line-indentation.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 0))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 0))
- (m3 (make-instance 'standard-left-sticky-mark
+ (m3 (make-instance %%left-sticky-mark
:buffer buffer :offset 11))
- (m4 (make-instance 'standard-right-sticky-mark
+ (m4 (make-instance %%right-sticky-mark
:buffer buffer :offset 11)))
(values
(line-indentation m1 8)
@@ -343,8 +343,8 @@
(offset m4))))
10 10 10 10 0 0 11 11)
-(deftest standard-buffer-buffer-number-of-lines-in-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest buffer-number-of-lines-in-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
(values
@@ -358,8 +358,8 @@
(climacs-base::buffer-number-of-lines-in-region buffer 8 14)))
0 0 1 1 1 1 0 0)
-(deftest standard-buffer-buffer-display-column.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest buffer-display-column.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " cli macs")
(values
(buffer-display-column buffer 0 8)
@@ -369,35 +369,35 @@
(buffer-display-column buffer 6 8)))
0 8 16 19 24)
-(deftest standard-buffer-number-of-lines-in-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest number-of-lines-in-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "
climacs
climacs
")
- (let ((m1l (make-instance 'standard-left-sticky-mark
+ (let ((m1l (make-instance %%left-sticky-mark
:buffer buffer :offset 0))
- (m1r (make-instance 'standard-right-sticky-mark
+ (m1r (make-instance %%right-sticky-mark
:buffer buffer :offset 0))
- (m2l (make-instance 'standard-left-sticky-mark
+ (m2l (make-instance %%left-sticky-mark
:buffer buffer :offset 1))
- (m2r (make-instance 'standard-left-sticky-mark
+ (m2r (make-instance %%left-sticky-mark
:buffer buffer :offset 1))
- (m3l (make-instance 'standard-left-sticky-mark
+ (m3l (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m3r (make-instance 'standard-right-sticky-mark
+ (m3r (make-instance %%right-sticky-mark
:buffer buffer :offset 3))
- (m4l (make-instance 'standard-left-sticky-mark
+ (m4l (make-instance %%left-sticky-mark
:buffer buffer :offset 8))
- (m4r (make-instance 'standard-right-sticky-mark
+ (m4r (make-instance %%right-sticky-mark
:buffer buffer :offset 8))
- (m5l (make-instance 'standard-left-sticky-mark
+ (m5l (make-instance %%left-sticky-mark
:buffer buffer :offset 15))
- (m5r (make-instance 'standard-right-sticky-mark
+ (m5r (make-instance %%right-sticky-mark
:buffer buffer :offset 15))
- (m6l (make-instance 'standard-left-sticky-mark
+ (m6l (make-instance %%left-sticky-mark
:buffer buffer :offset 16))
- (m6r (make-instance 'standard-right-sticky-mark
+ (m6r (make-instance %%right-sticky-mark
:buffer buffer :offset 16)))
(values
(number-of-lines-in-region m1l m1r)
@@ -420,17 +420,17 @@
(number-of-lines-in-region m3r m6l))))
0 0 1 1 1 1 1 1 1 1 1 1 1 0 0 0 2 1)
-(deftest standard-buffer-number-of-lines-in-region.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest number-of-lines-in-region.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m1l (make-instance 'standard-left-sticky-mark
+ (let ((m1l (make-instance %%left-sticky-mark
:buffer buffer :offset 6))
- (m1r (make-instance 'standard-right-sticky-mark
+ (m1r (make-instance %%right-sticky-mark
:buffer buffer :offset 6))
- (m2l (make-instance 'standard-left-sticky-mark
+ (m2l (make-instance %%left-sticky-mark
:buffer buffer :offset 7))
- (m2r (make-instance 'standard-right-sticky-mark
+ (m2r (make-instance %%right-sticky-mark
:buffer buffer :offset 7)))
(values
(number-of-lines-in-region m1l 10)
@@ -444,7 +444,7 @@
(number-of-lines-in-region 10 m2r))))
1 1 1 1 0 0 0 1 1)
-(deftest constituentp.test-1 ; NOTE: more tests may be needed for sbcl
+(defmultitest constituentp.test-1 ; NOTE: more tests may be needed for sbcl
(values
(constituentp #\a)
(constituentp #\Newline)
@@ -454,7 +454,7 @@
(constituentp #\Null))
t nil nil nil nil nil)
-(deftest whitespacep.test-1
+(defmultitest whitespacep.test-1
(values
(not (null (whitespacep #\a)))
(not (null (whitespacep #\Newline)))
@@ -464,21 +464,21 @@
(not (null (whitespacep #\Null))))
nil nil t t nil nil)
-(deftest standard-buffer-forward-to-word-boundary.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest forward-to-word-boundary.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs
climacs")
- (let ((m0l (make-instance 'standard-left-sticky-mark
+ (let ((m0l (make-instance %%left-sticky-mark
:buffer buffer :offset 0))
- (m0r (make-instance 'standard-right-sticky-mark
+ (m0r (make-instance %%right-sticky-mark
:buffer buffer :offset 0))
- (m1l (make-instance 'standard-left-sticky-mark
+ (m1l (make-instance %%left-sticky-mark
:buffer buffer :offset 5))
- (m1r (make-instance 'standard-right-sticky-mark
+ (m1r (make-instance %%right-sticky-mark
:buffer buffer :offset 5))
- (m2l (make-instance 'standard-left-sticky-mark
+ (m2l (make-instance %%left-sticky-mark
:buffer buffer :offset 17))
- (m2r (make-instance 'standard-right-sticky-mark
+ (m2r (make-instance %%right-sticky-mark
:buffer buffer :offset 17)))
(values
(progn (climacs-base::forward-to-word-boundary m0l) (offset m0l))
@@ -489,21 +489,21 @@
(progn (climacs-base::forward-to-word-boundary m2r) (offset m2r)))))
2 2 5 5 17 17)
-(deftest standard-buffer-backward-to-word-boundary.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest backward-to-word-boundary.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs ")
- (let ((m0l (make-instance 'standard-left-sticky-mark
+ (let ((m0l (make-instance %%left-sticky-mark
:buffer buffer :offset 17))
- (m0r (make-instance 'standard-right-sticky-mark
+ (m0r (make-instance %%right-sticky-mark
:buffer buffer :offset 17))
- (m1l (make-instance 'standard-left-sticky-mark
+ (m1l (make-instance %%left-sticky-mark
:buffer buffer :offset 10))
- (m1r (make-instance 'standard-right-sticky-mark
+ (m1r (make-instance %%right-sticky-mark
:buffer buffer :offset 10))
- (m2l (make-instance 'standard-left-sticky-mark
+ (m2l (make-instance %%left-sticky-mark
:buffer buffer :offset 0))
- (m2r (make-instance 'standard-right-sticky-mark
+ (m2r (make-instance %%right-sticky-mark
:buffer buffer :offset 0)))
(values
(progn (climacs-base::backward-to-word-boundary m0l) (offset m0l))
@@ -514,21 +514,21 @@
(progn (climacs-base::backward-to-word-boundary m2r) (offset m2r)))))
15 15 10 10 0 0)
-(deftest standard-buffer-forward-word.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest forward-word.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs
climacs")
- (let ((m0l (make-instance 'standard-left-sticky-mark
+ (let ((m0l (make-instance %%left-sticky-mark
:buffer buffer :offset 0))
- (m0r (make-instance 'standard-right-sticky-mark
+ (m0r (make-instance %%right-sticky-mark
:buffer buffer :offset 0))
- (m1l (make-instance 'standard-left-sticky-mark
+ (m1l (make-instance %%left-sticky-mark
:buffer buffer :offset 5))
- (m1r (make-instance 'standard-right-sticky-mark
+ (m1r (make-instance %%right-sticky-mark
:buffer buffer :offset 15))
- (m2l (make-instance 'standard-left-sticky-mark
+ (m2l (make-instance %%left-sticky-mark
:buffer buffer :offset 17))
- (m2r (make-instance 'standard-right-sticky-mark
+ (m2r (make-instance %%right-sticky-mark
:buffer buffer :offset 17)))
(values
(progn (forward-word m0l) (offset m0l))
@@ -539,21 +539,21 @@
(progn (forward-word m2r) (offset m2r)))))
9 9 9 17 17 17)
-(deftest standard-buffer-backward-word.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest backward-word.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs ")
- (let ((m0l (make-instance 'standard-left-sticky-mark
+ (let ((m0l (make-instance %%left-sticky-mark
:buffer buffer :offset 17))
- (m0r (make-instance 'standard-right-sticky-mark
+ (m0r (make-instance %%right-sticky-mark
:buffer buffer :offset 17))
- (m1l (make-instance 'standard-left-sticky-mark
+ (m1l (make-instance %%left-sticky-mark
:buffer buffer :offset 10))
- (m1r (make-instance 'standard-right-sticky-mark
+ (m1r (make-instance %%right-sticky-mark
:buffer buffer :offset 5))
- (m2l (make-instance 'standard-left-sticky-mark
+ (m2l (make-instance %%left-sticky-mark
:buffer buffer :offset 0))
- (m2r (make-instance 'standard-right-sticky-mark
+ (m2r (make-instance %%right-sticky-mark
:buffer buffer :offset 0)))
(values
(progn (backward-word m0l) (offset m0l))
@@ -564,10 +564,10 @@
(progn (backward-word m2r) (offset m2r)))))
8 8 8 0 0 0)
-(deftest standard-buffer-delete-word.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-word.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 3)))
(delete-word m)
(values
@@ -575,10 +575,10 @@
(offset m))))
"cli" 3)
-(deftest standard-buffer-delete-word.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-word.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs climacs")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 0)))
(delete-word m 2)
(values
@@ -586,10 +586,10 @@
(offset m))))
#() 0)
-(deftest standard-buffer-backward-delete-word.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest backward-delete-word.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 3)))
(backward-delete-word m)
(values
@@ -597,10 +597,10 @@
(offset m))))
"macs" 0)
-(deftest standard-buffer-backward-delete-word.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest backward-delete-word.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs climacs ")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 17)))
(backward-delete-word m 2)
(values
@@ -608,14 +608,14 @@
(offset m))))
#() 0)
-(deftest standard-buffer-previous-word.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest previous-word.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs climacs")
- (let ((m0 (make-instance 'standard-right-sticky-mark
+ (let ((m0 (make-instance %%right-sticky-mark
:buffer buffer :offset 7))
- (m1 (make-instance 'standard-left-sticky-mark
+ (m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 8))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 10)))
(values
(climacs-base::previous-word m0)
@@ -623,46 +623,46 @@
(climacs-base::previous-word m2))))
"climacs" #() "cl")
-(deftest standard-buffer-downcase-buffer-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest downcase-buffer-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "CLi mac5")
(climacs-base::downcase-buffer-region buffer 1 (size buffer))
(buffer-sequence buffer 0 (size buffer)))
"Cli mac5")
-(deftest standard-buffer-downcase-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest downcase-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 1))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 8)))
(downcase-region m2 m1)
(buffer-sequence buffer 0 (size buffer))))
"_cli mac5_")
-(deftest standard-buffer-downcase-region.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest downcase-region.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance 'standard-right-sticky-mark
+ (let ((m1 (make-instance %%right-sticky-mark
:buffer buffer :offset 1)))
(downcase-region 8 m1)
(buffer-sequence buffer 0 (size buffer))))
"_cli mac5_")
-(deftest standard-buffer-downcase-region.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest downcase-region.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 8)))
(downcase-region 1 m1)
(buffer-sequence buffer 0 (size buffer))))
"_cli mac5_")
-(deftest standard-buffer-downcase-word.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest downcase-word.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "CLI MA CS CLIMACS")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 0)))
(downcase-word m 3)
(values
@@ -670,46 +670,46 @@
(offset m))))
"cli ma cs CLIMACS" 9)
-(deftest standard-buffer-upcase-buffer-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest upcase-buffer-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "cli mac5")
(climacs-base::upcase-buffer-region buffer 1 (size buffer))
(buffer-sequence buffer 0 (size buffer)))
"cLI MAC5")
-(deftest standard-buffer-upcase-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest upcase-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 1))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 8)))
(upcase-region m2 m1)
(buffer-sequence buffer 0 (size buffer))))
"_CLI MAC5_")
-(deftest standard-buffer-upcase-region.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest upcase-region.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance 'standard-right-sticky-mark
+ (let ((m1 (make-instance %%right-sticky-mark
:buffer buffer :offset 1)))
(upcase-region 8 m1)
(buffer-sequence buffer 0 (size buffer))))
"_CLI MAC5_")
-(deftest standard-buffer-upcase-region.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest upcase-region.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 8)))
(upcase-region 1 m1)
(buffer-sequence buffer 0 (size buffer))))
"_CLI MAC5_")
-(deftest standard-buffer-upcase-word.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest upcase-word.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "cli ma cs climacs")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 0)))
(upcase-word m 3)
(values
@@ -717,53 +717,53 @@
(offset m))))
"CLI MA CS climacs" 9)
-(deftest standard-buffer-capitalize-buffer-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest capitalize-buffer-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "cli ma cs")
(climacs-base::capitalize-buffer-region buffer 1 (size buffer))
(buffer-sequence buffer 0 (size buffer)))
"cLi Ma Cs")
-(deftest standard-buffer-capitalize-buffer-region.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest capitalize-buffer-region.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "CLI mA Cs")
(climacs-base::capitalize-buffer-region buffer 0 (size buffer))
(buffer-sequence buffer 0 (size buffer)))
"Cli Ma Cs")
-(deftest standard-buffer-capitalize-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest capitalize-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 1))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 8)))
(capitalize-region m2 m1)
(buffer-sequence buffer 0 (size buffer))))
"_Cli Mac5_")
-(deftest standard-buffer-capitalize-region.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest capitalize-region.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance 'standard-right-sticky-mark
+ (let ((m1 (make-instance %%right-sticky-mark
:buffer buffer :offset 1)))
(capitalize-region 8 m1)
(buffer-sequence buffer 0 (size buffer))))
"_Cli Mac5_")
-(deftest standard-buffer-capitalize-region.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest capitalize-region.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 8)))
(capitalize-region 1 m1)
(buffer-sequence buffer 0 (size buffer))))
"_Cli Mac5_")
-(deftest standard-buffer-capitalize-word.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest capitalize-word.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "cli ma cs climacs")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 0)))
(capitalize-word m 3)
(values
@@ -771,96 +771,96 @@
(offset m))))
"Cli Ma Cs climacs" 9)
-(deftest standard-buffer-tabify-buffer-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest tabify-buffer-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "c l im acs")
(climacs-base::tabify-buffer-region buffer 0 (size buffer) 8)
(buffer-sequence buffer 0 (size buffer)))
"c l im acs")
-(deftest standard-buffer-tabify-buffer-region.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest tabify-buffer-region.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "c l im acs")
(climacs-base::tabify-buffer-region buffer 0 (size buffer) 8)
(buffer-sequence buffer 0 (size buffer)))
"c l im acs")
-(deftest standard-buffer-tabify-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest tabify-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 7)))
(tabify-region m2 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
-(deftest standard-buffer-tabify-region.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest tabify-region.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance 'standard-right-sticky-mark
+ (let ((m1 (make-instance %%right-sticky-mark
:buffer buffer :offset 3)))
(tabify-region 7 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
-(deftest standard-buffer-tabify-region.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest tabify-region.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 7)))
(tabify-region 3 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
-(deftest standard-buffer-untabify-buffer-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest untabify-buffer-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "c l im acs")
(climacs-base::untabify-buffer-region buffer 0 (size buffer) 8)
(buffer-sequence buffer 0 (size buffer)))
"c l im acs")
-(deftest standard-buffer-untabify-buffer-region.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest untabify-buffer-region.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "c l im acs")
(climacs-base::untabify-buffer-region buffer 0 (size buffer) 8)
(buffer-sequence buffer 0 (size buffer)))
"c l im acs")
-(deftest standard-buffer-untabify-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest untabify-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 5)))
(untabify-region m2 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
-(deftest standard-buffer-untabify-region.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest untabify-region.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance 'standard-right-sticky-mark
+ (let ((m1 (make-instance %%right-sticky-mark
:buffer buffer :offset 3)))
(untabify-region 5 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
-(deftest standard-buffer-untabify-region.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest untabify-region.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 5)))
(untabify-region 3 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
-(deftest standard-buffer-indent-line.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest indent-line.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 3)))
(indent-line m 4 nil)
(values
@@ -868,10 +868,10 @@
(buffer-sequence buffer 0 (size buffer)))))
0 " climacs ")
-(deftest standard-buffer-indent-line.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest indent-line.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 4)))
(indent-line m 5 4)
(values
@@ -879,10 +879,10 @@
(buffer-sequence buffer 0 (size buffer)))))
3 " climacs ")
-(deftest standard-buffer-indent-line.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest indent-line.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 3)))
(indent-line m 5 4)
(values
@@ -890,11 +890,11 @@
(buffer-sequence buffer 0 (size buffer)))))
2 " climacs ")
-(deftest standard-buffer-delete-indentation.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-indentation.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "
climacs ")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 3)))
(delete-indentation m)
(values
@@ -902,11 +902,11 @@
(buffer-sequence buffer 0 (size buffer)))))
0 "climacs ")
-(deftest standard-buffer-delete-indentation.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-indentation.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "
climacs ")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 7)))
(delete-indentation m)
(values
@@ -914,10 +914,10 @@
(buffer-sequence buffer 0 (size buffer)))))
0 "climacs ")
-(deftest standard-buffer-delete-indentation.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-indentation.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 7)))
(delete-indentation m)
(values
@@ -925,11 +925,11 @@
(buffer-sequence buffer 0 (size buffer)))))
0 " climacs ")
-(deftest standard-buffer-delete-indentation.test-4
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-indentation.test-4
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs ")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 12)))
(delete-indentation m)
(values
@@ -937,12 +937,12 @@
(buffer-sequence buffer 0 (size buffer)))))
8 "climacs climacs ")
-(deftest standard-buffer-delete-indentation.test-5
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-indentation.test-5
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "
climacs ")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 12)))
(delete-indentation m)
(values
@@ -951,10 +951,10 @@
1 "
climacs ")
-(deftest standard-buffer-fill-line.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest fill-line.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs climacs climacs")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 25)))
(fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8)
(values
Index: climacs/buffer-test.lisp
diff -u climacs/buffer-test.lisp:1.14 climacs/buffer-test.lisp:1.15
--- climacs/buffer-test.lisp:1.14 Sun Feb 6 01:03:26 2005
+++ climacs/buffer-test.lisp Thu Feb 10 01:27:07 2005
@@ -8,8 +8,40 @@
(cl:in-package :climacs-tests)
-(deftest standard-buffer-make-instance.test-1
- (let* ((buffer (make-instance 'standard-buffer))
+(defmacro defmultitest (name form &rest results)
+ (let ((name-string (symbol-name name)))
+ (flet ((%deftest-wrapper (bc lsm rsm tn f rs)
+ (let ((alist (list (cons '%%buffer bc)
+ (cons '%%left-sticky-mark lsm)
+ (cons '%%right-sticky-mark rsm))))
+ `(deftest ,tn
+ ,(sublis alist f)
+ ,@(mapcar (lambda (r) (sublis alist r)) rs)))))
+ `(progn
+ ,(%deftest-wrapper
+ ''standard-buffer
+ ''standard-left-sticky-mark
+ ''standard-right-sticky-mark
+ (intern (concatenate 'string "STANDARD-BUFFER-" name-string))
+ form
+ results)
+ ,(%deftest-wrapper
+ ''binseq-buffer
+ ''persistent-left-sticky-mark
+ ''persistent-right-sticky-mark
+ (intern (concatenate 'string "BINSEQ-BUFFER-" name-string))
+ form
+ results)
+ ,(%deftest-wrapper
+ ''obinseq-buffer
+ ''persistent-left-sticky-mark
+ ''persistent-right-sticky-mark
+ (intern (concatenate 'string "OBINSEQ-BUFFER-" name-string))
+ form
+ results)))))
+
+(defmultitest buffer-make-instance.test-1
+ (let* ((buffer (make-instance %%buffer))
(low (slot-value buffer 'low-mark))
(high (slot-value buffer 'high-mark)))
(and (= (offset low) 0)
@@ -19,34 +51,34 @@
(eq (buffer high) buffer)))
t)
-(deftest standard-buffer-mark-make-instance.test-1
+(defmultitest mark-make-instance.test-1
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
- (make-instance 'standard-left-sticky-mark :buffer buffer :offset 1))
+ (let ((buffer (make-instance %%buffer)))
+ (make-instance %%left-sticky-mark :buffer buffer :offset 1))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 1)))
t)
-(deftest standard-buffer-mark-make-instance.test-2
+(defmultitest mark-make-instance.test-2
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
- (make-instance 'standard-right-sticky-mark :buffer buffer :offset 1))
+ (let ((buffer (make-instance %%buffer)))
+ (make-instance %%right-sticky-mark :buffer buffer :offset 1))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 1)))
t)
-(deftest standard-buffer-clone-mark.test-1
+(defmultitest clone-mark.test-1
(flet ((%all-eq (&optional x y)
(cond
((null x) nil)
(t (when (eq x y) y)))))
- (let* ((buffer (make-instance 'standard-buffer))
+ (let* ((buffer (make-instance %%buffer))
(low (slot-value buffer 'low-mark))
(high (slot-value buffer 'high-mark))
(low2 (clone-mark low))
(high2 (clone-mark high))
- (low3 (clone-mark high 'standard-left-sticky-mark))
- (high3 (clone-mark low 'standard-right-sticky-mark)))
+ (low3 (clone-mark high %%left-sticky-mark))
+ (high3 (clone-mark low %%right-sticky-mark)))
(and (reduce #'%all-eq
(list (class-of low) (class-of low2) (class-of low3)))
(reduce #'%all-eq
@@ -58,8 +90,8 @@
;;; NOTE: the current implementation uses vectors wherever sequences are
;;; expected (and strings are vectors of characters)
-(deftest standard-buffer-insert-buffer-object.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-buffer-object.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-object buffer 0 #\a)
(values
(offset (low-mark buffer))
@@ -69,8 +101,8 @@
(buffer-sequence buffer 0 1)))
0 1 t 1 "a")
-(deftest standard-buffer-insert-buffer-object.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-buffer-object.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-object buffer 0 #\b)
(insert-buffer-object buffer 0 #\a)
(values
@@ -81,8 +113,8 @@
(buffer-sequence buffer 0 2)))
0 2 t 2 "ab")
-(deftest standard-buffer-insert-buffer-object.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-buffer-object.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-object buffer 0 #\b)
(insert-buffer-object buffer 1 #\a)
(values
@@ -93,66 +125,66 @@
(buffer-sequence buffer 0 2)))
0 2 t 2 "ba")
-(deftest standard-buffer-insert-buffer-object.test-4
+(defmultitest insert-buffer-object.test-4
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-object buffer 1 #\a))
(error (c)
(= (climacs-buffer::condition-offset c) 1)))
t)
-(deftest standard-buffer-insert-buffer-object.test-5
+(defmultitest insert-buffer-object.test-5
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-object buffer -1 #\a))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
-(deftest standard-buffer-insert-buffer-sequence.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-buffer-sequence.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(and (= (size buffer) 7) (buffer-sequence buffer 0 7)))
"climacs")
-(deftest standard-buffer-insert-buffer-sequence.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-buffer-sequence.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer 3 "ClimacS")
(and (= (size buffer) 14) (buffer-sequence buffer 0 14)))
"cliClimacSmacs")
-(deftest standard-buffer-insert-buffer-sequence.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-buffer-sequence.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer 0 "ClimacS")
(and (= (size buffer) 14) (buffer-sequence buffer 0 14)))
"ClimacSclimacs")
-(deftest standard-buffer-insert-buffer-sequence.test-4
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-buffer-sequence.test-4
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "")
(and (= (size buffer) 0) (buffer-sequence buffer 0 0)))
"")
-(deftest standard-buffer-insert-buffer-sequence.test-5
+(defmultitest insert-buffer-sequence.test-5
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 1 "climacs"))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 1)))
t)
-(deftest standard-buffer-insert-buffer-sequence.test-6
+(defmultitest insert-buffer-sequence.test-6
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer -1 "climacs"))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
-(deftest standard-buffer-delete-buffer-range.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-buffer-range.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(delete-buffer-range buffer 0 7)
(values
@@ -162,8 +194,8 @@
(size buffer)))
0 0 t 0)
-(deftest standard-buffer-delete-buffer-range.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-buffer-range.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(delete-buffer-range buffer 0 3)
(values
@@ -174,42 +206,42 @@
(buffer-sequence buffer 0 4)))
0 4 t 4 "macs")
-(deftest standard-buffer-delete-buffer-range.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-buffer-range.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(delete-buffer-range buffer 3 4)
(and (= (size buffer) 3) (buffer-sequence buffer 0 3)))
"cli")
-(deftest standard-buffer-delete-buffer-range.test-4
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-buffer-range.test-4
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(delete-buffer-range buffer 3 0)
(and (= (size buffer) 7) (buffer-sequence buffer 0 7)))
"climacs")
-(deftest standard-buffer-delete-buffer-range.test-5
+(defmultitest delete-buffer-range.test-5
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(delete-buffer-range buffer -1 0))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
-(deftest standard-buffer-delete-buffer-range.test-6
+(defmultitest delete-buffer-range.test-6
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(delete-buffer-range buffer 6 2))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 8)))
t)
-(deftest standard-buffer-insert-object.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-object.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 3)))
(insert-object m #\X)
(and (= (size buffer) 8)
@@ -218,10 +250,10 @@
(buffer-sequence buffer 0 8))))
"cliXmacs")
-(deftest standard-buffer-insert-object.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-object.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 3)))
(insert-object m #\X)
(and (= (size buffer) 8)
@@ -230,12 +262,12 @@
(buffer-sequence buffer 0 8))))
"cliXmacs")
-(deftest standard-buffer-insert-sequence.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-sequence.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-left-sticky-mark
+ (m2 (make-instance %%left-sticky-mark
:buffer buffer :offset 5)))
(insert-sequence m "ClimacS")
(and (= (size buffer) 14)
@@ -245,12 +277,12 @@
(buffer-sequence buffer 0 14))))
"cliClimacSmacs")
-(deftest standard-buffer-insert-sequence.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest insert-sequence.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 5)))
(insert-sequence m "ClimacS")
(and (= (size buffer) 14)
@@ -260,12 +292,12 @@
(buffer-sequence buffer 0 14))))
"cliClimacSmacs")
-(deftest standard-buffer-delete-range.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-range.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-left-sticky-mark
+ (m2 (make-instance %%left-sticky-mark
:buffer buffer :offset 5)))
(delete-range m 2)
(and (= (size buffer) 5)
@@ -276,12 +308,12 @@
(buffer-sequence buffer 0 5))))
"clics")
-(deftest standard-buffer-delete-range.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-range.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 5)))
(delete-range m -2)
(and (= (size buffer) 5)
@@ -292,12 +324,12 @@
(buffer-sequence buffer 0 5))))
"cmacs")
-(deftest standard-buffer-delete-region.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-region.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-left-sticky-mark
+ (m2 (make-instance %%left-sticky-mark
:buffer buffer :offset 5)))
(delete-region m m2)
(and (= (size buffer) 5)
@@ -308,12 +340,12 @@
(buffer-sequence buffer 0 5))))
"clics")
-(deftest standard-buffer-delete-region.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-region.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 5)))
(delete-region m m2)
(and (= (size buffer) 5)
@@ -324,12 +356,12 @@
(buffer-sequence buffer 0 5))))
"clics")
-(deftest standard-buffer-delete-region.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-region.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-left-sticky-mark
+ (m2 (make-instance %%left-sticky-mark
:buffer buffer :offset 5)))
(delete-region m2 m)
(and (= (size buffer) 5)
@@ -340,12 +372,12 @@
(buffer-sequence buffer 0 5))))
"clics")
-(deftest standard-buffer-delete-region.test-4
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-region.test-4
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 5)))
(delete-region m2 m)
(and (= (size buffer) 5)
@@ -356,15 +388,15 @@
(buffer-sequence buffer 0 5))))
"clics")
-(deftest standard-buffer-delete-region.test-5
+(defmultitest delete-region.test-5
(handler-case
- (let ((buffer (make-instance 'standard-buffer))
- (buffer2 (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer))
+ (buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m (make-instance 'standard-right-sticky-mark
+ (let ((m (make-instance %%right-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer2 :offset 5)))
(delete-region m2 m)))
(error (c)
@@ -372,12 +404,12 @@
'caught))
caught)
-(deftest standard-buffer-delete-region.test-6
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest delete-region.test-6
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-left-sticky-mark
+ (m2 (make-instance %%left-sticky-mark
:buffer buffer :offset 5)))
(delete-region m 5)
(delete-region 1 m2)
@@ -389,33 +421,33 @@
(buffer-sequence buffer 0 3))))
"ccs")
-(deftest standard-buffer-number-of-lines.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest number-of-lines.test-1
+ (let ((buffer (make-instance %%buffer)))
(number-of-lines buffer))
0)
-(deftest standard-buffer-number-of-lines.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest number-of-lines.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs
")
(number-of-lines buffer))
2)
-(deftest standard-buffer-mark-relations.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest mark-relations.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m0 (make-instance 'standard-right-sticky-mark
+ (let ((m0 (make-instance %%right-sticky-mark
:buffer buffer :offset 0))
- (m1 (make-instance 'standard-left-sticky-mark
+ (m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m1a (make-instance 'standard-right-sticky-mark
+ (m1a (make-instance %%right-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 4))
- (m2a (make-instance 'standard-left-sticky-mark
+ (m2a (make-instance %%left-sticky-mark
:buffer buffer :offset 5))
- (m3 (make-instance 'standard-left-sticky-mark
+ (m3 (make-instance %%left-sticky-mark
:buffer buffer :offset 7)))
(setf (offset m2) 5)
(and (mark< m0 m1) (not (mark> m0 m1)) (not (mark>= m0 m1))
@@ -443,43 +475,43 @@
(list m0 m1 m1a m2 m2a m3)))))
t)
-(deftest standard-buffer-setf-offset.test-1
+(defmultitest setf-offset.test-1
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 4)))
(setf (offset m) -1)))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
-(deftest standard-buffer-setf-offset.test-2
+(defmultitest setf-offset.test-2
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 4)))
(setf (offset m) 8)))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 8)))
t)
-(deftest standard-buffer-backward-object.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest backward-object.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let* ((m1 (make-instance 'standard-left-sticky-mark
+ (let* ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 4))
(m2 (clone-mark m1)))
(backward-object m1 2)
(region-to-sequence m1 m2)))
"im")
-(deftest standard-buffer-backward-object.test-2
+(defmultitest backward-object.test-2
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let* ((m1 (make-instance 'standard-right-sticky-mark
+ (let* ((m1 (make-instance %%right-sticky-mark
:buffer buffer :offset 2))
(m2 (clone-mark m1)))
(backward-object m1 3)
@@ -488,21 +520,21 @@
(= (climacs-buffer::condition-offset c) -1)))
t)
-(deftest standard-buffer-forward-object.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest forward-object.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let* ((m1 (make-instance 'standard-left-sticky-mark
+ (let* ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 4))
(m2 (clone-mark m1)))
(forward-object m1 2)
(region-to-sequence m1 m2)))
"ac")
-(deftest standard-buffer-forward-object.test-2
+(defmultitest forward-object.test-2
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let* ((m1 (make-instance 'standard-right-sticky-mark
+ (let* ((m1 (make-instance %%right-sticky-mark
:buffer buffer :offset 6))
(m2 (clone-mark m1)))
(forward-object m1 3)
@@ -511,38 +543,38 @@
(= (climacs-buffer::condition-offset c) 9)))
t)
-(deftest standard-buffer-setf-buffer-object.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest setf-buffer-object.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(setf (buffer-object buffer 0) #\C)
(buffer-sequence buffer 0 (size buffer)))
"Climacs")
-(deftest standard-buffer-setf-buffer-object.test-2
+(defmultitest setf-buffer-object.test-2
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(setf (buffer-object buffer 0) #\a))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 0)))
t)
-(deftest standard-buffer-setf-buffer-object.test-3
+(defmultitest setf-buffer-object.test-3
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(setf (buffer-object buffer -1) #\a))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
-(deftest standard-buffer-mark<.test-1
+(defmultitest mark<.test-1
(handler-case
- (let ((buffer (make-instance 'standard-buffer))
- (buffer2 (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer))
+ (buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 4))
- (m2 (make-instance 'standard-left-sticky-mark
+ (m2 (make-instance %%left-sticky-mark
:buffer buffer2 :offset 4)))
(mark< m1 m2)))
(error (c)
@@ -550,15 +582,15 @@
'caught))
caught)
-(deftest standard-buffer-mark>.test-1
+(defmultitest mark>.test-1
(handler-case
- (let ((buffer (make-instance 'standard-buffer))
- (buffer2 (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer))
+ (buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 4))
- (m2 (make-instance 'standard-left-sticky-mark
+ (m2 (make-instance %%left-sticky-mark
:buffer buffer2 :offset 4)))
(mark> m1 m2)))
(error (c)
@@ -566,15 +598,15 @@
'caught))
caught)
-(deftest standard-buffer-mark<=.test-1
+(defmultitest mark<=.test-1
(handler-case
- (let ((buffer (make-instance 'standard-buffer))
- (buffer2 (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer))
+ (buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 4))
- (m2 (make-instance 'standard-left-sticky-mark
+ (m2 (make-instance %%left-sticky-mark
:buffer buffer2 :offset 4)))
(mark<= m1 m2)))
(error (c)
@@ -582,15 +614,15 @@
'caught))
caught)
-(deftest standard-buffer-mark>=.test-1
+(defmultitest mark>=.test-1
(handler-case
- (let ((buffer (make-instance 'standard-buffer))
- (buffer2 (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer))
+ (buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 4))
- (m2 (make-instance 'standard-left-sticky-mark
+ (m2 (make-instance %%left-sticky-mark
:buffer buffer2 :offset 4)))
(mark>= m1 m2)))
(error (c)
@@ -598,15 +630,15 @@
'caught))
caught)
-(deftest standard-buffer-mark=.test-1
+(defmultitest mark=.test-1
(handler-case
- (let ((buffer (make-instance 'standard-buffer))
- (buffer2 (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer))
+ (buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 4))
- (m2 (make-instance 'standard-left-sticky-mark
+ (m2 (make-instance %%left-sticky-mark
:buffer buffer2 :offset 4)))
(mark= m1 m2)))
(error (c)
@@ -614,27 +646,27 @@
'caught))
caught)
-(deftest standard-buffer-line-number.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest line-number.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 11)))
(= 0 (line-number m1) (1- (line-number m2)))))
t)
-(deftest standard-buffer-buffer-column-number.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest buffer-column-number.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs")
(values
(buffer-object buffer 2)
(buffer-column-number buffer 2)))
#\c 2)
-(deftest standard-buffer-buffer-column-number.test-2
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest buffer-column-number.test-2
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "
climacs")
(values
@@ -642,300 +674,304 @@
(buffer-column-number buffer 3)))
#\c 2)
-(deftest standard-buffer-column-number.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest column-number.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m1 (make-instance 'standard-left-sticky-mark
+ (let ((m1 (make-instance %%left-sticky-mark
:buffer buffer :offset 3))
- (m2 (make-instance 'standard-right-sticky-mark
+ (m2 (make-instance %%right-sticky-mark
:buffer buffer :offset 11)))
(= 3 (column-number m1) (column-number m2))))
t)
-(deftest standard-buffer-beginning-of-line.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest beginning-of-line.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 11)))
(and (not (beginning-of-line-p m))
(progn (beginning-of-line m) (beginning-of-line-p m)))))
t)
-(deftest standard-buffer-end-of-line.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest end-of-line.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 11)))
(and (not (end-of-line-p m))
(progn (end-of-line m) (end-of-line-p m)))))
t)
-(deftest standard-buffer-beginning-of-buffer.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest beginning-of-buffer.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 11)))
(and (not (beginning-of-buffer-p m))
(progn (beginning-of-buffer m) (beginning-of-buffer-p m)))))
t)
-(deftest standard-buffer-end-of-buffer.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest end-of-buffer.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m (make-instance 'standard-left-sticky-mark
+ (let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 11)))
(and (not (end-of-buffer-p m))
(progn (end-of-buffer m) (end-of-buffer-p m)))))
t)
-(deftest standard-buffer-buffer-object.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest buffer-object.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(buffer-object buffer 3))
#\m)
-(deftest standard-buffer-buffer-object.test-2
+(defmultitest buffer-object.test-2
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(buffer-object buffer -1))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
-(deftest standard-buffer-buffer-object.test-3
+(defmultitest buffer-object.test-3
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(buffer-object buffer 7))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 7)))
t)
-(deftest standard-buffer-buffer-sequence.test-1
+(defmultitest buffer-sequence.test-1
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(buffer-sequence buffer -1 0))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
-(deftest standard-buffer-buffer-sequence.test-2
+(defmultitest buffer-sequence.test-2
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(buffer-sequence buffer 0 1))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 1)))
t)
-(deftest standard-buffer-buffer-sequence.test-3
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest buffer-sequence.test-3
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(buffer-sequence buffer 5 3))
#())
-(deftest standard-buffer-object-before.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest object-before.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(object-before (high-mark buffer)))
#\s)
-(deftest standard-buffer-object-before.test-2
+(defmultitest object-before.test-2
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(object-before (low-mark buffer)))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
-(deftest standard-buffer-object-after.test-1
- (let ((buffer (make-instance 'standard-buffer)))
+(defmultitest object-after.test-1
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(object-after (low-mark buffer)))
#\c)
-(deftest standard-buffer-object-after.test-2
+(defmultitest object-after.test-2
(handler-case
- (let ((buffer (make-instance 'standard-buffer)))
+ (let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(object-after (high-mark buffer)))
(climacs-buffer::no-such-offset (c)
(= (climacs-buffer::condition-offset c) 7)))
t)
-(deftest standard-buffer-region-to-sequence.test-1
+(defmultitest region-to-sequence.test-1
(let ((seq "climacs")
- (buffer (make-instance 'standard-buffer)))
+ (buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 seq)
(let ((seq2 (region-to-sequence (low-mark buffer) (high-mark buffer))))
(and (not (eq seq seq2)) seq2)))
"climacs")
-(deftest standard-buffer-region-to-sequence.test-1a
+(defmultitest region-to-sequence.test-1a
(let ((seq "climacs")
- (buffer (make-instance 'standard-buffer)))
+ (buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 seq)
(let ((seq2 (region-to-sequence 0 (high-mark buffer))))
(and (not (eq seq seq2)) seq2)))
"climacs")
-(deftest standard-buffer-region-to-sequence.test-1aa
+(defmultitest region-to-sequence.test-1aa
(let ((seq "climacs")
- (buffer (make-instance 'standard-buffer)))
+ (buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 seq)
(let ((seq2 (region-to-sequence (high-mark buffer) 0)))
(and (not (eq seq seq2)) seq2)))
"climacs")
-(deftest standard-buffer-region-to-sequence.test-1b
+(defmultitest region-to-sequence.test-1b
(let ((seq "climacs")
- (buffer (make-instance 'standard-buffer)))
+ (buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 seq)
(let ((seq2 (region-to-sequence (low-mark buffer) 7)))
(and (not (eq seq seq2)) seq2)))
"climacs")
-(deftest standard-buffer-region-to-sequence.test-1ba
+(defmultitest region-to-sequence.test-1ba
(let ((seq "climacs")
- (buffer (make-instance 'standard-buffer)))
+ (buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 seq)
(let ((seq2 (region-to-sequence 7 (low-mark buffer))))
(and (not (eq seq seq2)) seq2)))
"climacs")
-(deftest standard-buffer-region-to-sequence.test-2
+(defmultitest region-to-sequence.test-2
(let ((seq "climacs")
- (buffer (make-instance 'standard-buffer)))
+ (buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 seq)
(region-to-sequence (high-mark buffer) (low-mark buffer)))
"climacs")
-(deftest standard-buffer-region-to-sequence.test-3
+(defmultitest region-to-sequence.test-3
(handler-case
- (let ((buffer1 (make-instance 'standard-buffer))
- (buffer2 (make-instance 'standard-buffer)))
+ (let ((buffer1 (make-instance %%buffer))
+ (buffer2 (make-instance %%buffer)))
(region-to-sequence (low-mark buffer1) (high-mark buffer2)))
(error (c)
(declare (ignore c))
'caught))
caught)
-
;;;; performance tests
-(defmacro deftimetest (name form &rest results)
- `(deftest ,name
- (time
- (progn
- (format t "~&; Performance test ~a" ',name)
- ,form))
- , at 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)))
+(defmultitest performance.test-1
+ (time
+ (loop with b = (make-instance %%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))))
+(defmultitest performance.test-1a
+ (time
+ (let ((b (loop with b = (make-instance %%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)))
+(defmultitest performance.test-1b
+ (time
+ (loop with b = (make-instance %%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))))
+(defmultitest performance.test-1ba
+ (time
+ (let ((b (loop with b = (make-instance %%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)))
+(defmultitest performance.test-1c
+ (time
+ (loop with b = (make-instance %%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))))
+(defmultitest performance.test-1ca
+ (time
+ (let ((b (loop with b = (make-instance %%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))))
+(defmultitest performance.test-1cb
+ (time
+ (let ((b (loop with b = (make-instance %%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)))
+(defmultitest performance.test-2
+ (time
+ (loop with b = (make-instance %%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)))
+(defmultitest performance.test-2b
+ (time
+ (loop with b = (make-instance %%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)))
+(defmultitest performance.test-2c
+ (time
+ (loop with b = (make-instance %%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)))
+(defmultitest performance.test-3
+ (time
+ (loop with b = (make-instance %%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)))
+(defmultitest performance.test-3b
+ (time
+ (loop with b = (make-instance %%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)))
+(defmultitest performance.test-3c
+ (time
+ (loop with b = (make-instance %%buffer)
+ for i from 0 below 100000
+ do (insert-buffer-sequence b (floor (size b) 2) "abcdefghij")
+ finally (return (size b))))
1000000)
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.18 climacs/climacs.asd:1.19
--- climacs/climacs.asd:1.18 Mon Feb 7 16:26:41 2005
+++ climacs/climacs.asd Thu Feb 10 01:27:07 2005
@@ -70,9 +70,7 @@
;;---- optional ----
"testing/rt"
"buffer-test"
- "base-test"
- "Persistent/persistent-buffer-test"
- "Persistent/persistent-base-test")
+ "base-test")
#+asdf
(defmethod asdf:perform :around ((o asdf:compile-op)
From ejohnson at common-lisp.net Sun Feb 13 02:47:09 2005
From: ejohnson at common-lisp.net (Elliott Johnson)
Date: Sun, 13 Feb 2005 03:47:09 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050213024709.47C7488171@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv25955
Modified Files:
gui.lisp
Log Message:
Hi guys, added com-single-window [ C-x 1 ] which closes all but the current window. I'm not gone, I've just been busy.
Date: Sun Feb 13 03:47:08 2005
Author: ejohnson
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.106 climacs/gui.lisp:1.107
--- climacs/gui.lisp:1.106 Wed Feb 2 08:59:41 2005
+++ climacs/gui.lisp Sun Feb 13 03:47:06 2005
@@ -971,6 +971,29 @@
(sheet-adopt-child parent other)
(reorder-sheets parent (list first other)))))))
+
+(define-named-command com-single-window ()
+ (unless (null (cdr (windows *application-frame*)))
+ (let* ((saver (parent3 (current-window)))
+ (top-level (do
+ ((a 1 (1+ a))
+ (n saver (setf n (sheet-parent n))))
+ ((clim-internals::top-level-sheet-pane-p n) n)))
+ (level1 (car (sheet-children top-level))) ;; should be the only thing on level1
+ (level2 (if (typep (car (sheet-children level1)) 'vrack-pane) ;;don't select raised pane
+ (car (sheet-children level1))
+ (cadr (sheet-children level1))))
+ (level2-children (sheet-children level2))
+ (junker (if (typep (car level2-children) 'vrack-pane) ;;don't select minibuffer
+ (car level2-children)
+ (cadr level2-children))))
+ (sheet-disown-child (sheet-parent saver) saver)
+ (sheet-disown-child level2 junker)
+ (sheet-adopt-child level2 saver)
+ (reorder-sheets level2 (reverse (sheet-children level2))) ;;minibuffer goes on bottom
+ (setf (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)))
@@ -1367,6 +1390,7 @@
:keystroke gesture :errorp nil))
(c-x-set-key '(#\0) 'com-delete-window)
+(c-x-set-key '(#\1) 'com-single-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)
From ejohnson at common-lisp.net Sun Feb 13 02:52:10 2005
From: ejohnson at common-lisp.net (Elliott Johnson)
Date: Sun, 13 Feb 2005 03:52:10 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050213025210.9FCEC88171@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv25999
Modified Files:
gui.lisp
Log Message:
heh left some test code in there, sorry
Date: Sun Feb 13 03:52:09 2005
Author: ejohnson
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.107 climacs/gui.lisp:1.108
--- climacs/gui.lisp:1.107 Sun Feb 13 03:47:06 2005
+++ climacs/gui.lisp Sun Feb 13 03:52:08 2005
@@ -976,8 +976,7 @@
(unless (null (cdr (windows *application-frame*)))
(let* ((saver (parent3 (current-window)))
(top-level (do
- ((a 1 (1+ a))
- (n saver (setf n (sheet-parent n))))
+ ((n saver (setf n (sheet-parent n))))
((clim-internals::top-level-sheet-pane-p n) n)))
(level1 (car (sheet-children top-level))) ;; should be the only thing on level1
(level2 (if (typep (car (sheet-children level1)) 'vrack-pane) ;;don't select raised pane
From rstrandh at common-lisp.net Sat Feb 19 05:23:18 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sat, 19 Feb 2005 06:23:18 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050219052318.9CB49884FA@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv9176
Modified Files:
gui.lisp
Log Message:
Implemented flag *numeric-argument-p* to detect whether a numeric
argument was given att all.
Implemented eval-expression, M-:, which uses numeric-argument-p to
dentermine whether to show the result in the minibuffer or to insert
it into the buffer itself.
Date: Sat Feb 19 06:23:17 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.108 climacs/gui.lisp:1.109
--- climacs/gui.lisp:1.108 Sun Feb 13 03:52:08 2005
+++ climacs/gui.lisp Sat Feb 19 06:23:16 2005
@@ -240,6 +240,11 @@
(find-if (lambda (pane) (typep pane 'scroller-pane))
(sheet-children vbox)))))))
+(defvar *numeric-argument-p* (list nil))
+
+(defun substitute-numeric-argument-p (command numargp)
+ (substitute numargp *numeric-argument-p* command :test #'eq))
+
(defun climacs-top-level (frame &key
command-parser command-unparser
partial-command-parser prompt)
@@ -254,34 +259,36 @@
(redisplay-frame-panes frame :force-p t)
(loop (catch 'outer-loop
(loop for gestures = '()
- for numarg = (read-numeric-argument :stream *standard-input*)
- do (loop (setf *current-gesture* (climacs-read-gesture))
- (setf gestures (nconc gestures (list *current-gesture*)))
- (let ((item (find-gestures gestures 'global-climacs-table)))
- (cond ((not item)
- (beep) (return))
- ((eq (command-menu-item-type item) :command)
- (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 (previous-command *standard-output*)
- (if (consp command)
- (car command)
- command))
- (return)))
- (t nil))))
- (let ((buffer (buffer (current-window))))
- (when (modified-p buffer)
- (setf (needs-saving buffer) t)))
- (when (null (remaining-keys *application-frame*))
- (setf (executingp *application-frame*) nil)
- (redisplay-frame-panes frame))))
+ do (multiple-value-bind (numarg numargp)
+ (read-numeric-argument :stream *standard-input*)
+ (loop (setf *current-gesture* (climacs-read-gesture))
+ (setf gestures (nconc gestures (list *current-gesture*)))
+ (let ((item (find-gestures gestures 'global-climacs-table)))
+ (cond ((not item)
+ (beep) (return))
+ ((eq (command-menu-item-type item) :command)
+ (let ((command (command-menu-item-value item)))
+ (unless (consp command)
+ (setf command (list command)))
+ (setf command (substitute-numeric-argument-marker command numarg))
+ (setf command (substitute-numeric-argument-p command numargp))
+ (handler-case
+ (execute-frame-command frame command)
+ (error (condition)
+ (beep)
+ (format *error-output* "~a~%" condition)))
+ (setf (previous-command *standard-output*)
+ (if (consp command)
+ (car command)
+ command))
+ (return)))
+ (t nil))))
+ (let ((buffer (buffer (current-window))))
+ (when (modified-p buffer)
+ (setf (needs-saving buffer) t)))
+ (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)
@@ -1288,6 +1295,14 @@
(syntax (syntax (buffer pane))))
(display-message "~a" (forward-to-error point syntax))))
+(define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
+ (let* ((*package* (find-package :climacs-gui))
+ (string (accept 'string :prompt "Eval"))
+ (result (format nil "~a" (eval (read-from-string string)))))
+ (if insertp
+ (insert-sequence (point (current-window)) result)
+ (display-message result))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Global and dead-escape command tables
@@ -1317,6 +1332,7 @@
(global-set-key #\Newline 'com-self-insert)
(global-set-key #\Tab 'com-indent-line)
+(global-set-key '(#\: :shift :meta) `(com-eval-expression ,*numeric-argument-p*))
(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*))
From rstrandh at common-lisp.net Sat Feb 19 05:45:10 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sat, 19 Feb 2005 06:45:10 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050219054510.B4BAD884FA@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv10015
Modified Files:
gui.lisp
Log Message:
Used the new *numeric-argument-p* feature to implement Emacs-like
behavior for kill-line.
Date: Sat Feb 19 06:45:04 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.109 climacs/gui.lisp:1.110
--- climacs/gui.lisp:1.109 Sat Feb 19 06:23:16 2005
+++ climacs/gui.lisp Sat Feb 19 06:45:03 2005
@@ -465,22 +465,28 @@
(define-named-command com-open-line ()
(open-line (point (current-window))))
-(define-named-command com-kill-line ()
+(define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?")
+ (numargp 'boolean :prompt "Kill entire lines?"))
(let* ((pane (current-window))
(point (point pane))
(mark (offset point)))
- (cond ((end-of-buffer-p point) nil)
- ((end-of-line-p point)(forward-object point))
+ (cond ((or numargp (> numarg 1))
+ (loop repeat numarg
+ until (end-of-buffer-p point)
+ do (end-of-line point)
+ until (end-of-buffer-p point)
+ do (forward-object point)))
(t
- (end-of-line point)
- (cond ((beginning-of-buffer-p point) nil)
- ((beginning-of-line-p point)(forward-object point)))))
- (if (eq (previous-command pane) 'com-kill-line)
- (kill-ring-concatenating-push *kill-ring*
- (region-to-sequence mark point))
- (kill-ring-standard-push *kill-ring*
- (region-to-sequence mark point)))
- (delete-region mark point)))
+ (cond ((end-of-buffer-p point) nil)
+ ((end-of-line-p point)(forward-object point))
+ (t (end-of-line point)))))
+ (unless (mark= point mark)
+ (if (eq (previous-command pane) 'com-kill-line)
+ (kill-ring-concatenating-push *kill-ring*
+ (region-to-sequence mark point))
+ (kill-ring-standard-push *kill-ring*
+ (region-to-sequence mark point)))
+ (delete-region mark point))))
(define-named-command com-forward-word ((count 'integer :prompt "Number of words"))
(forward-word (point (current-window)) count))
@@ -1343,7 +1349,7 @@
(global-set-key '(#\l :control) 'com-full-redisplay)
(global-set-key '(#\n :control) 'com-next-line)
(global-set-key '(#\o :control) 'com-open-line)
-(global-set-key '(#\k :control) 'com-kill-line)
+(global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*))
(global-set-key '(#\t :control) 'com-transpose-objects)
(global-set-key '(#\Space :control) 'com-set-mark)
(global-set-key '(#\y :control) 'com-yank)
From rstrandh at common-lisp.net Sat Feb 19 06:09:47 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sat, 19 Feb 2005 07:09:47 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp
Message-ID: <20050219060947.53469884FA@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv11536
Modified Files:
base.lisp gui.lisp
Log Message:
next-line and previous-line now take an additional optional argument
indicating how many lines to move.
com-next-line and com-previous-line now take numeric arguments and pass
then on to next-line and previous-line.
Date: Sat Feb 19 07:09:45 2005
Author: rstrandh
Index: climacs/base.lisp
diff -u climacs/base.lisp:1.35 climacs/base.lisp:1.36
--- climacs/base.lisp:1.35 Sat Feb 12 16:34:46 2005
+++ climacs/base.lisp Sat Feb 19 07:09:45 2005
@@ -41,31 +41,31 @@
(loop for ,offset from ,offset1 below ,offset2
do , at body)))
-(defun previous-line (mark &optional column)
+(defun previous-line (mark &optional column (count 1))
"Move a mark up one line conserving horizontal position."
(unless column
(setf column (column-number mark)))
- (beginning-of-line mark)
- (if (beginning-of-buffer-p mark)
- (incf (offset mark) column)
- (progn (decf (offset mark))
- (when (> (column-number mark) column)
- (beginning-of-line mark)
- (incf (offset mark) column)))))
+ (loop repeat count
+ do (beginning-of-line mark)
+ until (beginning-of-buffer-p mark)
+ do (backward-object mark))
+ (end-of-line mark)
+ (when (> (column-number mark) column)
+ (beginning-of-line mark)
+ (incf (offset mark) column)))
-(defun next-line (mark &optional column)
+(defun next-line (mark &optional column (count 1))
"Move a mark down one line conserving horizontal position."
(unless column
(setf column (column-number mark)))
+ (loop repeat count
+ do (end-of-line mark)
+ until (end-of-buffer-p mark)
+ do (forward-object mark))
(end-of-line mark)
- (if (end-of-buffer-p mark)
- (progn (beginning-of-line mark)
- (incf (offset mark) column))
- (progn (incf (offset mark))
- (end-of-line mark)
- (when (> (column-number mark) column)
- (beginning-of-line mark)
- (incf (offset mark) column)))))
+ (when (> (column-number mark) column)
+ (beginning-of-line mark)
+ (incf (offset mark) column)))
(defmethod open-line ((mark left-sticky-mark))
"Create a new line in a buffer after the mark."
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.110 climacs/gui.lisp:1.111
--- climacs/gui.lisp:1.110 Sat Feb 19 06:45:03 2005
+++ climacs/gui.lisp Sat Feb 19 07:09:45 2005
@@ -446,21 +446,21 @@
(insert-sequence point line)
(insert-object point #\Newline))))
-(define-named-command com-previous-line ()
+(define-named-command com-previous-line ((numarg 'integer :prompt "How many lines?"))
(let* ((win (current-window))
(point (point win)))
(unless (or (eq (previous-command win) 'com-previous-line)
(eq (previous-command win) 'com-next-line))
(setf (slot-value win 'goal-column) (column-number point)))
- (previous-line point (slot-value win 'goal-column))))
+ (previous-line point (slot-value win 'goal-column) numarg)))
-(define-named-command com-next-line ()
+(define-named-command com-next-line ((numarg 'integer :prompt "How many lines?"))
(let* ((win (current-window))
(point (point win)))
(unless (or (eq (previous-command win) 'com-previous-line)
(eq (previous-command win) 'com-next-line))
(setf (slot-value win 'goal-column) (column-number point)))
- (next-line point (slot-value win 'goal-column))))
+ (next-line point (slot-value win 'goal-column) numarg)))
(define-named-command com-open-line ()
(open-line (point (current-window))))
@@ -1345,9 +1345,9 @@
(global-set-key '(#\a :control) 'com-beginning-of-line)
(global-set-key '(#\e :control) 'com-end-of-line)
(global-set-key '(#\d :control) `(com-delete-object ,*numeric-argument-marker*))
-(global-set-key '(#\p :control) 'com-previous-line)
+(global-set-key '(#\p :control) `(com-previous-line ,*numeric-argument-marker*))
(global-set-key '(#\l :control) 'com-full-redisplay)
-(global-set-key '(#\n :control) 'com-next-line)
+(global-set-key '(#\n :control) `(com-next-line ,*numeric-argument-marker*))
(global-set-key '(#\o :control) 'com-open-line)
(global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*))
(global-set-key '(#\t :control) 'com-transpose-objects)
@@ -1379,8 +1379,8 @@
(global-set-key '(#\r :control) 'com-isearch-mode-backward)
(global-set-key '(#\% :shift :meta) 'com-query-replace)
-(global-set-key '(:up) 'com-previous-line)
-(global-set-key '(:down) 'com-next-line)
+(global-set-key '(:up) `(com-previous-line ,*numeric-argument-marker*))
+(global-set-key '(:down) `(com-next-line ,*numeric-argument-marker*))
(global-set-key '(:left) `(com-backward-object ,*numeric-argument-marker*))
(global-set-key '(:right) `(com-forward-object ,*numeric-argument-marker*))
(global-set-key '(:left :control) `(com-backward-word ,*numeric-argument-marker*))
From rstrandh at common-lisp.net Sat Feb 19 06:19:07 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sat, 19 Feb 2005 07:19:07 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp
Message-ID: <20050219061907.D2ED3884FA@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv12302
Modified Files:
base.lisp gui.lisp
Log Message:
open-line now takes an optional count argument.
com-open-line now accepts a numeric argument that it passes on to
open-line.
Date: Sat Feb 19 07:19:06 2005
Author: rstrandh
Index: climacs/base.lisp
diff -u climacs/base.lisp:1.36 climacs/base.lisp:1.37
--- climacs/base.lisp:1.36 Sat Feb 19 07:09:45 2005
+++ climacs/base.lisp Sat Feb 19 07:19:06 2005
@@ -67,14 +67,16 @@
(beginning-of-line mark)
(incf (offset mark) column)))
-(defmethod open-line ((mark left-sticky-mark))
+(defmethod open-line ((mark left-sticky-mark) &optional (count 1))
"Create a new line in a buffer after the mark."
- (insert-object mark #\Newline))
+ (loop repeat count
+ do (insert-object mark #\Newline)))
-(defmethod open-line ((mark right-sticky-mark))
+(defmethod open-line ((mark right-sticky-mark) &optional (count 1))
"Create a new line in a buffer after the mark."
- (insert-object mark #\Newline)
- (decf (offset mark)))
+ (loop repeat count
+ do (insert-object mark #\Newline)
+ (decf (offset mark))))
(defun kill-line (mark)
"Remove a line from a buffer."
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.111 climacs/gui.lisp:1.112
--- climacs/gui.lisp:1.111 Sat Feb 19 07:09:45 2005
+++ climacs/gui.lisp Sat Feb 19 07:19:06 2005
@@ -462,8 +462,8 @@
(setf (slot-value win 'goal-column) (column-number point)))
(next-line point (slot-value win 'goal-column) numarg)))
-(define-named-command com-open-line ()
- (open-line (point (current-window))))
+(define-named-command com-open-line ((numarg 'integer :prompt "How many lines?"))
+ (open-line (point (current-window)) numarg))
(define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?")
(numargp 'boolean :prompt "Kill entire lines?"))
@@ -1348,7 +1348,7 @@
(global-set-key '(#\p :control) `(com-previous-line ,*numeric-argument-marker*))
(global-set-key '(#\l :control) 'com-full-redisplay)
(global-set-key '(#\n :control) `(com-next-line ,*numeric-argument-marker*))
-(global-set-key '(#\o :control) 'com-open-line)
+(global-set-key '(#\o :control) `(com-open-line ,*numeric-argument-marker*))
(global-set-key '(#\k :control) `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*))
(global-set-key '(#\t :control) 'com-transpose-objects)
(global-set-key '(#\Space :control) 'com-set-mark)
From rstrandh at common-lisp.net Sun Feb 20 05:11:53 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sun, 20 Feb 2005 06:11:53 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/TODO climacs/gui.lisp
Message-ID: <20050220051153.3DDEA884E1@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv21015
Modified Files:
TODO gui.lisp
Log Message:
Redisplay is now invoked when the frame is resized.
Date: Sun Feb 20 06:11:45 2005
Author: rstrandh
Index: climacs/TODO
diff -u climacs/TODO:1.3 climacs/TODO:1.4
--- climacs/TODO:1.3 Thu Feb 10 01:27:07 2005
+++ climacs/TODO Sun Feb 20 06:11:39 2005
@@ -8,5 +8,3 @@
- handle wrapped lines instead of making McCLIM handle them
- replace the use of the scroller pane by custom pane
-
-- invoke redisplay after resize
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.112 climacs/gui.lisp:1.113
--- climacs/gui.lisp:1.112 Sat Feb 19 07:19:06 2005
+++ climacs/gui.lisp Sun Feb 20 06:11:39 2005
@@ -147,6 +147,10 @@
(declare (ignore frame))
(redisplay-pane pane (eq pane (car (windows *application-frame*)))))
+(defmethod handle-repaint :before ((pane extended-pane) region)
+ (declare (ignore region))
+ (redisplay-frame-panes *application-frame*))
+
(defun find-gestures (gestures start-table)
(loop with table = (find-command-table start-table)
for (gesture . rest) on gestures
From rstrandh at common-lisp.net Sun Feb 20 05:39:17 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sun, 20 Feb 2005 06:39:17 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/TODO climacs/gui.lisp
Message-ID: <20050220053917.22B30884E1@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv22599
Modified Files:
TODO gui.lisp
Log Message:
Lines are no longer wrapped by CLIM. Scrolling does not work very well
either though. We do need that custom scroller pane.
Date: Sun Feb 20 06:39:16 2005
Author: rstrandh
Index: climacs/TODO
diff -u climacs/TODO:1.4 climacs/TODO:1.5
--- climacs/TODO:1.4 Sun Feb 20 06:11:39 2005
+++ climacs/TODO Sun Feb 20 06:39:15 2005
@@ -5,6 +5,4 @@
one sequence type for lines, the other for line contents), then
upgrade it to an undoable buffer
-- handle wrapped lines instead of making McCLIM handle them
-
- replace the use of the scroller pane by custom pane
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.113 climacs/gui.lisp:1.114
--- climacs/gui.lisp:1.113 Sun Feb 20 06:11:39 2005
+++ climacs/gui.lisp Sun Feb 20 06:39:16 2005
@@ -60,6 +60,7 @@
(make-pane 'extended-pane
:width 900 :height 400
:name 'bla
+ :end-of-line-action :scroll
:incremental-redisplay t
:display-function 'display-win))
(info-pane
@@ -916,6 +917,7 @@
(make-pane 'extended-pane
:width 900 :height 400
:name 'win
+ :end-of-line-action :scroll
:incremental-redisplay t
:display-function 'display-win))
(vbox
From rstrandh at common-lisp.net Mon Feb 21 07:47:29 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Mon, 21 Feb 2005 08:47:29 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050221074729.701968846F@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv13708
Modified Files:
gui.lisp
Log Message:
Simplified implementation of com-single-window and made it independent
of the clim-internals package.
Date: Mon Feb 21 08:47:27 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.114 climacs/gui.lisp:1.115
--- climacs/gui.lisp:1.114 Sun Feb 20 06:39:16 2005
+++ climacs/gui.lisp Mon Feb 21 08:47:26 2005
@@ -992,25 +992,10 @@
(define-named-command com-single-window ()
- (unless (null (cdr (windows *application-frame*)))
- (let* ((saver (parent3 (current-window)))
- (top-level (do
- ((n saver (setf n (sheet-parent n))))
- ((clim-internals::top-level-sheet-pane-p n) n)))
- (level1 (car (sheet-children top-level))) ;; should be the only thing on level1
- (level2 (if (typep (car (sheet-children level1)) 'vrack-pane) ;;don't select raised pane
- (car (sheet-children level1))
- (cadr (sheet-children level1))))
- (level2-children (sheet-children level2))
- (junker (if (typep (car level2-children) 'vrack-pane) ;;don't select minibuffer
- (car level2-children)
- (cadr level2-children))))
- (sheet-disown-child (sheet-parent saver) saver)
- (sheet-disown-child level2 junker)
- (sheet-adopt-child level2 saver)
- (reorder-sheets level2 (reverse (sheet-children level2))) ;;minibuffer goes on bottom
- (setf (windows *application-frame*) (list (car (windows *application-frame*)))))))
-
+ (loop until (null (cdr (windows *application-frame*)))
+ do (rotatef (car (windows *application-frame*))
+ (cadr (windows *application-frame*)))
+ (com-delete-window)))
;; (define-named-command com-delete-window ()
;; (unless (null (cdr (windows *application-frame*)))
From rstrandh at common-lisp.net Mon Feb 21 07:58:41 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Mon, 21 Feb 2005 08:58:41 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050221075841.CAA1E8846F@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv13781
Modified Files:
gui.lisp
Log Message:
Simplified implementation of com-delete-window
Date: Mon Feb 21 08:58:40 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.115 climacs/gui.lisp:1.116
--- climacs/gui.lisp:1.115 Mon Feb 21 08:47:26 2005
+++ climacs/gui.lisp Mon Feb 21 08:58:39 2005
@@ -981,15 +981,11 @@
(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)))))))
-
+ (sheet-disown-child parent box)
+ (sheet-adopt-child parent other)
+ (reorder-sheets parent (if (eq box first)
+ (list other second)
+ (list first other))))))
(define-named-command com-single-window ()
(loop until (null (cdr (windows *application-frame*)))
@@ -1012,13 +1008,11 @@
;; (third (third children)))
;; (pop (windows *application-frame*))
;; (sheet-disown-child box other)
+;; (sheet-disown-child parent box)
+;; (sheet-adopt-child parent other)
;; (cond ((eq box first)
-;; (sheet-disown-child parent box)
-;; (sheet-adopt-child parent other)
;; (reorder-sheets parent (list other second third)))
;; (t
-;; (sheet-disown-child parent box)
-;; (sheet-adopt-child parent other)
;; (reorder-sheets parent (list first second other)))))))
;;;;;;;;;;;;;;;;;;;;
From rstrandh at common-lisp.net Mon Feb 21 08:51:04 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Mon, 21 Feb 2005 09:51:04 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050221085104.7D2968846F@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv16960
Modified Files:
gui.lisp
Log Message:
Fixed old problem with using adjuster gadget.
Date: Mon Feb 21 09:51:03 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.116 climacs/gui.lisp:1.117
--- climacs/gui.lisp:1.116 Mon Feb 21 08:58:39 2005
+++ climacs/gui.lisp Mon Feb 21 09:51:03 2005
@@ -856,54 +856,32 @@
;;;
;;; Commands for splitting windows
-;;; put this in for real when we find a solution for the problem
-;;; it causes for com-delete-window
-;; (defun replace-constellation (constellation additional-constellation vertical-p)
-;; (let* ((parent (sheet-parent constellation))
-;; (children (sheet-children parent))
-;; (first (first children))
-;; (second (second children))
-;; (adjust (make-pane 'clim-extensions:box-adjuster-gadget)))
-;; (assert (member constellation children))
-;; (cond ((eq constellation first)
-;; (sheet-disown-child parent constellation)
-;; (let ((new (if vertical-p
-;; (vertically ()
-;; constellation adjust additional-constellation)
-;; (horizontally ()
-;; constellation adjust 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 adjust additional-constellation)
-;; (horizontally ()
-;; constellation adjust additional-constellation))))
-;; (sheet-adopt-child parent new)
-;; (reorder-sheets parent (list first new)))))))
-
+;; put this in for real when we find a solution for the problem
+;; it causes for com-delete-window
(defun replace-constellation (constellation additional-constellation vertical-p)
(let* ((parent (sheet-parent constellation))
(children (sheet-children parent))
(first (first children))
- (second (second children)))
+ (second (second children))
+ (third (third children))
+ (adjust (make-pane 'clim-extensions:box-adjuster-gadget)))
+ (format *query-io* "~S" 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)))))))
+ (sheet-disown-child parent constellation)
+ (let ((new (if vertical-p
+ (vertically ()
+ constellation adjust additional-constellation)
+ (horizontally ()
+ constellation adjust additional-constellation))))
+ (sheet-adopt-child parent new)
+ (reorder-sheets parent
+ (if (eq constellation first)
+ (if third
+ (list new second third)
+ (list new second))
+ (if third
+ (list first second new)
+ (list first new)))))))
(defun parent3 (sheet)
(sheet-parent (sheet-parent (sheet-parent sheet))))
@@ -967,53 +945,36 @@
(append (cdr (windows *application-frame*))
(list (car (windows *application-frame*))))))
+(define-named-command com-single-window ()
+ (loop until (null (cdr (windows *application-frame*)))
+ do (rotatef (car (windows *application-frame*))
+ (cadr (windows *application-frame*)))
+ (com-delete-window)))
+
(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)
+ (third box-children)
(first box-children)))
(parent (sheet-parent box))
(children (sheet-children parent))
(first (first children))
- (second (second children)))
+ (second (second children))
+ (third (third children)))
(pop (windows *application-frame*))
(sheet-disown-child box other)
(sheet-disown-child parent box)
- (sheet-adopt-child parent other)
+ (sheet-adopt-child parent other)
(reorder-sheets parent (if (eq box first)
- (list other second)
- (list first other))))))
-
-(define-named-command com-single-window ()
- (loop until (null (cdr (windows *application-frame*)))
- do (rotatef (car (windows *application-frame*))
- (cadr (windows *application-frame*)))
- (com-delete-window)))
-
-;; (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))
-;; (third box-children)
-;; (first box-children)))
-;; (parent (sheet-parent box))
-;; (children (sheet-children parent))
-;; (first (first children))
-;; (second (second children))
-;; (third (third children)))
-;; (pop (windows *application-frame*))
-;; (sheet-disown-child box other)
-;; (sheet-disown-child parent box)
-;; (sheet-adopt-child parent other)
-;; (cond ((eq box first)
-;; (reorder-sheets parent (list other second third)))
-;; (t
-;; (reorder-sheets parent (list first second other)))))))
+ (if third
+ (list other second third)
+ (list other second))
+ (if third
+ (list first second other)
+ (list first other)))))))
;;;;;;;;;;;;;;;;;;;;
;; Kill ring commands
From rstrandh at common-lisp.net Mon Feb 21 12:52:02 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Mon, 21 Feb 2005 13:52:02 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050221125202.B3B6D884E2@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv30093
Modified Files:
gui.lisp
Log Message:
Removed debug message and an obsolete comment.
Date: Mon Feb 21 13:51:57 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.117 climacs/gui.lisp:1.118
--- climacs/gui.lisp:1.117 Mon Feb 21 09:51:03 2005
+++ climacs/gui.lisp Mon Feb 21 13:51:55 2005
@@ -856,8 +856,6 @@
;;;
;;; Commands for splitting windows
-;; put this in for real when we find a solution for the problem
-;; it causes for com-delete-window
(defun replace-constellation (constellation additional-constellation vertical-p)
(let* ((parent (sheet-parent constellation))
(children (sheet-children parent))
@@ -865,7 +863,6 @@
(second (second children))
(third (third children))
(adjust (make-pane 'clim-extensions:box-adjuster-gadget)))
- (format *query-io* "~S" children)
(assert (member constellation children))
(sheet-disown-child parent constellation)
(let ((new (if vertical-p
From rstrandh at common-lisp.net Tue Feb 22 07:29:09 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Tue, 22 Feb 2005 08:29:09 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050222072909.C470988677@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv27192
Modified Files:
gui.lisp
Log Message:
C-g now aborts extended commands.
Date: Tue Feb 22 08:29:09 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.118 climacs/gui.lisp:1.119
--- climacs/gui.lisp:1.118 Mon Feb 21 13:51:55 2005
+++ climacs/gui.lisp Tue Feb 22 08:29:08 2005
@@ -176,8 +176,6 @@
(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 '(:keyboard #\g 512)) ; FIXME
- do (throw 'outer-loop nil)
until (or (characterp gesture)
(and (typep gesture 'keyboard-event)
(or (keyboard-event-character gesture)
@@ -260,40 +258,41 @@
(let ((*standard-output* (car windows))
(*standard-input* (find-pane-named frame 'int))
(*print-pretty* nil)
- (*abort-gestures* nil))
+ (*abort-gestures* '((:keyboard #\g 512))))
(redisplay-frame-panes frame :force-p t)
- (loop (catch 'outer-loop
- (loop for gestures = '()
- do (multiple-value-bind (numarg numargp)
- (read-numeric-argument :stream *standard-input*)
- (loop (setf *current-gesture* (climacs-read-gesture))
- (setf gestures (nconc gestures (list *current-gesture*)))
- (let ((item (find-gestures gestures 'global-climacs-table)))
- (cond ((not item)
- (beep) (return))
- ((eq (command-menu-item-type item) :command)
- (let ((command (command-menu-item-value item)))
- (unless (consp command)
- (setf command (list command)))
- (setf command (substitute-numeric-argument-marker command numarg))
- (setf command (substitute-numeric-argument-p command numargp))
- (handler-case
- (execute-frame-command frame command)
- (error (condition)
- (beep)
- (format *error-output* "~a~%" condition)))
- (setf (previous-command *standard-output*)
- (if (consp command)
- (car command)
- command))
- (return)))
- (t nil))))
- (let ((buffer (buffer (current-window))))
- (when (modified-p buffer)
- (setf (needs-saving buffer) t)))
- (when (null (remaining-keys *application-frame*))
- (setf (executingp *application-frame*) nil)
- (redisplay-frame-panes frame)))))
+ (loop (handler-case
+ (loop for gestures = '()
+ do (multiple-value-bind (numarg numargp)
+ (read-numeric-argument :stream *standard-input*)
+ (loop (setf *current-gesture* (climacs-read-gesture))
+ (setf gestures (nconc gestures (list *current-gesture*)))
+ (let ((item (find-gestures gestures 'global-climacs-table)))
+ (cond ((not item)
+ (beep) (return))
+ ((eq (command-menu-item-type item) :command)
+ (let ((command (command-menu-item-value item)))
+ (unless (consp command)
+ (setf command (list command)))
+ (setf command (substitute-numeric-argument-marker command numarg))
+ (setf command (substitute-numeric-argument-p command numargp))
+ (handler-case
+ (execute-frame-command frame command)
+ (error (condition)
+ (beep)
+ (format *error-output* "~a~%" condition)))
+ (setf (previous-command *standard-output*)
+ (if (consp command)
+ (car command)
+ command))
+ (return)))
+ (t nil))))
+ (let ((buffer (buffer (current-window))))
+ (when (modified-p buffer)
+ (setf (needs-saving buffer) t)))
+ (when (null (remaining-keys *application-frame*))
+ (setf (executingp *application-frame*) nil)
+ (redisplay-frame-panes frame))))
+ (abort-gesture () nil))
(beep)
(let ((buffer (buffer (current-window))))
(when (modified-p buffer)
From rstrandh at common-lisp.net Tue Feb 22 08:29:04 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Tue, 22 Feb 2005 09:29:04 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050222082904.BF76F88666@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv30769
Modified Files:
gui.lisp
Log Message:
Give the user a message after C-g.
Date: Tue Feb 22 09:29:03 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.119 climacs/gui.lisp:1.120
--- climacs/gui.lisp:1.119 Tue Feb 22 08:29:08 2005
+++ climacs/gui.lisp Tue Feb 22 09:29:03 2005
@@ -292,7 +292,7 @@
(when (null (remaining-keys *application-frame*))
(setf (executingp *application-frame*) nil)
(redisplay-frame-panes frame))))
- (abort-gesture () nil))
+ (abort-gesture () (display-message "Quit")))
(beep)
(let ((buffer (buffer (current-window))))
(when (modified-p buffer)
From crhodes at common-lisp.net Tue Feb 22 11:00:44 2005
From: crhodes at common-lisp.net (Christophe Rhodes)
Date: Tue, 22 Feb 2005 12:00:44 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/README
Message-ID: <20050222110044.0568C88666@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv6633
Modified Files:
README
Log Message:
Minor textual changes. More major ones are probably necessary.
Date: Tue Feb 22 12:00:34 2005
Author: crhodes
Index: climacs/README
diff -u climacs/README:1.1 climacs/README:1.2
--- climacs/README:1.1 Wed Dec 22 15:43:18 2004
+++ climacs/README Tue Feb 22 12:00:33 2005
@@ -28,7 +28,10 @@
How to contribute
-----------------
-[fill this in when we have a cl.net project]
+Discussion happens on the mailing lists accessible from
+; arcives are likewise
+accessible. Contributions to make the framework and the editor a
+nicer environment are actively sought.
What to work on
---------------
@@ -64,4 +67,4 @@
Installation
------------
-To install Climacs, se the INSTALL file.
+To install Climacs, see the INSTALL file.
From crhodes at common-lisp.net Tue Feb 22 11:01:44 2005
From: crhodes at common-lisp.net (Christophe Rhodes)
Date: Tue, 22 Feb 2005 12:01:44 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050222110144.62FDF884E1@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv6793
Modified Files:
gui.lisp
Log Message:
Implement, basically from Tim Moore, a command input context for the climacs
top level. (This allows presentation-to-command translators to be clickable)
Date: Tue Feb 22 12:01:42 2005
Author: crhodes
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.120 climacs/gui.lisp:1.121
--- climacs/gui.lisp:1.120 Tue Feb 22 09:29:03 2005
+++ climacs/gui.lisp Tue Feb 22 12:01:38 2005
@@ -249,57 +249,65 @@
(substitute numargp *numeric-argument-p* command :test #'eq))
(defun climacs-top-level (frame &key
- command-parser command-unparser
- partial-command-parser prompt)
+ command-parser command-unparser
+ partial-command-parser prompt)
(declare (ignore command-parser command-unparser partial-command-parser prompt))
(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* '((:keyboard #\g 512))))
- (redisplay-frame-panes frame :force-p t)
- (loop (handler-case
- (loop for gestures = '()
- do (multiple-value-bind (numarg numargp)
- (read-numeric-argument :stream *standard-input*)
- (loop (setf *current-gesture* (climacs-read-gesture))
- (setf gestures (nconc gestures (list *current-gesture*)))
- (let ((item (find-gestures gestures 'global-climacs-table)))
- (cond ((not item)
- (beep) (return))
- ((eq (command-menu-item-type item) :command)
- (let ((command (command-menu-item-value item)))
- (unless (consp command)
- (setf command (list command)))
- (setf command (substitute-numeric-argument-marker command numarg))
- (setf command (substitute-numeric-argument-p command numargp))
- (handler-case
- (execute-frame-command frame command)
- (error (condition)
- (beep)
- (format *error-output* "~a~%" condition)))
- (setf (previous-command *standard-output*)
- (if (consp command)
- (car command)
- command))
- (return)))
- (t nil))))
- (let ((buffer (buffer (current-window))))
- (when (modified-p buffer)
- (setf (needs-saving buffer) t)))
- (when (null (remaining-keys *application-frame*))
- (setf (executingp *application-frame*) nil)
- (redisplay-frame-panes frame))))
- (abort-gesture () (display-message "Quit")))
- (beep)
- (let ((buffer (buffer (current-window))))
- (when (modified-p buffer)
- (setf (needs-saving buffer) t)))
- (when (null (remaining-keys *application-frame*))
- (setf (executingp *application-frame*) nil)
- (redisplay-frame-panes 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* '((:keyboard #\g 512))))
+ (redisplay-frame-panes frame :force-p t)
+ (flet ((do-command (command)
+ (handler-case
+ (execute-frame-command frame command)
+ (error (condition)
+ (beep)
+ (format *error-output* "~a~%" condition)))
+ (setf (previous-command *standard-output*)
+ (if (consp command)
+ (car command)
+ command)))
+ (update-climacs ()
+ (let ((buffer (buffer (current-window))))
+ (when (modified-p buffer)
+ (setf (needs-saving buffer) t)))
+ (when (null (remaining-keys *application-frame*))
+ (setf (executingp *application-frame*) nil)
+ (redisplay-frame-panes frame))))
+ (loop
+ for maybe-error = t
+ do (handler-case
+ (with-input-context ('(command
+ :command-table 'global-climacs-table))
+ (object)
+ (loop
+ for gestures = '()
+ for numarg = (read-numeric-argument :stream *standard-input*)
+ do (loop (setf *current-gesture* (climacs-read-gesture))
+ (setf gestures (nconc gestures (list *current-gesture*)))
+ (let ((item (find-gestures gestures 'global-climacs-table)))
+ (cond ((not item)
+ (beep) (return))
+ ((eq (command-menu-item-type item) :command)
+ (let ((command (command-menu-item-value item)))
+ (unless (consp command)
+ (setf command (list command)))
+ (setf command (substitute-numeric-argument-marker command numarg))
+ (do-command command)
+ (return)))
+ (t nil))))
+ (update-climacs))
+ (t
+ (do-command object)
+ (setq maybe-error nil)))
+ (abort-gesture ()
+ (display-message "Quit")))
+ (when maybe-error
+ (beep))
+ (update-climacs))))))
(defmacro simple-command-loop (command-table loop-condition end-clauses)
(let ((gesture (gensym))
From rstrandh at common-lisp.net Wed Feb 23 06:13:11 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Wed, 23 Feb 2005 07:13:11 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050223061311.B713F884E1@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv5057
Modified Files:
gui.lisp
Log Message:
Fixed a problem introduced by a recent change to the command loop, where
the numeric argument flag was not replaced in commands.
Date: Wed Feb 23 07:13:09 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.121 climacs/gui.lisp:1.122
--- climacs/gui.lisp:1.121 Tue Feb 22 12:01:38 2005
+++ climacs/gui.lisp Wed Feb 23 07:13:09 2005
@@ -285,20 +285,22 @@
(object)
(loop
for gestures = '()
- for numarg = (read-numeric-argument :stream *standard-input*)
- do (loop (setf *current-gesture* (climacs-read-gesture))
- (setf gestures (nconc gestures (list *current-gesture*)))
- (let ((item (find-gestures gestures 'global-climacs-table)))
- (cond ((not item)
- (beep) (return))
- ((eq (command-menu-item-type item) :command)
- (let ((command (command-menu-item-value item)))
- (unless (consp command)
- (setf command (list command)))
- (setf command (substitute-numeric-argument-marker command numarg))
- (do-command command)
- (return)))
- (t nil))))
+ do (multiple-value-bind (numarg numargp)
+ (read-numeric-argument :stream *standard-input*)
+ (loop (setf *current-gesture* (climacs-read-gesture))
+ (setf gestures (nconc gestures (list *current-gesture*)))
+ (let ((item (find-gestures gestures 'global-climacs-table)))
+ (cond ((not item)
+ (beep) (return))
+ ((eq (command-menu-item-type item) :command)
+ (let ((command (command-menu-item-value item)))
+ (unless (consp command)
+ (setf command (list command)))
+ (setf command (substitute-numeric-argument-marker command numarg))
+ (setf command (substitute-numeric-argument-p command numargp))
+ (do-command command)
+ (return)))
+ (t nil)))))
(update-climacs))
(t
(do-command object)
From rstrandh at common-lisp.net Wed Feb 23 18:15:37 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Wed, 23 Feb 2005 19:15:37 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/buffer.lisp climacs/gui.lisp
climacs/packages.lisp
Message-ID: <20050223181537.39B01884E2@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv13301
Modified Files:
buffer.lisp gui.lisp packages.lisp
Log Message:
Implemented new conditions according to proposal on the devel list.
Date: Wed Feb 23 19:15:32 2005
Author: rstrandh
Index: climacs/buffer.lisp
diff -u climacs/buffer.lisp:1.27 climacs/buffer.lisp:1.28
--- climacs/buffer.lisp:1.27 Sat Feb 5 21:59:50 2005
+++ climacs/buffer.lisp Wed Feb 23 19:15:32 2005
@@ -81,9 +81,55 @@
(defmethod offset ((mark mark-mixin))
(cursor-pos (cursor mark)))
+(define-condition no-such-offset (simple-error)
+ ((offset :reader condition-offset :initarg :offset))
+ (:report (lambda (condition stream)
+ (format stream "No such offset: ~a" (condition-offset condition))))
+ (:documentation "This condition is signaled whenever an attempt is
+made to access buffer contents that is before the beginning or after
+the end of the buffer."))
+
+(define-condition offset-before-beginning (no-such-offset)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "Offset before beginning: ~a" (condition-offset condition))))
+ (:documentation "This condition is signaled whenever an attempt is
+made to access buffer contents that is before the beginning of the buffer."))
+
+(define-condition offset-after-end (no-such-offset)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "Offset after end: ~a" (condition-offset condition))))
+ (:documentation "This condition is signaled whenever an attempt is
+made to access buffer contents that is after the end of the buffer."))
+
+(define-condition invalid-motion (simple-error)
+ ((offset :reader condition-offset :initarg :offset))
+ (:report (lambda (condition stream)
+ (format stream "Invalid motion to offset: ~a" (condition-offset condition))))
+ (:documentation "This condition is signaled whenever an attempt is
+made to move a mark before the beginning or after the end of the
+buffer."))
+
+(define-condition motion-before-beginning (invalid-motion)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "Motion before beginning: ~a" (condition-offset condition))))
+ (:documentation "This condition is signaled whenever an attempt is
+made to move a mark before the beginning of the buffer."))
+
+(define-condition motion-after-end (invalid-motion)
+ ()
+ (:report (lambda (condition stream)
+ (format stream "Motion after end: ~a" (condition-offset condition))))
+ (:documentation "This condition is signaled whenever an attempt is
+made to move a mark after the end of the buffer."))
+
(defmethod (setf offset) (new-offset (mark mark-mixin))
- (assert (<= 0 new-offset (size (buffer mark))) ()
- (make-condition 'no-such-offset :offset new-offset))
+ (assert (<= 0 new-offset) ()
+ (make-condition 'motion-before-beginning :offset new-offset))
+ (assert (<= new-offset (size (buffer mark))) ()
+ (make-condition 'motion-after-end :offset new-offset))
(setf (cursor-pos (cursor mark)) new-offset))
(defgeneric backward-object (mark &optional count))
@@ -105,8 +151,10 @@
(defmethod initialize-instance :after ((mark standard-left-sticky-mark) &rest args &key (offset 0))
"Associates a created mark with the buffer it was created for."
(declare (ignore args))
- (assert (<= 0 offset (size (buffer mark))) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'motion-before-beginning :offset offset))
+ (assert (<= offset (size (buffer mark))) ()
+ (make-condition 'motion-after-end :offset offset))
(setf (slot-value mark 'cursor)
(make-instance 'left-sticky-flexicursor
:chain (slot-value (buffer mark) 'contents)
@@ -115,8 +163,10 @@
(defmethod initialize-instance :after ((mark standard-right-sticky-mark) &rest args &key (offset 0))
"Associates a created mark with the buffer it was created for."
(declare (ignore args))
- (assert (<= 0 offset (size (buffer mark))) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'motion-before-beginning :offset offset))
+ (assert (<= offset (size (buffer mark))) ()
+ (make-condition 'motion-after-end :offset offset))
(setf (slot-value mark 'cursor)
(make-instance 'right-sticky-flexicursor
:chain (slot-value (buffer mark) 'contents)
@@ -138,13 +188,6 @@
(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))
- (:report (lambda (condition stream)
- (format stream "No such offset: ~a" (condition-offset condition))))
- (:documentation "This condition is signaled whenever an attempt is made at an operation
-that is before the beginning or after the end of the buffer."))
-
(defgeneric size (buffer)
(:documentation "Return the number of objects in the buffer."))
@@ -348,8 +391,10 @@
offset will be positioned after the inserted object."))
(defmethod insert-buffer-object ((buffer standard-buffer) offset object)
- (assert (<= 0 offset (size buffer)) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
(insert* (slot-value buffer 'contents) offset object))
(defgeneric insert-buffer-sequence (buffer offset sequence)
@@ -380,8 +425,10 @@
no-such-offset condition is signaled."))
(defmethod delete-buffer-range ((buffer standard-buffer) offset n)
- (assert (<= 0 offset (size buffer)) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
(loop repeat n
do (delete* (slot-value buffer 'contents) offset)))
@@ -427,8 +474,10 @@
the size of the buffer, a no-such-offset condition is signaled."))
(defmethod buffer-object ((buffer standard-buffer) offset)
- (assert (<= 0 offset (1- (size buffer))) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (1- (size buffer))) ()
+ (make-condition 'offset-after-end :offset offset))
(element* (slot-value buffer 'contents) offset))
(defgeneric (setf buffer-object) (object buffer offset)
@@ -437,8 +486,10 @@
the size of the buffer, a no-such-offset condition is signaled."))
(defmethod (setf buffer-object) (object (buffer standard-buffer) offset)
- (assert (<= 0 offset (1- (size buffer))) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (1- (size buffer))) ()
+ (make-condition 'offset-after-end :offset offset))
(setf (element* (slot-value buffer 'contents) offset) object))
(defgeneric buffer-sequence (buffer offset1 offset2)
@@ -449,10 +500,14 @@
offset1, an empty sequence will be returned."))
(defmethod buffer-sequence ((buffer standard-buffer) offset1 offset2)
- (assert (<= 0 offset1 (size buffer)) ()
- (make-condition 'no-such-offset :offset offset1))
- (assert (<= 0 offset2 (size buffer)) ()
- (make-condition 'no-such-offset :offset offset2))
+ (assert (<= 0 offset1) ()
+ (make-condition 'offset-before-beginning :offset offset1))
+ (assert (<= offset1 (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset1))
+ (assert (<= 0 offset2) ()
+ (make-condition 'offset-before-beginning :offset offset2))
+ (assert (<= offset2 (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset2))
(if (< offset1 offset2)
(loop with result = (make-array (- offset2 offset1))
for offset from offset1 below offset2
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.122 climacs/gui.lisp:1.123
--- climacs/gui.lisp:1.122 Wed Feb 23 07:13:09 2005
+++ climacs/gui.lisp Wed Feb 23 19:15:32 2005
@@ -263,9 +263,14 @@
(flet ((do-command (command)
(handler-case
(execute-frame-command frame command)
- (error (condition)
- (beep)
- (format *error-output* "~a~%" condition)))
+ (offset-before-beginning ()
+ (beep) (display-message "Beginning of buffer"))
+ (offset-after-end ()
+ (beep) (display-message "End of buffer"))
+ (motion-before-beginning ()
+ (beep) (display-message "Beginning of buffer"))
+ (motion-after-end ()
+ (beep) (display-message "End of buffer")))
(setf (previous-command *standard-output*)
(if (consp command)
(car command)
@@ -314,8 +319,7 @@
(defmacro simple-command-loop (command-table loop-condition end-clauses)
(let ((gesture (gensym))
(item (gensym))
- (command (gensym))
- (condition (gensym)))
+ (command (gensym)))
`(progn
(redisplay-frame-panes *application-frame*)
(loop while ,loop-condition
@@ -329,9 +333,14 @@
(handler-case
(execute-frame-command *application-frame*
,command)
- (error (,condition)
- (beep)
- (format *error-output* "~a~%" ,condition)))))
+ (offset-before-beginning ()
+ (beep) (display-message "Beginning of buffer"))
+ (offset-after-end ()
+ (beep) (display-message "End of buffer"))
+ (motion-before-beginning ()
+ (beep) (display-message "Beginning of buffer"))
+ (motion-after-end ()
+ (beep) (display-message "End of buffer")))))
(t
(unread-gesture ,gesture)
, at end-clauses))
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.49 climacs/packages.lisp:1.50
--- climacs/packages.lisp:1.49 Sat Feb 12 16:34:46 2005
+++ climacs/packages.lisp Wed Feb 23 19:15:32 2005
@@ -27,7 +27,10 @@
(:export #:buffer #:standard-buffer
#:mark #:left-sticky-mark #:right-sticky-mark
#:standard-left-sticky-mark #:standard-right-sticky-mark
- #:clone-mark #:no-such-offset #:size #:number-of-lines
+ #:clone-mark
+ #:no-such-offset #:offset-before-beginning #:offset-after-end
+ #:invalid-motion #:motion-before-beginning #:motion-after-end
+ #:size #:number-of-lines
#:offset #:mark< #:mark<= #:mark= #:mark> #:mark>=
#:forward-object #:backward-object
#:beginning-of-buffer #:end-of-buffer
From rstrandh at common-lisp.net Thu Feb 24 08:30:32 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Thu, 24 Feb 2005 09:30:32 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp
Message-ID: <20050224083032.C6EC6884E2@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv28328
Modified Files:
gui.lisp
Log Message:
Many commands now capture their own error situations and give
reasonable error messages in the minibuffer.
Date: Thu Feb 24 09:30:30 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.123 climacs/gui.lisp:1.124
--- climacs/gui.lisp:1.123 Wed Feb 23 19:15:32 2005
+++ climacs/gui.lisp Thu Feb 24 09:30:28 2005
@@ -603,7 +603,10 @@
(setf (offset point) (offset point-backup)))))
(define-command com-extended-command ()
- (let ((item (accept 'command :prompt "Extended Command")))
+ (let ((item (handler-case (accept 'command :prompt "Extended Command")
+ (error () (progn (beep)
+ (display-message "No such command")
+ (return-from com-extended-command nil))))))
(execute-frame-command *application-frame* item)))
(eval-when (:compile-toplevel :load-toplevel)
@@ -729,12 +732,18 @@
(define-named-command (com-quit) ()
(loop for buffer in (buffers *application-frame*)
when (and (needs-saving buffer)
- (accept 'boolean
- :prompt (format nil "Save buffer: ~a ?" (name buffer))))
+ (handler-case (accept 'boolean
+ :prompt (format nil "Save buffer: ~a ?" (name buffer)))
+ (error () (progn (beep)
+ (display-message "Invalid answer")
+ (return-from com-quit nil)))))
do (save-buffer buffer))
(when (or (notany #'needs-saving
(buffers *application-frame*))
- (accept 'boolean :prompt "Modified buffers exist. Quit anyway?"))
+ (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
+ (error () (progn (beep)
+ (display-message "Invalid answer")
+ (return-from com-quit nil)))))
(frame-exit *application-frame*)))
(define-named-command com-write-buffer ()
@@ -776,7 +785,10 @@
(with-slots (buffers) *application-frame*
(let ((buffer (buffer (current-window))))
(when (and (needs-saving buffer)
- (accept 'boolean :prompt "Save buffer first?"))
+ (handler-case (accept 'boolean :prompt "Save buffer first?")
+ (error () (progn (beep)
+ (display-message "Invalid answer")
+ (return-from com-kill-buffer nil)))))
(com-save-buffer))
(setf buffers (remove buffer buffers))
;; Always need one buffer.
@@ -816,14 +828,20 @@
(define-named-command com-goto-position ()
(setf (offset (point (current-window)))
- (accept 'integer :prompt "Goto Position")))
+ (handler-case (accept 'integer :prompt "Goto Position")
+ (error () (progn (beep)
+ (display-message "Not a valid position")
+ (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)))
do (end-of-line mark)
until (end-of-buffer-p mark)
- repeat (accept 'integer :prompt "Goto Line")
+ repeat (handler-case (accept 'integer :prompt "Goto Line")
+ (error () (progn (beep)
+ (display-message "Not a valid line number")
+ (return-from com-goto-line nil))))
do (incf (offset mark))
(end-of-line mark)
finally (beginning-of-line mark)
@@ -846,7 +864,10 @@
(let* ((pane (current-window))
(buffer (buffer pane)))
(setf (syntax buffer)
- (make-instance (accept 'syntax :prompt "Set Syntax")
+ (make-instance (or (accept 'syntax :prompt "Set Syntax")
+ (progn (beep)
+ (display-message "No such syntax")
+ (return-from com-set-syntax nil)))
:buffer buffer))
(setf (offset (low-mark buffer)) 0
(offset (high-mark buffer)) (size buffer))))
@@ -1021,7 +1042,10 @@
(insert-sequence point (kill-ring-yank *kill-ring*))))
(define-named-command com-resize-kill-ring ()
- (let ((size (accept 'integer :prompt "New kill ring size")))
+ (let ((size (handler-case (accept 'integer :prompt "New kill ring size")
+ (error () (progn (beep)
+ (display-message "Not a valid kill ring size")
+ (return-from com-resize-kill-ring nil))))))
(setf (kill-ring-max-size *kill-ring*) size)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1141,10 +1165,16 @@
(/= (offset mark) offset-before))))
(define-named-command com-query-replace ()
- (let* ((string1 (accept 'string :prompt "Query replace"))
- (string2 (accept 'string
- :prompt (format nil "Query replace ~A with"
- string1)))
+ (let* ((string1 (handler-case (accept 'string :prompt "Query replace")
+ (error () (progn (beep)
+ (display-message "Empty string")
+ (return-from com-query-replace nil)))))
+ (string2 (handler-case (accept 'string
+ :prompt (format nil "Query replace ~A with"
+ string1))
+ (error () (progn (beep)
+ (display-message "Empty string")
+ (return-from com-query-replace nil)))))
(pane (current-window))
(point (point pane)))
(when (query-replace-find-next-match point string1)
@@ -1264,8 +1294,15 @@
(define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
(let* ((*package* (find-package :climacs-gui))
- (string (accept 'string :prompt "Eval"))
- (result (format nil "~a" (eval (read-from-string string)))))
+ (string (handler-case (accept 'string :prompt "Eval")
+ (error () (progn (beep)
+ (display-message "Empty string")
+ (return-from com-eval-expression nil)))))
+ (result (format nil "~a"
+ (handler-case (eval (read-from-string string))
+ (error (condition) (progn (beep)
+ (display-message "~a" condition)
+ (return-from com-eval-expression nil)))))))
(if insertp
(insert-sequence (point (current-window)) result)
(display-message result))))
From rstrandh at common-lisp.net Fri Feb 25 07:11:26 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Fri, 25 Feb 2005 08:11:26 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/buffer-test.lisp
climacs/buffer.lisp climacs/cl-syntax.lisp
Message-ID: <20050225071126.491CB8866B@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv8126
Modified Files:
buffer-test.lisp buffer.lisp cl-syntax.lisp
Log Message:
Changed the contract of clone mark so that the optional argument is
either :left or :right forcing the return value to be a
left-sticky-mark and a right-sticky-mark respectively.
Altered the two calls (in test code) that actually used the optional
argument to pass the right thing.
Modified the implementation of clone-mark to use constant symbols for
the class to instantiate, and made two methods so that the type of the
argument will be known statically. Still needed an explicit test for
the optional argument, but that is still much faster than using a
variable class to make-instance.
Date: Fri Feb 25 08:11:25 2005
Author: rstrandh
Index: climacs/buffer-test.lisp
diff -u climacs/buffer-test.lisp:1.15 climacs/buffer-test.lisp:1.16
--- climacs/buffer-test.lisp:1.15 Thu Feb 10 01:27:07 2005
+++ climacs/buffer-test.lisp Fri Feb 25 08:11:24 2005
@@ -77,8 +77,8 @@
(high (slot-value buffer 'high-mark))
(low2 (clone-mark low))
(high2 (clone-mark high))
- (low3 (clone-mark high %%left-sticky-mark))
- (high3 (clone-mark low %%right-sticky-mark)))
+ (low3 (clone-mark high :left))
+ (high3 (clone-mark low :right)))
(and (reduce #'%all-eq
(list (class-of low) (class-of low2) (class-of low3)))
(reduce #'%all-eq
Index: climacs/buffer.lisp
diff -u climacs/buffer.lisp:1.28 climacs/buffer.lisp:1.29
--- climacs/buffer.lisp:1.28 Wed Feb 23 19:15:32 2005
+++ climacs/buffer.lisp Fri Feb 25 08:11:24 2005
@@ -179,14 +179,29 @@
(setf low-mark (make-instance 'standard-left-sticky-mark :buffer buffer))
(setf high-mark (make-instance 'standard-right-sticky-mark :buffer buffer))))
-(defgeneric clone-mark (mark &optional type)
- (:documentation "Clone a mark. By default (when type is NIL) the same type of mark is
-returned. Otherwise type is the name of a class (subclass of the mark
-class) to be used as a class of the clone."))
+(defgeneric clone-mark (mark &optional stick-to)
+ (:documentation "Clone a mark. By default (when stick-to is NIL)
+the same type of mark is returned. Otherwise stick-to is either :left
+or :right indicating whether a left-sticky or a right-sticky mark
+should be created."))
-(defmethod clone-mark ((mark mark) &optional type)
- (make-instance (or type (class-of mark))
- :buffer (buffer mark) :offset (offset mark)))
+(defmethod clone-mark ((mark standard-left-sticky-mark) &optional stick-to)
+ (cond ((or (null stick-to) (eq stick-to :left))
+ (make-instance 'standard-left-sticky-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ ((eq stick-to :right)
+ (make-instance 'standard-right-sticky-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ (t (error "invalid value for stick-to"))))
+
+(defmethod clone-mark ((mark standard-right-sticky-mark) &optional stick-to)
+ (cond ((or (null stick-to) (eq stick-to :right))
+ (make-instance 'standard-right-sticky-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ ((eq stick-to :left)
+ (make-instance 'standard-left-sticky-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ (t (error "invalid value for stick-to"))))
(defgeneric size (buffer)
(:documentation "Return the number of objects in the buffer."))
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.1 climacs/cl-syntax.lisp:1.2
--- climacs/cl-syntax.lisp:1.1 Mon Feb 7 16:26:41 2005
+++ climacs/cl-syntax.lisp Fri Feb 25 08:11:24 2005
@@ -171,71 +171,71 @@
(defun next-entry (scan)
(let ((start-mark (clone-mark scan)))
- (flet ((make-entry (type)
- (return-from next-entry
- (make-instance type :start-mark start-mark :end-mark (clone-mark scan))))
- (fo () (forward-object scan)))
- (loop with object = (object-after scan)
- until (end-of-buffer-p scan)
- do (case object
- (#\( (fo) (make-entry 'list-start-entry))
- (#\) (fo) (make-entry 'list-end-entry))
- (#\; (fo) (make-entry 'comment-entry))
- (#\" (fo) (make-entry 'double-quote-entry))
- (#\' (fo) (make-entry 'quote-entry))
- (#\` (fo) (make-entry 'backquote-entry))
- (#\, (fo) (make-entry 'unquote-entry))
- (#\# (fo)
- (loop until (end-of-buffer-p scan)
- while (member (object-after scan)
- '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
- do (fo))
- (if (end-of-buffer-p scan)
- (make-entry 'error-entry)
- (case (object-after scan)
- (#\# (fo) (make-entry 'label-ref-entry))
- (#\= (fo) (make-entry 'label-entry))
- (#\' (fo) (make-entry 'function-entry))
- (#\| (fo) (make-entry 'balanced-comment-entry))
- (#\+ (fo) (make-entry 'read-time-conditional-plus-entry))
- (#\- (fo) (make-entry 'read-time-conditional-minus-entry))
- (#\( (fo) (make-entry 'vector-entry))
- (#\* (fo) (make-entry 'bitvector-entry))
- (#\: (fo) (make-entry 'uninterned-symbol-entry))
- (#\. (fo) (make-entry 'read-time-evaluation-entry))
- ((#\A #\a) (fo) (make-entry 'array-entry))
- ((#\B #\b) (fo) (make-entry 'binary-entry))
- ((#\C #\c) (fo) (make-entry 'complex-entry))
- ((#\O #\o) (fo) (make-entry 'octal-entry))
- ((#\P #\p) (fo) (make-entry 'pathname-entry))
- ((#\R #\r) (fo) (make-entry 'radix-n-entry))
- ((#\S #\s) (fo) (make-entry 'structure-entry))
- ((#\X #\x) (fo) (make-entry 'hex-entry))
- (#\\ (fo)
- (cond ((end-of-buffer-p scan)
- (make-entry 'error-entry))
- ((not (constituentp (object-after scan)))
- (fo)
- (make-entry 'character-entry))
- (t
- (fo)
- (loop until (end-of-buffer-p scan)
- while (constituentp (object-after scan))
- do (fo))
- (make-entry 'character-entry))))
- (t (make-entry 'error-entry)))))
- (t (cond ((whitespacep object)
- (loop until (end-of-buffer-p scan)
- while (whitespacep (object-after scan))
- do (fo))
- (make-entry 'whitespace-entry))
- ((constituentp object)
- (loop until (end-of-buffer-p scan)
- while (constituentp (object-after scan))
- do (fo))
- (make-entry 'token-entry))
- (t
- (fo) (make-entry 'error-entry)))))))))
+ (flet ((fo () (forward-object scan)))
+ (macrolet ((make-entry (type)
+ `(return-from next-entry
+ (make-instance ,type :start-mark start-mark :end-mark (clone-mark scan)))))
+ (loop with object = (object-after scan)
+ until (end-of-buffer-p scan)
+ do (case object
+ (#\( (fo) (make-entry 'list-start-entry))
+ (#\) (fo) (make-entry 'list-end-entry))
+ (#\; (fo) (make-entry 'comment-entry))
+ (#\" (fo) (make-entry 'double-quote-entry))
+ (#\' (fo) (make-entry 'quote-entry))
+ (#\` (fo) (make-entry 'backquote-entry))
+ (#\, (fo) (make-entry 'unquote-entry))
+ (#\# (fo)
+ (loop until (end-of-buffer-p scan)
+ while (member (object-after scan)
+ '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
+ do (fo))
+ (if (end-of-buffer-p scan)
+ (make-entry 'error-entry)
+ (case (object-after scan)
+ (#\# (fo) (make-entry 'label-ref-entry))
+ (#\= (fo) (make-entry 'label-entry))
+ (#\' (fo) (make-entry 'function-entry))
+ (#\| (fo) (make-entry 'balanced-comment-entry))
+ (#\+ (fo) (make-entry 'read-time-conditional-plus-entry))
+ (#\- (fo) (make-entry 'read-time-conditional-minus-entry))
+ (#\( (fo) (make-entry 'vector-entry))
+ (#\* (fo) (make-entry 'bitvector-entry))
+ (#\: (fo) (make-entry 'uninterned-symbol-entry))
+ (#\. (fo) (make-entry 'read-time-evaluation-entry))
+ ((#\A #\a) (fo) (make-entry 'array-entry))
+ ((#\B #\b) (fo) (make-entry 'binary-entry))
+ ((#\C #\c) (fo) (make-entry 'complex-entry))
+ ((#\O #\o) (fo) (make-entry 'octal-entry))
+ ((#\P #\p) (fo) (make-entry 'pathname-entry))
+ ((#\R #\r) (fo) (make-entry 'radix-n-entry))
+ ((#\S #\s) (fo) (make-entry 'structure-entry))
+ ((#\X #\x) (fo) (make-entry 'hex-entry))
+ (#\\ (fo)
+ (cond ((end-of-buffer-p scan)
+ (make-entry 'error-entry))
+ ((not (constituentp (object-after scan)))
+ (fo)
+ (make-entry 'character-entry))
+ (t
+ (fo)
+ (loop until (end-of-buffer-p scan)
+ while (constituentp (object-after scan))
+ do (fo))
+ (make-entry 'character-entry))))
+ (t (make-entry 'error-entry)))))
+ (t (cond ((whitespacep object)
+ (loop until (end-of-buffer-p scan)
+ while (whitespacep (object-after scan))
+ do (fo))
+ (make-entry 'whitespace-entry))
+ ((constituentp object)
+ (loop until (end-of-buffer-p scan)
+ while (constituentp (object-after scan))
+ do (fo))
+ (make-entry 'token-entry))
+ (t
+ (fo) (make-entry 'error-entry))))))))))
(defmethod update-syntax (buffer (syntax cl-syntax))
(let ((low-mark (low-mark buffer))
From abakic at common-lisp.net Fri Feb 25 20:45:14 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Fri, 25 Feb 2005 21:45:14 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/base-test.lisp
climacs/buffer-test.lisp
Message-ID: <20050225204514.554B3884E2@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv20153
Modified Files:
base-test.lisp buffer-test.lisp
Log Message:
Updated persistent buffers and tests to catch up with recent changes.
Date: Fri Feb 25 21:45:08 2005
Author: abakic
Index: climacs/base-test.lisp
diff -u climacs/base-test.lisp:1.10 climacs/base-test.lisp:1.11
--- climacs/base-test.lisp:1.10 Sat Feb 12 16:34:46 2005
+++ climacs/base-test.lisp Fri Feb 25 21:45:07 2005
@@ -8,20 +8,22 @@
(defmultitest previous-line.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
+climacs
climacs")
(let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 8)))
- (previous-line mark)
+ :buffer buffer :offset 16)))
+ (previous-line mark nil 2)
(offset mark)))
0)
(defmultitest previous-line.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
+climacs
climacs")
(let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 11)))
- (previous-line mark 2)
+ :buffer buffer :offset 19)))
+ (previous-line mark 2 2)
(offset mark)))
2)
@@ -78,22 +80,24 @@
(defmultitest next-line.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
+climacs
climacs")
(let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 6)))
- (next-line mark)
+ (next-line mark nil 2)
(offset mark)))
- 14)
+ 22)
(defmultitest next-line.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
+climacs
climacs")
(let ((mark (make-instance %%right-sticky-mark
:buffer buffer :offset 3)))
- (next-line mark 2)
+ (next-line mark 2 2)
(offset mark)))
- 10)
+ 18)
(defmultitest next-line.test-3
(let ((buffer (make-instance %%buffer)))
@@ -150,9 +154,10 @@
(insert-buffer-sequence buffer 0 "climacs")
(let ((mark (make-instance %%left-sticky-mark
:buffer buffer :offset 0)))
- (open-line mark)
+ (open-line mark 2)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"
+
climacs" 0)
(defmultitest open-line.test-2
Index: climacs/buffer-test.lisp
diff -u climacs/buffer-test.lisp:1.16 climacs/buffer-test.lisp:1.17
--- climacs/buffer-test.lisp:1.16 Fri Feb 25 08:11:24 2005
+++ climacs/buffer-test.lisp Fri Feb 25 21:45:07 2005
@@ -55,7 +55,7 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(make-instance %%left-sticky-mark :buffer buffer :offset 1))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-after-end (c)
(= (climacs-buffer::condition-offset c) 1)))
t)
@@ -63,7 +63,7 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(make-instance %%right-sticky-mark :buffer buffer :offset 1))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-after-end (c)
(= (climacs-buffer::condition-offset c) 1)))
t)
@@ -137,7 +137,7 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(insert-buffer-object buffer -1 #\a))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-before-beginning (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
@@ -171,7 +171,7 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 1 "climacs"))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-after-end (c)
(= (climacs-buffer::condition-offset c) 1)))
t)
@@ -179,7 +179,7 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer -1 "climacs"))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-before-beginning (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
@@ -225,7 +225,7 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(delete-buffer-range buffer -1 0))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-before-beginning (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
@@ -234,7 +234,7 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(delete-buffer-range buffer 6 2))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-after-end (c)
(= (climacs-buffer::condition-offset c) 8)))
t)
@@ -482,7 +482,7 @@
(let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 4)))
(setf (offset m) -1)))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-before-beginning (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
@@ -493,7 +493,7 @@
(let ((m (make-instance %%left-sticky-mark
:buffer buffer :offset 4)))
(setf (offset m) 8)))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-after-end (c)
(= (climacs-buffer::condition-offset c) 8)))
t)
@@ -516,7 +516,7 @@
(m2 (clone-mark m1)))
(backward-object m1 3)
(region-to-sequence m1 m2)))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-before-beginning (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
@@ -539,7 +539,7 @@
(m2 (clone-mark m1)))
(forward-object m1 3)
(region-to-sequence m1 m2)))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-after-end (c)
(= (climacs-buffer::condition-offset c) 9)))
t)
@@ -554,7 +554,7 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(setf (buffer-object buffer 0) #\a))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::offset-after-end (c)
(= (climacs-buffer::condition-offset c) 0)))
t)
@@ -562,7 +562,7 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(setf (buffer-object buffer -1) #\a))
- (climacs-buffer::no-such-offset (c)
+ (climacs-buffer::motion-before-beginning (c)
(= (climacs-buffer::condition-offset c) -1)))
t)
From abakic at common-lisp.net Fri Feb 25 20:45:16 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Fri, 25 Feb 2005 21:45:16 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Persistent/persistent-buffer.lisp
Message-ID: <20050225204516.7A44E8866E@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Persistent
In directory common-lisp.net:/tmp/cvs-serv20153/Persistent
Modified Files:
persistent-buffer.lisp
Log Message:
Updated persistent buffers and tests to catch up with recent changes.
Date: Fri Feb 25 21:45:14 2005
Author: abakic
Index: climacs/Persistent/persistent-buffer.lisp
diff -u climacs/Persistent/persistent-buffer.lisp:1.6 climacs/Persistent/persistent-buffer.lisp:1.7
--- climacs/Persistent/persistent-buffer.lisp:1.6 Sun Feb 6 17:33:52 2005
+++ climacs/Persistent/persistent-buffer.lisp Fri Feb 25 21:45:11 2005
@@ -103,8 +103,10 @@
(cursor-pos (cursor mark)))
(defmethod (setf offset) (new-offset (mark p-mark-mixin))
- (assert (<= 0 new-offset (size (buffer mark))) ()
- (make-condition 'no-such-offset :offset new-offset))
+ (assert (<= 0 new-offset) ()
+ (make-condition 'motion-before-beginning :offset new-offset))
+ (assert (<= new-offset (size (buffer mark))) ()
+ (make-condition 'motion-after-end :offset new-offset))
(setf (cursor-pos (cursor mark)) new-offset))
(defclass persistent-left-sticky-mark (left-sticky-mark p-mark-mixin) ()
@@ -119,8 +121,10 @@
&rest args &key (offset 0))
"Associates a created mark with the buffer for which it was created."
(declare (ignorable args))
- (assert (<= 0 offset (size (buffer mark))) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'motion-before-beginning :offset offset))
+ (assert (<= offset (size (buffer mark))) ()
+ (make-condition 'motion-after-end :offset offset))
(setf (slot-value mark 'cursor)
(make-instance 'left-sticky-persistent-cursor
:buffer (buffer mark)
@@ -130,8 +134,10 @@
&rest args &key (offset 0))
"Associates a created mark with the buffer for which it was created."
(declare (ignorable args))
- (assert (<= 0 offset (size (buffer mark))) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'motion-before-beginning :offset offset))
+ (assert (<= offset (size (buffer mark))) ()
+ (make-condition 'motion-after-end :offset offset))
(setf (slot-value mark 'cursor)
(make-instance 'right-sticky-persistent-cursor
:buffer (buffer mark)
@@ -145,6 +151,26 @@
(setf high-mark (make-instance 'persistent-right-sticky-mark
:buffer buffer))))
+(defmethod clone-mark ((mark persistent-left-sticky-mark) &optional stick-to)
+ (cond
+ ((or (null stick-to) (eq stick-to :left))
+ (make-instance 'persistent-left-sticky-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ ((eq stick-to :right)
+ (make-instance 'persistent-right-sticky-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ (t (error "invalid value for stick-to"))))
+
+(defmethod clone-mark ((mark persistent-right-sticky-mark) &optional stick-to)
+ (cond
+ ((or (null stick-to) (eq stick-to :right))
+ (make-instance 'persistent-right-sticky-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ ((eq stick-to :left)
+ (make-instance 'persistent-left-sticky-mark
+ :buffer (buffer mark) :offset (offset mark)))
+ (t (error "invalid value for stick-to"))))
+
(defmethod size ((buffer binseq-buffer))
(binseq-length (slot-value buffer 'contents)))
@@ -258,8 +284,10 @@
;;; it can be saved for UNDO purposes in a history tree, by an UNDOABLE-BUFFER
(defmethod insert-buffer-object ((buffer binseq-buffer) offset object)
- (assert (<= 0 offset (size buffer)) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
(setf (slot-value buffer 'contents)
(binseq-insert (slot-value buffer 'contents) offset object)))
@@ -286,8 +314,10 @@
(insert-buffer-sequence (buffer mark) (offset mark) sequence))
(defmethod delete-buffer-range ((buffer binseq-buffer) offset n)
- (assert (<= 0 offset (size buffer)) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset))
(setf (slot-value buffer 'contents)
(binseq-remove* (slot-value buffer 'contents) offset n)))
@@ -324,32 +354,44 @@
(delete-buffer-range (buffer mark2) offset1 (- offset2 offset1))))
(defmethod buffer-object ((buffer binseq-buffer) offset)
- (assert (<= 0 offset (1- (size buffer))) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (1- (size buffer))) ()
+ (make-condition 'offset-after-end :offset offset))
(binseq-get (slot-value buffer 'contents) offset))
(defmethod (setf buffer-object) (object (buffer binseq-buffer) offset)
- (assert (<= 0 offset (1- (size buffer))) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (1- (size buffer))) ()
+ (make-condition 'offset-after-end :offset offset))
(setf (slot-value buffer 'contents)
(binseq-set (slot-value buffer 'contents) offset object)))
(defmethod buffer-object ((buffer obinseq-buffer) offset)
- (assert (<= 0 offset (1- (size buffer))) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (1- (size buffer))) ()
+ (make-condition 'offset-after-end :offset offset))
(obinseq-get (slot-value buffer 'contents) offset))
(defmethod (setf buffer-object) (object (buffer obinseq-buffer) offset)
- (assert (<= 0 offset (1- (size buffer))) ()
- (make-condition 'no-such-offset :offset offset))
+ (assert (<= 0 offset) ()
+ (make-condition 'offset-before-beginning :offset offset))
+ (assert (<= offset (1- (size buffer))) ()
+ (make-condition 'offset-after-end :offset offset))
(setf (slot-value buffer 'contents)
(obinseq-set (slot-value buffer 'contents) offset object)))
(defmethod buffer-sequence ((buffer binseq-buffer) offset1 offset2)
- (assert (<= 0 offset1 (size buffer)) ()
- (make-condition 'no-such-offset :offset offset1))
- (assert (<= 0 offset2 (size buffer)) ()
- (make-condition 'no-such-offset :offset offset2))
+ (assert (<= 0 offset1) ()
+ (make-condition 'offset-before-beginning :offset offset1))
+ (assert (<= offset1 (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset1))
+ (assert (<= 0 offset2) ()
+ (make-condition 'offset-before-beginning :offset offset2))
+ (assert (<= offset2 (size buffer)) ()
+ (make-condition 'offset-after-end :offset offset2))
(coerce
(let ((len (- offset2 offset1)))
(if (> len 0)
From rstrandh at common-lisp.net Sat Feb 26 05:33:41 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sat, 26 Feb 2005 06:33:41 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
Message-ID: <20050226053341.CE5988866E@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Doc
In directory common-lisp.net:/tmp/cvs-serv17346/Doc
Modified Files:
climacs-internals.texi
Log Message:
Updated the description of the buffer protocol to reflect recent changes
with respect to conditions and clone-mark.
Date: Sat Feb 26 06:33:39 2005
Author: rstrandh
Index: climacs/Doc/climacs-internals.texi
diff -u climacs/Doc/climacs-internals.texi:1.12 climacs/Doc/climacs-internals.texi:1.13
--- climacs/Doc/climacs-internals.texi:1.12 Sat Feb 5 14:49:22 2005
+++ climacs/Doc/climacs-internals.texi Sat Feb 26 06:33:37 2005
@@ -113,11 +113,12 @@
mark will be positioned to the right of the object.
@end deftp
- at deffn {Generic Function} {clone-mark} (mark &key type)
+ at deffn {Generic Function} {clone-mark} (mark &optional stick-to)
-Clone a mark. By default (when type is NIL) the same type of mark is
-returned. Otherwise type is the name of a class (subclass of the mark
-class) to be used as a class of the clone.
+Clone a mark. By default (when stick-to is NIL) the same type of mark
+is returned. Otherwise stick-to is either :left, indicating that a
+left-sticky-mark should be created, or :right indicating that a
+right-sticky-mark should be created.
@end deffn
@deffn {Generic Function} {buffer} mark
@@ -127,8 +128,42 @@
@deftp {Error Condition} no-such-offset
-This condition is signaled whenever an attempt is made at an operation
-that is before the beginning or after the end of the buffer.
+This condition is signaled whenever an attempt is made to access an
+object that is before the beginning or after the end of the buffer.
+ at end deftp
+
+ at deftp {Error Condition} offset-before-beginning
+
+This condition is signaled whenever an attempt is made to access
+buffer contents that is before the beginning of the buffer.
+This condition is a subclass of no-such-offset
+ at end deftp
+
+ at deftp {Error Condition} offset-after-end
+
+This condition is signaled whenever an attempt is made to access
+buffer contents that is after the end of the buffer.
+This condition is a subclass of no-such-offset
+ at end deftp
+
+ at deftp {Error Condition} invalid-motion
+
+This condition is signaled whenever an attempt is made to move a mark
+before the beginning or after the end of the buffer.
+ at end deftp
+
+ at deftp {Error Condition} motion-before-beginning
+
+This condition is signaled whenever an attempt is made to move a mark
+before the beginning of the buffer.
+This condition is a subclass of invalid-motion.
+ at end deftp
+
+ at deftp {Error Condition} motion-after-end
+
+This condition is signaled whenever an attempt is made to move a mark
+after the end of the buffer.
+This condition is a subclass of invalid-motion.
@end deftp
@deffn {Generic Function} {size} buffer
@@ -152,25 +187,32 @@
@deffn {Generic Function} {(setf offset)} offset mark
-Set the offset of the mark into the buffer. A no-such-offset
-condition is signaled if the offset is less than zero or greater than
-the size of the buffer.
+Set the offset of the mark into the buffer. A motion-before-beginning
+condition is signaled if the offset is less than zero. A
+motion-after-end condition is signaled if the offset is greater than
+the size of the buffer.
@end deffn
@deffn {Generic Function} {forward-object} mark &optional (count 1)
-Move the mark forward the number of positions indicated by count.
+Move the mark forward the number of positions indicated by count.
This function could be implemented by an incf on the offset of the
mark, but many buffer implementations can implement this function much
-more efficiently in a different way.
+more efficiently in a different way. A motion-before-beginning
+condition is signaled if the resulting offset of the mark is less than
+zero. A motion-after-end condition is signaled if the resulting offset
+of the mark is greater than the size of the buffer.
@end deffn
@deffn {Generic Function} {backward-object} mark &optional (count 1)
-Move the mark backward the number of positions indicated by count.
+Move the mark backward the number of positions indicated by count.
This function could be implemented by a decf on the offset of the
mark, but many buffer implementations can implement this function much
-more efficiently in a different way.
+more efficiently in a different way. A motion-before-beginning
+condition is signaled if the resulting offset of the mark is less than
+zero. A motion-after-end condition is signaled if the resulting offset
+of the mark is greater than the size of the buffer.
@end deffn
@deffn {Generic Function} {mark<} mark1 mark2
@@ -309,9 +351,10 @@
@deffn {Generic Function} {delete-buffer-range} buffer offset n
-Delete n objects from the buffer starting at the offset. If offset
-is negative or offset+n is greater than the size of the buffer, a
-no-such-offset condition is signaled.
+Delete n objects from the buffer starting at the offset. If offset is
+negative, a offset-before-beginning condition is signaled. If
+offset+n is greater than the size of the buffer, a offset-after-end
+condition is signaled.
@end deffn
@deffn {Generic Function} {delete-range} mark &optional (n 1)
@@ -336,31 +379,33 @@
@deffn {Generic Function} {buffer-object} buffer offset
Return the object at the offset in the buffer. The first object
-has offset 0. If offset is less than zero or greater than or equal to
-the size of the buffer, a no-such-offset condition is signaled.
+has offset 0. If offset is less than zero, an offset-before-beginning
+condition is signaled. If offset is greater than or equal to
+the size of the buffer, an offset-after-end condition is signaled.
@end deffn
@deffn {Generic Function} {buffer-sequence} buffer offset1 offset2
Return the contents of the buffer starting at offset1 and ending at
-offset2-1 as a sequence. If either of the offsets is less than zero
-or greater than or equal to the size of the buffer, a no-such-offset
-condition is signaled. If offset2 is smaller than or equal to
-offset1, an empty sequence will be returned.
+offset2-1 as a sequence. If either of the offsets is less than zero,
+an offset-before-beginning condition is signaled. If either of the
+offsets is greater than or equal to the size of the buffer, an
+offset-after-end condition is signaled. If offset2 is smaller than or
+equal to offset1, an empty sequence will be returned.
@end deffn
@deffn {Generic Function} {object-before} mark
Return the object that is immediately before the mark. If mark is at
-the beginning of the buffer, a no-such-offset condition is signaled.
-If the mark is at the beginning of a line, but not at the beginning
-of the buffer, a newline character is returned.
+the beginning of the buffer, an offset-before-beginning condition is
+signaled. If the mark is at the beginning of a line, but not at the
+beginning of the buffer, a newline character is returned.
@end deffn
@deffn {Generic Function} {object-after} mark
Return the object that is immediately after the mark. If mark is at
-the end of the buffer, a no-such-offset condition is signaled. If
+the end of the buffer, an offset-after-end condition is signaled. If
the mark is at the end of a line, but not at the end of the buffer, a
newline character is returned.
@end deffn
@@ -371,6 +416,8 @@
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 buffer-sequence with the appropriate arguments.
@end deffn
@section Implementation hints
From rstrandh at common-lisp.net Sun Feb 27 06:16:58 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sun, 27 Feb 2005 07:16:58 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/cl-syntax.lisp
Message-ID: <20050227061658.446818866C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv1114
Modified Files:
cl-syntax.lisp
Log Message:
Decreased consing by a third, and improved performance at the same
time, by having a single mark and a size instead of two marks in a
stack entry.
Date: Sun Feb 27 07:16:52 2005
Author: rstrandh
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.2 climacs/cl-syntax.lisp:1.3
--- climacs/cl-syntax.lisp:1.2 Fri Feb 25 08:11:24 2005
+++ climacs/cl-syntax.lisp Sun Feb 27 07:16:48 2005
@@ -24,9 +24,15 @@
(defclass stack-entry ()
((start-mark :initarg :start-mark :reader start-mark)
- (end-mark :initarg :end-mark :reader end-mark))
+ (size :initarg :size))
(:documentation "A stack entry corresponds to a syntactic category"))
+(defgeneric end-offset (stack-entry))
+
+(defmethod end-offset ((entry stack-entry))
+ (with-slots (start-mark size) entry
+ (+ (offset start-mark) size)))
+
(defclass error-entry (stack-entry) ())
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -167,14 +173,15 @@
:buffer buffer
:offset 0)))
(insert* elements 0 (make-instance 'start-entry
- :start-mark mark :end-mark mark)))))
+ :start-mark mark :size 0)))))
(defun next-entry (scan)
(let ((start-mark (clone-mark scan)))
(flet ((fo () (forward-object scan)))
(macrolet ((make-entry (type)
`(return-from next-entry
- (make-instance ,type :start-mark start-mark :end-mark (clone-mark scan)))))
+ (make-instance ,type :start-mark start-mark
+ :size (- (offset scan) (offset start-mark))))))
(loop with object = (object-after scan)
until (end-of-buffer-p scan)
do (case object
@@ -245,12 +252,12 @@
(when (mark<= low-mark high-mark)
;; go back to a position before low-mark
(loop until (or (= guess-pos 1)
- (mark< (end-mark (element* elements (1- guess-pos))) low-mark))
+ (mark< (end-offset (element* elements (1- guess-pos))) low-mark))
do (decf guess-pos))
;; go forward to the last position before low-mark
(loop with nb-elements = (nb-elements elements)
until (or (= guess-pos nb-elements)
- (mark>= (end-mark (element* elements guess-pos)) low-mark))
+ (mark>= (end-offset (element* elements guess-pos)) low-mark))
do (incf guess-pos))
;; delete entries that must be reparsed
(loop until (or (= guess-pos (nb-elements elements))
@@ -260,7 +267,7 @@
:buffer buffer
:offset (if (zerop guess-pos)
0
- (offset (end-mark (element* elements (1- guess-pos)))))))
+ (end-offset (element* elements (1- guess-pos))))))
;; scan
(unless (end-of-buffer-p scan)
(loop with start-mark = nil
From rstrandh at common-lisp.net Sun Feb 27 06:23:29 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Sun, 27 Feb 2005 07:23:29 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/cl-syntax.lisp
Message-ID: <20050227062329.B33078866C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv1744
Modified Files:
cl-syntax.lisp
Log Message:
Improved performance some more by considering line comments to be
single entries.
Date: Sun Feb 27 07:23:28 2005
Author: rstrandh
Index: climacs/cl-syntax.lisp
diff -u climacs/cl-syntax.lisp:1.3 climacs/cl-syntax.lisp:1.4
--- climacs/cl-syntax.lisp:1.3 Sun Feb 27 07:16:48 2005
+++ climacs/cl-syntax.lisp Sun Feb 27 07:23:28 2005
@@ -187,7 +187,9 @@
do (case object
(#\( (fo) (make-entry 'list-start-entry))
(#\) (fo) (make-entry 'list-end-entry))
- (#\; (fo) (make-entry 'comment-entry))
+ (#\; (loop do (fo)
+ until (end-of-line-p scan))
+ (make-entry 'comment-entry))
(#\" (fo) (make-entry 'double-quote-entry))
(#\' (fo) (make-entry 'quote-entry))
(#\` (fo) (make-entry 'backquote-entry))
From abakic at common-lisp.net Sun Feb 27 19:02:16 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 27 Feb 2005 20:02:16 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/delegating-buffer.lisp
Message-ID: <20050227190216.2D5568866E@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv10609
Added Files:
delegating-buffer.lisp
Log Message:
Delegating-buffer class implementation.
Date: Sun Feb 27 20:02:15 2005
Author: abakic
From abakic at common-lisp.net Sun Feb 27 19:13:49 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 27 Feb 2005 20:13:49 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
Message-ID: <20050227191349.11A788866E@common-lisp.net>
Update of /project/climacs/cvsroot/climacs/Doc
In directory common-lisp.net:/tmp/cvs-serv10718
Modified Files:
climacs-internals.texi
Log Message:
Added descriptions of buffer-line-number and buffer-column-number.
Date: Sun Feb 27 20:13:48 2005
Author: abakic
Index: climacs/Doc/climacs-internals.texi
diff -u climacs/Doc/climacs-internals.texi:1.13 climacs/Doc/climacs-internals.texi:1.14
--- climacs/Doc/climacs-internals.texi:1.13 Sat Feb 26 06:33:37 2005
+++ climacs/Doc/climacs-internals.texi Sun Feb 27 20:13:47 2005
@@ -305,12 +305,24 @@
end of the buffer), nil otherwise.
@end deffn
+ at deffn {Generic Function} {buffer-line-number} buffer offset
+
+Return the line number of the line at offset. Lines are numbered from
+zero.
+ at end deffn
+
+ at deffn {Generic Function} {buffer-column-number} buffer offset
+
+Return the column number of the line at offset. It is the number of
+objects between it and the preceding newline, or between it and the
+beginning of the buffer if offset is on the first line of the buffer.
+ at end deffn
+
@deffn {Generic Function} {line-number} mark
Return the line number of the mark. Lines are numbered from zero.
@end deffn
-
@deffn {Generic Function} {column-number} mark
Return the column number of the mark. The column number of a mark is
@@ -318,7 +330,6 @@
between it and the beginning of the buffer if the mark is on the
first line of the buffer.
@end deffn
-
@section Inserting and deleting objects
From abakic at common-lisp.net Sun Feb 27 19:15:29 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 27 Feb 2005 20:15:29 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/delegating-buffer.lisp
Message-ID: <20050227191529.D86DF8866E@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv10897
Modified Files:
delegating-buffer.lisp
Log Message:
Added license.
Date: Sun Feb 27 20:15:28 2005
Author: abakic
Index: climacs/delegating-buffer.lisp
diff -u climacs/delegating-buffer.lisp:1.1 climacs/delegating-buffer.lisp:1.2
--- climacs/delegating-buffer.lisp:1.1 Sun Feb 27 20:02:15 2005
+++ climacs/delegating-buffer.lisp Sun Feb 27 20:15:27 2005
@@ -3,6 +3,23 @@
;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com)
;;;
+;;; This library is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Library General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2 of the License, or (at your option) any later version.
+;;;
+;;; This library is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Library General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Library General Public
+;;; License along with this library; if not, write to the
+;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;;; Boston, MA 02111-1307 USA.
+
+;;; GUI for the Climacs editor.
+
(in-package :climacs-buffer)
(defclass delegating-buffer (buffer)
From abakic at common-lisp.net Sun Feb 27 19:16:17 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 27 Feb 2005 20:16:17 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/delegating-buffer.lisp
Message-ID: <20050227191617.60CB18866E@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv11262
Modified Files:
delegating-buffer.lisp
Log Message:
Added description.
Date: Sun Feb 27 20:16:16 2005
Author: abakic
Index: climacs/delegating-buffer.lisp
diff -u climacs/delegating-buffer.lisp:1.2 climacs/delegating-buffer.lisp:1.3
--- climacs/delegating-buffer.lisp:1.2 Sun Feb 27 20:15:27 2005
+++ climacs/delegating-buffer.lisp Sun Feb 27 20:16:14 2005
@@ -18,7 +18,7 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
-;;; GUI for the Climacs editor.
+;;; Buffer class that allow specifying buffer implementation at run time.
(in-package :climacs-buffer)
From abakic at common-lisp.net Sun Feb 27 21:21:54 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 27 Feb 2005 22:21:54 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/delegating-buffer.lisp
Message-ID: <20050227212154.7FDC08866E@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv17788
Modified Files:
delegating-buffer.lisp
Log Message:
Fixed description...
Date: Sun Feb 27 22:21:51 2005
Author: abakic
Index: climacs/delegating-buffer.lisp
diff -u climacs/delegating-buffer.lisp:1.3 climacs/delegating-buffer.lisp:1.4
--- climacs/delegating-buffer.lisp:1.3 Sun Feb 27 20:16:14 2005
+++ climacs/delegating-buffer.lisp Sun Feb 27 22:21:51 2005
@@ -18,7 +18,7 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
-;;; Buffer class that allow specifying buffer implementation at run time.
+;;; Buffer class that allows for specifying buffer implementation at run time.
(in-package :climacs-buffer)
From rstrandh at common-lisp.net Mon Feb 28 08:51:40 2005
From: rstrandh at common-lisp.net (Robert Strandh)
Date: Mon, 28 Feb 2005 09:51:40 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/html-syntax.lisp
climacs/packages.lisp
Message-ID: <20050228085140.DF1428866C@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv23495
Modified Files:
gui.lisp html-syntax.lisp packages.lisp
Log Message:
Improvements to HTML syntax. This syntax module now uses an
incremental lexer, and and incremental parser based on the existing
Earley parser in syntax.lisp.
Removed backward-to-error and forward-to-error, since I am not sure
that these are what we want.
Date: Mon Feb 28 09:51:36 2005
Author: rstrandh
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.125 climacs/gui.lisp:1.126
--- climacs/gui.lisp:1.125 Sun Feb 27 19:52:01 2005
+++ climacs/gui.lisp Mon Feb 28 09:51:33 2005
@@ -1282,18 +1282,6 @@
(syntax (syntax (buffer pane))))
(end-of-paragraph point syntax)))
-(define-named-command com-backward-to-error ()
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (display-message "~a" (backward-to-error point syntax))))
-
-(define-named-command com-forward-to-error ()
- (let* ((pane (current-window))
- (point (point pane))
- (syntax (syntax (buffer pane))))
- (display-message "~a" (forward-to-error point syntax))))
-
(define-named-command com-eval-expression ((insertp 'boolean :prompt "Insert?"))
(let* ((*package* (find-package :climacs-gui))
(string (handler-case (accept 'string :prompt "Eval")
Index: climacs/html-syntax.lisp
diff -u climacs/html-syntax.lisp:1.3 climacs/html-syntax.lisp:1.4
--- climacs/html-syntax.lisp:1.3 Sat Feb 5 07:49:53 2005
+++ climacs/html-syntax.lisp Mon Feb 28 09:51:34 2005
@@ -34,183 +34,237 @@
(and (eq (class-of t1) (class-of t2))
(< (badness t1) (badness t2))))
-(defclass html (html-sym) ())
-(defclass head (html-sym) ())
-(defclass title (html-sym) ())
-(defclass body (html-sym) ())
-(defclass h1 (html-sym) ())
-(defclass h2 (html-sym) ())
-(defclass h3 (html-sym) ())
-(defclass para (html-sym) ())
-(defclass ul (html-sym) ())
-(defclass li (html-sym) ())
-(defclass texts (html-sym) ())
-
-(defclass error-token (html-sym) ())
-(defclass text (html-sym) ())
-
-(defclass (html-sym) ())
-(defclass (html-sym) ())
-(defclass (html-sym) ())
-(defclass (html-sym) ())
-(defclass (html-sym) ())
-(defclass (html-sym) ())
-(defclass (html-sym) ())
-(defclass (html-sym) ())
-(defclass (html-sym) ())
-(defclass
(html-sym) ())
-(defclass (html-sym) ())
-(defclass
(html-sym) ())
-(defclass (html-sym) ())
-(defclass
(html-sym) ())
-(defclass (html-sym) ())
-(defclass
(html-sym) ())
-(defclass (html-sym) ())
-(defclass
(html-sym) ())
-(defclass (html-sym) ())
-(defclass (html-sym) ())
+(defclass words (html-sym) ())
+
+(defclass empty-words (words) ())
+
+(defclass nonempty-words (words)
+ ((words :initarg :words)
+ (word :initarg :word)))
+
+(defclass html-balanced (html-sym)
+ ((start :initarg :start)
+ (end :initarg :end)))
+
+(defclass html (html-balanced)
+ ((head :initarg :head)
+ (body :initarg :body)))
+
+(defclass head (html-balanced)
+ ((title :initarg :title)))
+
+(defclass html-words (html-balanced)
+ ((words :initarg :words)))
+
+(defclass title (html-words) ())
+(defclass body (html-words) ())
+(defclass h1 (html-words) ())
+(defclass h2 (html-words) ())
+(defclass h3 (html-words) ())
+(defclass para (html-words) ())
+
+(defclass html-token (html-sym)
+ ((start-mark :initarg :start-mark :reader start-mark)
+ (size :initarg :size)))
+
+(defgeneric end-offset (html-token))
+
+(defmethod end-offset ((token html-token))
+ (with-slots (start-mark size) token
+ (+ (offset start-mark) size)))
+
+(defgeneric start-offset (html-token))
+
+(defmethod start-offset ((token html-token))
+ (offset (start-mark token)))
+
+(defclass (html-token) () (:default-initargs :size 6))
+(defclass (html-token) ()(:default-initargs :size 7))
+(defclass (html-token) () (:default-initargs :size 6))
+(defclass (html-token) () (:default-initargs :size 7))
+(defclass (html-token) () (:default-initargs :size 7))
+(defclass (html-token) () (:default-initargs :size 8))
+(defclass (html-token) () (:default-initargs :size 6))
+(defclass (html-token) () (:default-initargs :size 7))
+(defclass (html-token) () (:default-initargs :size 4))
+(defclass
(html-token) () (:default-initargs :size 5))
+(defclass (html-token) () (:default-initargs :size 4))
+(defclass
(html-token) () (:default-initargs :size 5))
+(defclass (html-token) () (:default-initargs :size 4))
+(defclass
(html-token) () (:default-initargs :size 5))
+(defclass (html-token) () (:default-initargs :size 3))
+(defclass
(html-token) () (:default-initargs :size 4))
+(defclass (html-token) () (:default-initargs :size 4))
+(defclass
(html-token) () (:default-initargs :size 5))
+(defclass (html-token) () (:default-initargs :size 4))
+(defclass (html-token) () (:default-initargs :size 5))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; lexer
-(defparameter *token-table*
- '(("" . )
- ("" . )
- ("" . )
- ("" . )
- ("" . <title>)
- ("" . )
- ("" . )
- ("" . )
- ("" . )
- ("
" .
)
- ("" . )
- ("
" .
)
- ("" . )
- ("
" .
)
- ("" .
)
- ("
" . )
- (")
- ("" . )
- ("" . )))
-
-(defclass html-lexer (lexer)
- ((mark :initarg :mark)))
-
-(defmethod lex ((lexer html-lexer))
- (with-slots (mark) lexer
- (assert (not (end-of-buffer-p mark)))
- (cond ((or (end-of-line-p mark)
- (not (eql (object-after mark) #\<)))
- (when (end-of-line-p mark)
- (forward-object mark))
- (loop until (or (end-of-line-p mark)
- (eql (object-after mark) #\<))
- do (forward-object mark))
- (make-instance 'text))
- (t
- (let ((offset (offset mark)))
- (forward-object mark)
- (loop until (or (end-of-line-p mark)
- (whitespacep (object-after mark))
- (eql (object-before mark) #\>))
- do (forward-object mark))
- (let* ((word (region-to-sequence offset mark))
- (class-name (cdr (assoc word *token-table* :test #'equalp))))
- (make-instance (or class-name 'error-token))))))))
+(defclass html-element (html-token)
+ ((state :initarg :state)))
+
+(defclass start-element (html-element) ())
+(defclass tag-start (html-element) ())
+(defclass tag-end (html-element) ())
+(defclass slash (html-element) ())
+(defclass word (html-element) ())
+(defclass delimiter (html-element) ())
+
+(defun next-token (scan)
+ (let ((start-mark (clone-mark scan)))
+ (flet ((fo () (forward-object scan)))
+ (macrolet ((make-entry (type)
+ `(return-from next-token
+ (make-instance ,type :start-mark start-mark
+ :size (- (offset scan) (offset start-mark))))))
+ (loop with object = (object-after scan)
+ until (end-of-buffer-p scan)
+ do (case object
+ (#\< (fo) (make-entry 'tag-start))
+ (#\> (fo) (make-entry 'tag-end))
+ (#\/ (fo) (make-entry 'slash))
+ (t (cond ((alphanumericp object)
+ (loop until (end-of-buffer-p scan)
+ while (alphanumericp (object-after scan))
+ do (fo))
+ (make-entry 'word))
+ (t
+ (fo) (make-entry 'delimiter))))))))))
+
+(define-syntax html-syntax ("HTML" (basic-syntax))
+ ((tokens :initform (make-instance 'standard-flexichain))
+ (guess-pos :initform 1)
+ (valid-parse :initform 1)
+ (parser)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; parser
+(defun word-is (word string)
+ (string-equal (coerce (region-to-sequence (start-mark word) (end-offset word)) 'string)
+ string))
+
(defparameter *html-grammar*
(grammar
- (html -> ( head body ))
- (head -> ( title ))
- (title -> ( texts ))
- (body -> ( texts ))
- (texts -> ())
- (texts -> (texts text))))
-
-(define-syntax html-syntax ("HTML" (basic-syntax))
- ((parser)
- (states)))
+ ( -> (tag-start
+ (word (and (= (end-offset tag-start) (start-offset word))
+ (word-is word "html")))
+ (tag-end (= (end-offset word) (start-offset tag-end))))
+ :start-mark (start-mark tag-start))
+ ( -> (tag-start
+ (slash (= (end-offset tag-start) (start-offset slash)))
+ (word (and (= (end-offset slash) (start-offset word))
+ (word-is word "html")))
+ (tag-end (= (end-offset word) (start-offset tag-end))))
+ :start-mark (start-mark tag-start))
+ ( -> (tag-start
+ (word (and (= (end-offset tag-start) (start-offset word))
+ (word-is word "head")))
+ (tag-end (= (end-offset word) (start-offset tag-end))))
+ :start-mark (start-mark tag-start))
+ ( -> (tag-start
+ (slash (= (end-offset tag-start) (start-offset slash)))
+ (word (and (= (end-offset slash) (start-offset word))
+ (word-is word "head")))
+ (tag-end (= (end-offset word) (start-offset tag-end))))
+ :start-mark (start-mark tag-start))
+ ( -> (tag-start
+ (word (and (= (end-offset tag-start) (start-offset word))
+ (word-is word "title")))
+ (tag-end (= (end-offset word) (start-offset tag-end))))
+ :start-mark (start-mark tag-start))
+ ( -> (tag-start
+ (slash (= (end-offset tag-start) (start-offset slash)))
+ (word (and (= (end-offset slash) (start-offset word))
+ (word-is word "title")))
+ (tag-end (= (end-offset word) (start-offset tag-end))))
+ :start-mark (start-mark tag-start))
+ ( -> (tag-start
+ (word (and (= (end-offset tag-start) (start-offset word))
+ (word-is word "body")))
+ (tag-end (= (end-offset word) (start-offset tag-end))))
+ :start-mark (start-mark tag-start))
+ ( -> (tag-start
+ (slash (= (end-offset tag-start) (start-offset slash)))
+ (word (and (= (end-offset slash) (start-offset word))
+ (word-is word "body")))
+ (tag-end (= (end-offset word) (start-offset tag-end))))
+ :start-mark (start-mark tag-start))
+ (html -> ( head body )
+ :start :head head :body body :end )
+ (head -> ( title )
+ :start :title title :end )
+ (title -> ( words )
+ :start :words words :end )
+ (body -> ( words )
+ :start :words words :end )
+ (words -> ()
+ (make-instance 'empty-words))
+ (words -> (words word)
+ (make-instance 'nonempty-words :words words :word word))))
(defmethod initialize-instance :after ((syntax html-syntax) &rest args)
(declare (ignore args))
- (with-slots (parser states buffer) syntax
+ (with-slots (parser tokens buffer) syntax
(setf parser (make-instance 'parser
:grammar *html-grammar*
- :lexer (make-instance 'html-lexer
- :mark (make-instance 'standard-left-sticky-mark :buffer buffer))
:target 'html))
- (setf states (list (cons (make-instance 'standard-left-sticky-mark :buffer buffer)
- (initial-state parser))))))
+ (insert* tokens 0 (make-instance 'start-element
+ :start-mark (make-instance 'standard-left-sticky-mark
+ :buffer buffer
+ :offset 0)
+ :size 0
+ :state (initial-state parser)))))
+
+(defmethod update-syntax-for-display (buffer (syntax html-syntax) top bot)
+ (with-slots (parser tokens valid-parse) syntax
+ (loop until (= valid-parse (nb-elements tokens))
+ while (mark< (end-offset (element* tokens valid-parse)) bot)
+ do (let ((current-token (element* tokens (1- valid-parse)))
+ (next-token (element* tokens valid-parse)))
+ (setf (slot-value next-token 'state)
+ (advance-parse parser (list next-token) (slot-value current-token 'state))))
+ (incf valid-parse))))
(defmethod update-syntax (buffer (syntax html-syntax))
- (let ((low-mark (low-mark buffer)))
- (with-slots (parser states) syntax
- (with-slots (lexer) parser
- (with-slots (mark) lexer
- (loop until (or (null (cdr states))
- (< (offset (caar states)) (offset low-mark)))
- do (pop states))
- (setf (offset mark) (offset (caar states)))
- (loop until (end-of-buffer-p mark)
- do (let ((token (lex lexer)))
- (push (cons (clone-mark mark)
- (advance-parse parser (list token) (cdar states)))
- states)))))
- (print (find 'html (gethash (initial-state parser) (parse-trees (cdar states)))
- :key #'type-of)
- *query-io*)
- (finish-output *query-io*))))
-
-(defgeneric forward-to-error (point syntax))
-(defgeneric backward-to-error (point syntax))
-
-(defun find-bad-parse-tree (state)
- (maphash (lambda (key parse-trees)
- (declare (ignore key))
- (let ((parse-tree (find-if (lambda (parse-tree)
- (plusp (badness parse-tree)))
- parse-trees)))
- (when parse-tree
- (return-from find-bad-parse-tree parse-tree))))
- (parse-trees state)))
-
-(defgeneric empty-state-p (state))
-
-(defmethod empty-state-p (state)
- (maphash (lambda (key val)
- (declare (ignore key))
- (loop for parse-tree in val
- do (return-from empty-state-p nil)))
- (parse-trees state))
- (maphash (lambda (key val)
- (declare (ignore key))
- (loop for parse-tree in val
- do (return-from empty-state-p nil)))
- (incomplete-items state)))
-
-(defmethod backward-to-error (point (syntax html-syntax))
- (let ((states (slot-value syntax 'states)))
- ;; find the last state before point
- (loop until (or (null states)
- (mark< (caar states) point))
- do (pop states))
- (when (null states)
- (return-from backward-to-error "no more errors"))
- (when (empty-state-p (cdar states))
- (loop for ((m1 . s1) (m2 . s2)) on states
- until (not (empty-state-p s2))
- finally (setf (offset point) (offset m1)))
- (return-from backward-to-error "no valid parse from this point"))
- (loop for (mark . state) in states
- for tree = (find-bad-parse-tree state)
- when tree
- do (setf (offset point) (offset mark))
- (return (message tree))
- finally (return "no more errors"))))
+ (let ((low-mark (low-mark buffer))
+ (high-mark (high-mark buffer))
+ (scan))
+ (with-slots (tokens guess-pos valid-parse) syntax
+ (when (mark<= low-mark high-mark)
+ ;; go back to a position before low-mark
+ (loop until (or (= guess-pos 1)
+ (mark< (end-offset (element* tokens (1- guess-pos))) low-mark))
+ do (decf guess-pos))
+ ;; go forward to the last position before low-mark
+ (loop with nb-elements = (nb-elements tokens)
+ until (or (= guess-pos nb-elements)
+ (mark>= (end-offset (element* tokens guess-pos)) low-mark))
+ do (incf guess-pos))
+ ;; mark valid parse
+ (setf valid-parse guess-pos)
+ ;; delete entries that must be reparsed
+ (loop until (or (= guess-pos (nb-elements tokens))
+ (mark> (start-mark (element* tokens guess-pos)) high-mark))
+ do (delete* tokens guess-pos))
+ (setf scan (make-instance 'standard-left-sticky-mark
+ :buffer buffer
+ :offset (if (zerop guess-pos)
+ 0
+ (end-offset (element* tokens (1- guess-pos))))))
+ ;; scan
+ (loop with start-mark = nil
+ do (loop until (end-of-buffer-p scan)
+ while (whitespacep (object-after scan))
+ do (forward-object scan))
+ until (if (end-of-buffer-p high-mark)
+ (end-of-buffer-p scan)
+ (mark> scan high-mark))
+ do (setf start-mark (clone-mark scan))
+ (insert* tokens guess-pos (next-token scan))
+ (incf guess-pos))))))
+
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.51 climacs/packages.lisp:1.52
--- climacs/packages.lisp:1.51 Sun Feb 27 19:52:01 2005
+++ climacs/packages.lisp Mon Feb 28 09:51:35 2005
@@ -91,8 +91,7 @@
#:basic-syntax
#:update-syntax #:update-syntax-for-display
#:syntax-line-indentation
- #:beginning-of-paragraph #:end-of-paragraph
- #:forward-to-error #:backward-to-error))
+ #:beginning-of-paragraph #:end-of-paragraph))
(defpackage :climacs-cl-syntax
(:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain :climacs-syntax)
From abakic at common-lisp.net Sun Feb 27 18:52:04 2005
From: abakic at common-lisp.net (Aleksandar Bakic)
Date: Sun, 27 Feb 2005 19:52:04 +0100 (CET)
Subject: [climacs-cvs] CVS update: climacs/base-test.lisp
climacs/buffer-test.lisp climacs/climacs.asd climacs/gui.lisp
climacs/kill-ring.lisp climacs/packages.lisp climacs/pane.lisp
Message-ID: <20050227185204.0ED0F8866E@common-lisp.net>
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv9768
Modified Files:
base-test.lisp buffer-test.lisp climacs.asd gui.lisp
kill-ring.lisp packages.lisp pane.lisp
Log Message:
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.
Date: Sun Feb 27 19:52:01 2005
Author: abakic
Index: climacs/base-test.lisp
diff -u climacs/base-test.lisp:1.11 climacs/base-test.lisp:1.12
--- climacs/base-test.lisp:1.11 Fri Feb 25 21:45:07 2005
+++ climacs/base-test.lisp Sun Feb 27 19:52:00 2005
@@ -10,8 +10,8 @@
(insert-buffer-sequence buffer 0 "climacs
climacs
climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 16)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 16)
(previous-line mark nil 2)
(offset mark)))
0)
@@ -21,8 +21,8 @@
(insert-buffer-sequence buffer 0 "climacs
climacs
climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 19)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 19)
(previous-line mark 2 2)
(offset mark)))
2)
@@ -31,8 +31,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 7)
(previous-line mark)
(offset mark)))
7)
@@ -41,8 +41,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 7)
(previous-line mark 2)
(offset mark)))
2)
@@ -51,8 +51,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 0)
(previous-line mark)
(offset mark)))
0)
@@ -61,8 +61,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 0)
(previous-line mark 2)
(offset mark)))
2)
@@ -71,8 +71,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs2")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 15)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 15)
(previous-line mark)
(offset mark)))
7)
@@ -82,8 +82,8 @@
(insert-buffer-sequence buffer 0 "climacs
climacs
climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 6)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 6)
(next-line mark nil 2)
(offset mark)))
22)
@@ -93,8 +93,8 @@
(insert-buffer-sequence buffer 0 "climacs
climacs
climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 3)
(next-line mark 2 2)
(offset mark)))
18)
@@ -103,8 +103,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 8)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 8)
(next-line mark)
(offset mark)))
8)
@@ -113,8 +113,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 8)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 8)
(next-line mark 2)
(offset mark)))
10)
@@ -123,8 +123,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 15)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 15)
(next-line mark)
(offset mark)))
15)
@@ -133,8 +133,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 15)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 15)
(next-line mark 2)
(offset mark)))
10)
@@ -143,8 +143,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 0)
(next-line mark)
(offset mark)))
8)
@@ -152,8 +152,8 @@
(defmultitest open-line.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 0)
(open-line mark 2)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"
@@ -163,8 +163,8 @@
(defmultitest open-line.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 0)
(open-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"
@@ -173,8 +173,8 @@
(defmultitest open-line.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 7)
(open-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacs
@@ -183,8 +183,8 @@
(defmultitest open-line.test-4
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 7)
(open-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacs
@@ -193,8 +193,8 @@
(defmultitest kill-line.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 0)
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
#() 0)
@@ -202,8 +202,8 @@
(defmultitest kill-line.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 0)
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
#() 0)
@@ -211,8 +211,8 @@
(defmultitest kill-line.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 7)
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacs" 7)
@@ -220,8 +220,8 @@
(defmultitest kill-line.test-4
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 7)
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacs" 7)
@@ -230,8 +230,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%left-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((mark (clone-mark (low-mark buffer) :left)))
+ (setf (offset mark) 7)
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacsclimacs" 7)
@@ -240,34 +240,32 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((mark (make-instance %%right-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((mark (clone-mark (low-mark buffer) :right)))
+ (setf (offset mark) 7)
(kill-line mark)
(values (buffer-sequence buffer 0 (size buffer)) (offset mark))))
"climacsclimacs" 7)
(defmultitest empty-line-p.test-1
(let* ((buffer (make-instance %%buffer))
- (m1 (make-instance %%left-sticky-mark :buffer buffer))
- (m2 (make-instance %%right-sticky-mark :buffer buffer)))
+ (m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
(values (empty-line-p m1) (empty-line-p m2)))
t t)
(defmultitest empty-line-p.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-object buffer 0 #\a)
- (let ((m1 (make-instance %%left-sticky-mark :buffer buffer))
- (m2 (make-instance %%right-sticky-mark :buffer buffer)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
(values (empty-line-p m1) (empty-line-p m2))))
nil nil)
(defmultitest empty-line-p.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-object buffer 0 #\a)
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 1))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 1)))
+ (let ((m1 (clone-mark (high-mark buffer) :left))
+ (m2 (clone-mark (high-mark buffer) :right)))
(values (empty-line-p m1) (empty-line-p m2))))
nil nil)
@@ -275,24 +273,24 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "a
b")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 1))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 1)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 1
+ (offset m2) 1)
(values (empty-line-p m1) (empty-line-p m2))))
nil nil)
(defmultitest line-indentation.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 0))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 0))
- (m3 (make-instance %%left-sticky-mark
- :buffer buffer :offset 10))
- (m4 (make-instance %%right-sticky-mark
- :buffer buffer :offset 10)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right))
+ (m3 (clone-mark (low-mark buffer) :left))
+ (m4 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 0
+ (offset m2) 0
+ (offset m3) 10
+ (offset m4) 10)
(values
(line-indentation m1 8)
(line-indentation m2 8)
@@ -307,14 +305,14 @@
(defmultitest line-indentation.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 0))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 0))
- (m3 (make-instance %%left-sticky-mark
- :buffer buffer :offset 11))
- (m4 (make-instance %%right-sticky-mark
- :buffer buffer :offset 11)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right))
+ (m3 (clone-mark (low-mark buffer) :left))
+ (m4 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 0
+ (offset m2) 0
+ (offset m3) 11
+ (offset m4) 11)
(values
(line-indentation m1 8)
(line-indentation m2 8)
@@ -329,14 +327,14 @@
(defmultitest line-indentation.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 0))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 0))
- (m3 (make-instance %%left-sticky-mark
- :buffer buffer :offset 11))
- (m4 (make-instance %%right-sticky-mark
- :buffer buffer :offset 11)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right))
+ (m3 (clone-mark (low-mark buffer) :left))
+ (m4 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 0
+ (offset m2) 0
+ (offset m3) 11
+ (offset m4) 11)
(values
(line-indentation m1 8)
(line-indentation m2 8)
@@ -380,30 +378,30 @@
climacs
climacs
")
- (let ((m1l (make-instance %%left-sticky-mark
- :buffer buffer :offset 0))
- (m1r (make-instance %%right-sticky-mark
- :buffer buffer :offset 0))
- (m2l (make-instance %%left-sticky-mark
- :buffer buffer :offset 1))
- (m2r (make-instance %%left-sticky-mark
- :buffer buffer :offset 1))
- (m3l (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m3r (make-instance %%right-sticky-mark
- :buffer buffer :offset 3))
- (m4l (make-instance %%left-sticky-mark
- :buffer buffer :offset 8))
- (m4r (make-instance %%right-sticky-mark
- :buffer buffer :offset 8))
- (m5l (make-instance %%left-sticky-mark
- :buffer buffer :offset 15))
- (m5r (make-instance %%right-sticky-mark
- :buffer buffer :offset 15))
- (m6l (make-instance %%left-sticky-mark
- :buffer buffer :offset 16))
- (m6r (make-instance %%right-sticky-mark
- :buffer buffer :offset 16)))
+ (let ((m1l (clone-mark (low-mark buffer) :left))
+ (m1r (clone-mark (low-mark buffer) :right))
+ (m2l (clone-mark (low-mark buffer) :left))
+ (m2r (clone-mark (low-mark buffer) :right))
+ (m3l (clone-mark (low-mark buffer) :left))
+ (m3r (clone-mark (low-mark buffer) :right))
+ (m4l (clone-mark (low-mark buffer) :left))
+ (m4r (clone-mark (low-mark buffer) :right))
+ (m5l (clone-mark (low-mark buffer) :left))
+ (m5r (clone-mark (low-mark buffer) :right))
+ (m6l (clone-mark (low-mark buffer) :left))
+ (m6r (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1l) 0
+ (offset m1r) 0
+ (offset m2l) 1
+ (offset m2r) 1
+ (offset m3l) 3
+ (offset m3r) 3
+ (offset m4l) 8
+ (offset m4r) 8
+ (offset m5l) 15
+ (offset m5r) 15
+ (offset m6l) 16
+ (offset m6r) 16)
(values
(number-of-lines-in-region m1l m1r)
(number-of-lines-in-region m1r m1l)
@@ -429,14 +427,14 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m1l (make-instance %%left-sticky-mark
- :buffer buffer :offset 6))
- (m1r (make-instance %%right-sticky-mark
- :buffer buffer :offset 6))
- (m2l (make-instance %%left-sticky-mark
- :buffer buffer :offset 7))
- (m2r (make-instance %%right-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((m1l (clone-mark (low-mark buffer) :left))
+ (m1r (clone-mark (low-mark buffer) :right))
+ (m2l (clone-mark (low-mark buffer) :left))
+ (m2r (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1l) 6
+ (offset m1r) 6
+ (offset m2l) 7
+ (offset m2r) 7)
(values
(number-of-lines-in-region m1l 10)
(number-of-lines-in-region 10 m1l)
@@ -473,18 +471,18 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs
climacs")
- (let ((m0l (make-instance %%left-sticky-mark
- :buffer buffer :offset 0))
- (m0r (make-instance %%right-sticky-mark
- :buffer buffer :offset 0))
- (m1l (make-instance %%left-sticky-mark
- :buffer buffer :offset 5))
- (m1r (make-instance %%right-sticky-mark
- :buffer buffer :offset 5))
- (m2l (make-instance %%left-sticky-mark
- :buffer buffer :offset 17))
- (m2r (make-instance %%right-sticky-mark
- :buffer buffer :offset 17)))
+ (let ((m0l (clone-mark (low-mark buffer) :left))
+ (m0r (clone-mark (low-mark buffer) :right))
+ (m1l (clone-mark (low-mark buffer) :left))
+ (m1r (clone-mark (low-mark buffer) :right))
+ (m2l (clone-mark (low-mark buffer) :left))
+ (m2r (clone-mark (low-mark buffer) :right)))
+ (setf (offset m0l) 0
+ (offset m0r) 0
+ (offset m1l) 5
+ (offset m1r) 5
+ (offset m2l) 17
+ (offset m2r) 17)
(values
(progn (climacs-base::forward-to-word-boundary m0l) (offset m0l))
(progn (climacs-base::forward-to-word-boundary m0r) (offset m0r))
@@ -498,18 +496,18 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs ")
- (let ((m0l (make-instance %%left-sticky-mark
- :buffer buffer :offset 17))
- (m0r (make-instance %%right-sticky-mark
- :buffer buffer :offset 17))
- (m1l (make-instance %%left-sticky-mark
- :buffer buffer :offset 10))
- (m1r (make-instance %%right-sticky-mark
- :buffer buffer :offset 10))
- (m2l (make-instance %%left-sticky-mark
- :buffer buffer :offset 0))
- (m2r (make-instance %%right-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((m0l (clone-mark (low-mark buffer) :left))
+ (m0r (clone-mark (low-mark buffer) :right))
+ (m1l (clone-mark (low-mark buffer) :left))
+ (m1r (clone-mark (low-mark buffer) :right))
+ (m2l (clone-mark (low-mark buffer) :left))
+ (m2r (clone-mark (low-mark buffer) :right)))
+ (setf (offset m0l) 17
+ (offset m0r) 17
+ (offset m1l) 10
+ (offset m1r) 10
+ (offset m2l) 0
+ (offset m2r) 0)
(values
(progn (climacs-base::backward-to-word-boundary m0l) (offset m0l))
(progn (climacs-base::backward-to-word-boundary m0r) (offset m0r))
@@ -523,18 +521,18 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs
climacs")
- (let ((m0l (make-instance %%left-sticky-mark
- :buffer buffer :offset 0))
- (m0r (make-instance %%right-sticky-mark
- :buffer buffer :offset 0))
- (m1l (make-instance %%left-sticky-mark
- :buffer buffer :offset 5))
- (m1r (make-instance %%right-sticky-mark
- :buffer buffer :offset 15))
- (m2l (make-instance %%left-sticky-mark
- :buffer buffer :offset 17))
- (m2r (make-instance %%right-sticky-mark
- :buffer buffer :offset 17)))
+ (let ((m0l (clone-mark (low-mark buffer) :left))
+ (m0r (clone-mark (low-mark buffer) :right))
+ (m1l (clone-mark (low-mark buffer) :left))
+ (m1r (clone-mark (low-mark buffer) :right))
+ (m2l (clone-mark (low-mark buffer) :left))
+ (m2r (clone-mark (low-mark buffer) :right)))
+ (setf (offset m0l) 0
+ (offset m0r) 0
+ (offset m1l) 5
+ (offset m1r) 15
+ (offset m2l) 17
+ (offset m2r) 17)
(values
(progn (forward-word m0l) (offset m0l))
(progn (forward-word m0r) (offset m0r))
@@ -548,18 +546,18 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs ")
- (let ((m0l (make-instance %%left-sticky-mark
- :buffer buffer :offset 17))
- (m0r (make-instance %%right-sticky-mark
- :buffer buffer :offset 17))
- (m1l (make-instance %%left-sticky-mark
- :buffer buffer :offset 10))
- (m1r (make-instance %%right-sticky-mark
- :buffer buffer :offset 5))
- (m2l (make-instance %%left-sticky-mark
- :buffer buffer :offset 0))
- (m2r (make-instance %%right-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((m0l (clone-mark (low-mark buffer) :left))
+ (m0r (clone-mark (low-mark buffer) :right))
+ (m1l (clone-mark (low-mark buffer) :left))
+ (m1r (clone-mark (low-mark buffer) :right))
+ (m2l (clone-mark (low-mark buffer) :left))
+ (m2r (clone-mark (low-mark buffer) :right)))
+ (setf (offset m0l) 17
+ (offset m0r) 17
+ (offset m1l) 10
+ (offset m1r) 5
+ (offset m2l) 0
+ (offset m2r) 0)
(values
(progn (backward-word m0l) (offset m0l))
(progn (backward-word m0r) (offset m0r))
@@ -572,8 +570,8 @@
(defmultitest delete-word.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 3)
(delete-word m)
(values
(buffer-sequence buffer 0 (size buffer))
@@ -583,8 +581,8 @@
(defmultitest delete-word.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 0)
(delete-word m 2)
(values
(buffer-sequence buffer 0 (size buffer))
@@ -594,8 +592,8 @@
(defmultitest backward-delete-word.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 3)
(backward-delete-word m)
(values
(buffer-sequence buffer 0 (size buffer))
@@ -605,8 +603,8 @@
(defmultitest backward-delete-word.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs climacs ")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 17)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 17)
(backward-delete-word m 2)
(values
(buffer-sequence buffer 0 (size buffer))
@@ -616,12 +614,12 @@
(defmultitest previous-word.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs climacs")
- (let ((m0 (make-instance %%right-sticky-mark
- :buffer buffer :offset 7))
- (m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 8))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 10)))
+ (let ((m0 (clone-mark (low-mark buffer) :right))
+ (m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m0) 7
+ (offset m1) 8
+ (offset m2) 10)
(values
(climacs-base::previous-word m0)
(climacs-base::previous-word m1)
@@ -638,10 +636,10 @@
(defmultitest downcase-region.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 1))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 8)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 1
+ (offset m2) 8)
(downcase-region m2 m1)
(buffer-sequence buffer 0 (size buffer))))
"_cli mac5_")
@@ -649,8 +647,8 @@
(defmultitest downcase-region.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance %%right-sticky-mark
- :buffer buffer :offset 1)))
+ (let ((m1 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 1)
(downcase-region 8 m1)
(buffer-sequence buffer 0 (size buffer))))
"_cli mac5_")
@@ -658,8 +656,8 @@
(defmultitest downcase-region.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 8)))
+ (let ((m1 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m1) 8)
(downcase-region 1 m1)
(buffer-sequence buffer 0 (size buffer))))
"_cli mac5_")
@@ -667,8 +665,8 @@
(defmultitest downcase-word.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "CLI MA CS CLIMACS")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 0)
(downcase-word m 3)
(values
(buffer-sequence buffer 0 (size buffer))
@@ -685,10 +683,10 @@
(defmultitest upcase-region.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 1))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 8)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 1
+ (offset m2) 8)
(upcase-region m2 m1)
(buffer-sequence buffer 0 (size buffer))))
"_CLI MAC5_")
@@ -696,8 +694,8 @@
(defmultitest upcase-region.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance %%right-sticky-mark
- :buffer buffer :offset 1)))
+ (let ((m1 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 1)
(upcase-region 8 m1)
(buffer-sequence buffer 0 (size buffer))))
"_CLI MAC5_")
@@ -705,8 +703,8 @@
(defmultitest upcase-region.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 8)))
+ (let ((m1 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m1) 8)
(upcase-region 1 m1)
(buffer-sequence buffer 0 (size buffer))))
"_CLI MAC5_")
@@ -714,8 +712,8 @@
(defmultitest upcase-word.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "cli ma cs climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 0)
(upcase-word m 3)
(values
(buffer-sequence buffer 0 (size buffer))
@@ -739,10 +737,10 @@
(defmultitest capitalize-region.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 1))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 8)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 1
+ (offset m2) 8)
(capitalize-region m2 m1)
(buffer-sequence buffer 0 (size buffer))))
"_Cli Mac5_")
@@ -750,8 +748,8 @@
(defmultitest capitalize-region.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance %%right-sticky-mark
- :buffer buffer :offset 1)))
+ (let ((m1 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 1)
(capitalize-region 8 m1)
(buffer-sequence buffer 0 (size buffer))))
"_Cli Mac5_")
@@ -759,8 +757,8 @@
(defmultitest capitalize-region.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "_Cli mac5_")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 8)))
+ (let ((m1 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m1) 8)
(capitalize-region 1 m1)
(buffer-sequence buffer 0 (size buffer))))
"_Cli Mac5_")
@@ -768,8 +766,8 @@
(defmultitest capitalize-word.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "cli ma cs climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 0)
(capitalize-word m 3)
(values
(buffer-sequence buffer 0 (size buffer))
@@ -793,10 +791,10 @@
(defmultitest tabify-region.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 3
+ (offset m2) 7)
(tabify-region m2 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
@@ -804,8 +802,8 @@
(defmultitest tabify-region.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance %%right-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m1 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 3)
(tabify-region 7 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
@@ -813,8 +811,8 @@
(defmultitest tabify-region.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((m1 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m1) 7)
(tabify-region 3 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
@@ -836,10 +834,10 @@
(defmultitest untabify-region.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 3
+ (offset m2) 5)
(untabify-region m2 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
@@ -847,8 +845,8 @@
(defmultitest untabify-region.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance %%right-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m1 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 3)
(untabify-region 5 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
@@ -856,8 +854,8 @@
(defmultitest untabify-region.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "clim acs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m1 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m1) 5)
(untabify-region 3 m1 4)
(buffer-sequence buffer 0 (size buffer))))
"clim acs")
@@ -865,8 +863,8 @@
(defmultitest indent-line.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 3)
(indent-line m 4 nil)
(values
(offset m)
@@ -876,8 +874,8 @@
(defmultitest indent-line.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 4)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 4)
(indent-line m 5 4)
(values
(offset m)
@@ -887,8 +885,8 @@
(defmultitest indent-line.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 3)
(indent-line m 5 4)
(values
(offset m)
@@ -899,8 +897,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "
climacs ")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 3)
(delete-indentation m)
(values
(offset m)
@@ -911,8 +909,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "
climacs ")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 7)
(delete-indentation m)
(values
(offset m)
@@ -922,8 +920,8 @@
(defmultitest delete-indentation.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 " climacs ")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 7)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 7)
(delete-indentation m)
(values
(offset m)
@@ -934,8 +932,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs ")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 12)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 12)
(delete-indentation m)
(values
(offset m)
@@ -947,8 +945,8 @@
(insert-buffer-sequence buffer 0 "
climacs ")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 12)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 12)
(delete-indentation m)
(values
(offset m)
@@ -959,8 +957,8 @@
(defmultitest fill-line.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs climacs climacs climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 25)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 25)
(fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8)
(values
(offset m)
@@ -972,8 +970,8 @@
(defmultitest fill-line.test-1a
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs climacs climacs climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 25)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 25)
(fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 nil)
(values
(offset m)
@@ -985,8 +983,8 @@
(defmultitest fill-line.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs climacs climacs climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 25)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 25)
(fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8)
(values
(offset m)
@@ -998,8 +996,8 @@
(defmultitest fill-line.test-2a
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs climacs climacs climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 25)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 25)
(fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 nil)
(values
(offset m)
@@ -1011,8 +1009,8 @@
(defmultitest fill-line.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "c l i m a c s")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 1)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 1)
(fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8)
(values
(offset m)
@@ -1022,8 +1020,8 @@
(defmultitest fill-line.test-3a
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "c l i m a c s")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 1)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 1)
(fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8 nil)
(values
(offset m)
@@ -1057,10 +1055,10 @@
(defmultitest looking-at.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 1))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 1
+ (offset m2) 3)
(values
(looking-at m1 "lima")
(looking-at m2 "mac")
@@ -1108,8 +1106,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "
climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 0)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 0)
(search-forward m "Mac" :test #'char-equal)
(offset m)))
7)
@@ -1117,8 +1115,8 @@
(defmultitest search-forward.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 3)
(search-forward m "Mac" :test #'char-equal)
(offset m)))
6)
@@ -1126,8 +1124,8 @@
(defmultitest search-forward.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 3)
(search-forward m "klimaks")
(offset m)))
3)
@@ -1136,8 +1134,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 8)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 8)
(search-backward m "Mac" :test #'char-equal)
(offset m)))
3)
@@ -1145,8 +1143,8 @@
(defmultitest search-backward.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 6)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 6)
(search-backward m "Mac" :test #'char-equal)
(offset m)))
3)
@@ -1154,8 +1152,8 @@
(defmultitest search-backward.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 3)
(search-backward m "klimaks")
(offset m)))
3)
@@ -1182,4 +1180,4 @@
(climacs-base::buffer-search-word-backward buffer 4 "clim")
(climacs-base::buffer-search-word-backward buffer 8 "macs")
(climacs-base::buffer-search-word-backward buffer 8 "")))
- 0 nil nil nil 8)
+ 0 nil nil nil 8)
\ No newline at end of file
Index: climacs/buffer-test.lisp
diff -u climacs/buffer-test.lisp:1.17 climacs/buffer-test.lisp:1.18
--- climacs/buffer-test.lisp:1.17 Fri Feb 25 21:45:07 2005
+++ climacs/buffer-test.lisp Sun Feb 27 19:52:01 2005
@@ -8,6 +8,9 @@
(cl:in-package :climacs-tests)
+(defclass delegating-standard-buffer (delegating-buffer) ()
+ (:default-initargs :implementation (make-instance 'standard-buffer)))
+
(defmacro defmultitest (name form &rest results)
(let ((name-string (symbol-name name)))
(flet ((%deftest-wrapper (bc lsm rsm tn f rs)
@@ -26,6 +29,13 @@
form
results)
,(%deftest-wrapper
+ ''delegating-standard-buffer
+ ''standard-left-sticky-mark
+ ''standard-right-sticky-mark
+ (intern (concatenate 'string "DELEGATING-STANDARD-BUFFER-" name-string))
+ form
+ results)
+ ,(%deftest-wrapper
''binseq-buffer
''persistent-left-sticky-mark
''persistent-right-sticky-mark
@@ -42,13 +52,12 @@
(defmultitest buffer-make-instance.test-1
(let* ((buffer (make-instance %%buffer))
- (low (slot-value buffer 'low-mark))
- (high (slot-value buffer 'high-mark)))
+ (low (low-mark buffer))
+ (high (low-mark buffer)))
(and (= (offset low) 0)
(= (offset high) 0)
(null (modified-p buffer))
- (eq (buffer low) buffer)
- (eq (buffer high) buffer)))
+ (eq (buffer low) (buffer high))))
t)
(defmultitest mark-make-instance.test-1
@@ -73,8 +82,8 @@
((null x) nil)
(t (when (eq x y) y)))))
(let* ((buffer (make-instance %%buffer))
- (low (slot-value buffer 'low-mark))
- (high (slot-value buffer 'high-mark))
+ (low (low-mark buffer))
+ (high (high-mark buffer))
(low2 (clone-mark low))
(high2 (clone-mark high))
(low3 (clone-mark high :left))
@@ -241,11 +250,10 @@
(defmultitest insert-object.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 3)
(insert-object m #\X)
(and (= (size buffer) 8)
- (eq (buffer m) buffer)
(= (offset m) 3)
(buffer-sequence buffer 0 8))))
"cliXmacs")
@@ -253,11 +261,10 @@
(defmultitest insert-object.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 3)))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 3)
(insert-object m #\X)
(and (= (size buffer) 8)
- (eq (buffer m) buffer)
(= (offset m) 4)
(buffer-sequence buffer 0 8))))
"cliXmacs")
@@ -265,13 +272,13 @@
(defmultitest insert-sequence.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%left-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 3
+ (offset m2) 5)
(insert-sequence m "ClimacS")
(and (= (size buffer) 14)
- (eq (buffer m) buffer)
+ (eq (buffer m) (buffer m2))
(= (offset m) 3)
(= (offset m2) 12)
(buffer-sequence buffer 0 14))))
@@ -280,13 +287,13 @@
(defmultitest insert-sequence.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m (clone-mark (low-mark buffer) :right))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 3
+ (offset m2) 5)
(insert-sequence m "ClimacS")
(and (= (size buffer) 14)
- (eq (buffer m) buffer)
+ (eq (buffer m) (buffer m2))
(= (offset m) 10)
(= (offset m2) 12)
(buffer-sequence buffer 0 14))))
@@ -295,14 +302,13 @@
(defmultitest delete-range.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%left-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 3
+ (offset m2) 5)
(delete-range m 2)
(and (= (size buffer) 5)
- (eq (buffer m) buffer)
- (eq (buffer m2) buffer)
+ (eq (buffer m) (buffer m2))
(= (offset m) 3)
(= (offset m2) 3)
(buffer-sequence buffer 0 5))))
@@ -311,14 +317,13 @@
(defmultitest delete-range.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m (clone-mark (low-mark buffer) :right))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 3
+ (offset m2) 5)
(delete-range m -2)
(and (= (size buffer) 5)
- (eq (buffer m) buffer)
- (eq (buffer m2) buffer)
+ (eq (buffer m) (buffer m2))
(= (offset m) 1)
(= (offset m2) 3)
(buffer-sequence buffer 0 5))))
@@ -327,14 +332,13 @@
(defmultitest delete-region.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%left-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 3
+ (offset m2) 5)
(delete-region m m2)
(and (= (size buffer) 5)
- (eq (buffer m) buffer)
- (eq (buffer m2) buffer)
+ (eq (buffer m) (buffer m2))
(= (offset m) 3)
(= (offset m2) 3)
(buffer-sequence buffer 0 5))))
@@ -343,14 +347,13 @@
(defmultitest delete-region.test-2
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m (clone-mark (low-mark buffer) :right))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 3
+ (offset m2) 5)
(delete-region m m2)
(and (= (size buffer) 5)
- (eq (buffer m) buffer)
- (eq (buffer m2) buffer)
+ (eq (buffer m) (buffer m2))
(= (offset m) 3)
(= (offset m2) 3)
(buffer-sequence buffer 0 5))))
@@ -359,14 +362,13 @@
(defmultitest delete-region.test-3
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%left-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 3
+ (offset m2) 5)
(delete-region m2 m)
(and (= (size buffer) 5)
- (eq (buffer m) buffer)
- (eq (buffer m2) buffer)
+ (eq (buffer m) (buffer m2))
(= (offset m) 3)
(= (offset m2) 3)
(buffer-sequence buffer 0 5))))
@@ -375,14 +377,13 @@
(defmultitest delete-region.test-4
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m (clone-mark (low-mark buffer) :right))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) 3
+ (offset m2) 5)
(delete-region m2 m)
(and (= (size buffer) 5)
- (eq (buffer m) buffer)
- (eq (buffer m2) buffer)
+ (eq (buffer m) (buffer m2))
(= (offset m) 3)
(= (offset m2) 3)
(buffer-sequence buffer 0 5))))
@@ -394,10 +395,10 @@
(buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m (make-instance %%right-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer2 :offset 5)))
+ (let ((m (clone-mark (low-mark buffer) :right))
+ (m2 (clone-mark (low-mark buffer2) :right)))
+ (setf (offset m) 3
+ (offset m2) 5)
(delete-region m2 m)))
(error (c)
(declare (ignore c))
@@ -407,15 +408,14 @@
(defmultitest delete-region.test-6
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%left-sticky-mark
- :buffer buffer :offset 5)))
+ (let ((m (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 3
+ (offset m2) 5)
(delete-region m 5)
(delete-region 1 m2)
(and (= (size buffer) 3)
- (eq (buffer m) buffer)
- (eq (buffer m2) buffer)
+ (eq (buffer m) (buffer m2))
(= (offset m) 1)
(= (offset m2) 1)
(buffer-sequence buffer 0 3))))
@@ -437,19 +437,18 @@
(defmultitest mark-relations.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m0 (make-instance %%right-sticky-mark
- :buffer buffer :offset 0))
- (m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m1a (make-instance %%right-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 4))
- (m2a (make-instance %%left-sticky-mark
- :buffer buffer :offset 5))
- (m3 (make-instance %%left-sticky-mark
- :buffer buffer :offset 7)))
- (setf (offset m2) 5)
+ (let ((m0 (clone-mark (low-mark buffer) :right))
+ (m1 (clone-mark (low-mark buffer) :left))
+ (m1a (clone-mark (low-mark buffer) :right))
+ (m2 (clone-mark (low-mark buffer) :right))
+ (m2a (clone-mark (low-mark buffer) :left))
+ (m3 (clone-mark (low-mark buffer) :left)))
+ (setf (offset m0) 0
+ (offset m1) 3
+ (offset m1a) 3
+ (offset m2) 5
+ (offset m2a) 5
+ (offset m3) 7)
(and (mark< m0 m1) (not (mark> m0 m1)) (not (mark>= m0 m1))
(mark< m0 m2) (not (mark> m0 m2)) (not (mark>= m0 m2))
(mark< m0 m3) (not (mark> m0 m3)) (not (mark>= m0 m3))
@@ -479,8 +478,7 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 4)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
(setf (offset m) -1)))
(climacs-buffer::motion-before-beginning (c)
(= (climacs-buffer::condition-offset c) -1)))
@@ -490,8 +488,7 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 4)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
(setf (offset m) 8)))
(climacs-buffer::motion-after-end (c)
(= (climacs-buffer::condition-offset c) 8)))
@@ -500,9 +497,10 @@
(defmultitest backward-object.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let* ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 4))
+ (let* ((m1 (clone-mark (low-mark buffer) :left))
(m2 (clone-mark m1)))
+ (setf (offset m1) 4
+ (offset m2) 4)
(backward-object m1 2)
(region-to-sequence m1 m2)))
"im")
@@ -511,9 +509,10 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let* ((m1 (make-instance %%right-sticky-mark
- :buffer buffer :offset 2))
+ (let* ((m1 (clone-mark (low-mark buffer) :right))
(m2 (clone-mark m1)))
+ (setf (offset m1) 2
+ (offset m2) 2)
(backward-object m1 3)
(region-to-sequence m1 m2)))
(climacs-buffer::motion-before-beginning (c)
@@ -523,9 +522,10 @@
(defmultitest forward-object.test-1
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let* ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 4))
+ (let* ((m1 (clone-mark (low-mark buffer) :left))
(m2 (clone-mark m1)))
+ (setf (offset m1) 4
+ (offset m2) 4)
(forward-object m1 2)
(region-to-sequence m1 m2)))
"ac")
@@ -534,9 +534,10 @@
(handler-case
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
- (let* ((m1 (make-instance %%right-sticky-mark
- :buffer buffer :offset 6))
+ (let* ((m1 (clone-mark (low-mark buffer) :right))
(m2 (clone-mark m1)))
+ (setf (offset m1) 6
+ (offset m2) 6)
(forward-object m1 3)
(region-to-sequence m1 m2)))
(climacs-buffer::motion-after-end (c)
@@ -572,10 +573,8 @@
(buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 4))
- (m2 (make-instance %%left-sticky-mark
- :buffer buffer2 :offset 4)))
+ (let ((m1 (clone-mark (low-mark buffer)))
+ (m2 (clone-mark (low-mark buffer2))))
(mark< m1 m2)))
(error (c)
(declare (ignore c))
@@ -588,10 +587,8 @@
(buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 4))
- (m2 (make-instance %%left-sticky-mark
- :buffer buffer2 :offset 4)))
+ (let ((m1 (clone-mark (low-mark buffer)))
+ (m2 (clone-mark (low-mark buffer2))))
(mark> m1 m2)))
(error (c)
(declare (ignore c))
@@ -604,10 +601,8 @@
(buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 4))
- (m2 (make-instance %%left-sticky-mark
- :buffer buffer2 :offset 4)))
+ (let ((m1 (clone-mark (low-mark buffer)))
+ (m2 (clone-mark (low-mark buffer2))))
(mark<= m1 m2)))
(error (c)
(declare (ignore c))
@@ -620,10 +615,8 @@
(buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 4))
- (m2 (make-instance %%left-sticky-mark
- :buffer buffer2 :offset 4)))
+ (let ((m1 (clone-mark (low-mark buffer)))
+ (m2 (clone-mark (low-mark buffer2))))
(mark>= m1 m2)))
(error (c)
(declare (ignore c))
@@ -636,10 +629,8 @@
(buffer2 (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs")
(insert-buffer-sequence buffer2 0 "climacs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 4))
- (m2 (make-instance %%left-sticky-mark
- :buffer buffer2 :offset 4)))
+ (let ((m1 (clone-mark (low-mark buffer)))
+ (m2 (clone-mark (low-mark buffer2))))
(mark= m1 m2)))
(error (c)
(declare (ignore c))
@@ -650,10 +641,10 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 11)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 3
+ (offset m2) 11)
(= 0 (line-number m1) (1- (line-number m2)))))
t)
@@ -678,10 +669,10 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m1 (make-instance %%left-sticky-mark
- :buffer buffer :offset 3))
- (m2 (make-instance %%right-sticky-mark
- :buffer buffer :offset 11)))
+ (let ((m1 (clone-mark (low-mark buffer) :left))
+ (m2 (clone-mark (low-mark buffer) :right)))
+ (setf (offset m1) 3
+ (offset m2) 11)
(= 3 (column-number m1) (column-number m2))))
t)
@@ -689,8 +680,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 11)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 11)
(and (not (beginning-of-line-p m))
(progn (beginning-of-line m) (beginning-of-line-p m)))))
t)
@@ -699,8 +690,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 11)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 11)
(and (not (end-of-line-p m))
(progn (end-of-line m) (end-of-line-p m)))))
t)
@@ -709,8 +700,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 11)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 11)
(and (not (beginning-of-buffer-p m))
(progn (beginning-of-buffer m) (beginning-of-buffer-p m)))))
t)
@@ -719,8 +710,8 @@
(let ((buffer (make-instance %%buffer)))
(insert-buffer-sequence buffer 0 "climacs
climacs")
- (let ((m (make-instance %%left-sticky-mark
- :buffer buffer :offset 11)))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) 11)
(and (not (end-of-buffer-p m))
(progn (end-of-buffer m) (end-of-buffer-p m)))))
t)
Index: climacs/climacs.asd
diff -u climacs/climacs.asd:1.19 climacs/climacs.asd:1.20
--- climacs/climacs.asd:1.19 Thu Feb 10 01:27:07 2005
+++ climacs/climacs.asd Sun Feb 27 19:52:01 2005
@@ -65,6 +65,7 @@
"cl-syntax"
"kill-ring"
"undo"
+ "delegating-buffer"
"pane"
"gui"
;;---- optional ----
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.124 climacs/gui.lisp:1.125
--- climacs/gui.lisp:1.124 Thu Feb 24 09:30:28 2005
+++ climacs/gui.lisp Sun Feb 27 19:52:01 2005
@@ -346,11 +346,6 @@
, at 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)
`(, at 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 @@
;; 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 ()
Index: climacs/kill-ring.lisp
diff -u climacs/kill-ring.lisp:1.5 climacs/kill-ring.lisp:1.6
--- climacs/kill-ring.lisp:1.5 Fri Jan 7 19:58:08 2005
+++ climacs/kill-ring.lisp Sun Feb 27 19:52:01 2005
@@ -87,7 +87,7 @@
(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)
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.50 climacs/packages.lisp:1.51
--- climacs/packages.lisp:1.50 Wed Feb 23 19:15:32 2005
+++ climacs/packages.lisp Sun Feb 27 19:52:01 2005
@@ -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)
Index: climacs/pane.lisp
diff -u climacs/pane.lisp:1.18 climacs/pane.lisp:1.19
--- climacs/pane.lisp:1.18 Sat Feb 5 07:49:53 2005
+++ climacs/pane.lisp Sun Feb 27 19:52:01 2005
@@ -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))