Commit 7a331fc6 authored by strandh's avatar strandh
Browse files

Docstrings from Elliott Johnson.

the find-file command now stores the filename in the buffer for
later use by save-buffer.
parent eb084a44
;;; -*- Mode: Lisp; Package: CLIMACS-ABBREV -*-
;;; (c) copyright 2004 by
;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
;;; Robert Strandh (strandh@labri.fr)
;;; (c) copyright 2004 by
;;; Elliott Johnson (ejohnson@fasl.info)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
......@@ -33,25 +35,32 @@
(in-package :climacs-abbrev)
;;; the protocol class for all abbrev expanders.
(defclass abbrev-expander () ())
(defclass abbrev-expander () ()
(:documentation "The protocol class for all abbreviation expanders"))
(defgeneric expand-abbrev (word abbrev-expander)
(:documentation "Given a word and an abbrev expander,
return the expanded abbrev, or NIL if no expansion exists"))
(:documentation "Given a word and an abbrev expander, return the
expanded abbrev, or NIL if no expansion exists"))
(defclass dictionary-abbrev-expander (abbrev-expander)
((dictionary :initform '() :accessor dictionary)))
((dictionary :initform '() :accessor dictionary
:documentation "A dictionary of abbreviations."))
(:documentation "A protocol class specified for dictionary abbreviation expanders."))
(defgeneric add-abbrev (word expansion dictionary-abbrev-expander)
(:documentation "Add an abbrev expansion to a dictionary abbrev expander"))
(defun string-upper-case-p (string)
"A predicate testing if each character of a string is uppercase."
(loop for c across string
unless (upper-case-p c)
do (return nil)
finally (return t)))
(defmethod expand-abbrev (word (expander dictionary-abbrev-expander))
"Expands an abbrevated word by attempting to assocate it with a member of
an abbreviation dictionary. If such an association is found, an uppercase,
expanded version of the abbrevation is returned."
(let ((expansion (cdr (assoc word (dictionary expander) :test #'string-equal))))
(when expansion
(cond ((string-upper-case-p word) (string-upcase expansion))
......@@ -59,6 +68,7 @@ return the expanded abbrev, or NIL if no expansion exists"))
(t expansion)))))
(defun possibly-expand-abbrev (mark)
"Replaces a bit of abbreviated text with its fully expanded counterpart."
(let ((buffer (buffer mark)))
(when (and (not (beginning-of-buffer-p mark))
(constituentp (object-before mark)))
......@@ -75,4 +85,6 @@ return the expanded abbrev, or NIL if no expansion exists"))
(defclass abbrev-mixin ()
((expander :initform (make-instance 'dictionary-abbrev-expander)
:initarg :expander :accessor abbrev-expander)))
:initarg :expander :accessor abbrev-expander))
(:documentation "A mixin class which adds abbreviation expansion facilities to
a buffer via the accessor \"abbrev-expander\""))
;;; -*- Mode: Lisp; Package: CLIMACS-BASE -*-
;;; (c) copyright 2004 by
;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
;;; Robert Strandh (strandh@labri.fr)
;;; (c) copyright 2004 by
;;; Elliott Johnson (ejohnson@fasl.info)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
......@@ -27,6 +29,7 @@
(in-package :climacs-base)
(defun previous-line (mark)
"Move a mark up one line conserving horizontal position."
(let ((column (column-number mark)))
(beginning-of-line mark)
(if (beginning-of-buffer-p mark)
......@@ -37,6 +40,7 @@
(incf (offset mark) column))))))
(defun next-line (mark)
"Move a mark down one line conserving horizontal position."
(let ((column (column-number mark)))
(end-of-line mark)
(if (end-of-buffer-p mark)
......@@ -49,10 +53,12 @@
(incf (offset mark) column))))))
(defun open-line (mark)
"Create a new line in a buffer."
(insert-object mark #\Newline)
(decf (offset mark)))
(defun kill-line (mark)
"Remove a line from a buffer."
(if (end-of-line-p mark)
(unless (end-of-buffer-p mark)
(delete-range mark))
......@@ -61,11 +67,13 @@
(delete-region offset mark))))
(defun constituentp (obj)
"A predicate to ensure that an object is a constituent character."
(and (characterp obj)
#+sbcl (sb-impl::constituentp obj)
#-sbcl (alphanumericp obj)))
(defun forward-word (mark)
"Forward the mark to the next word."
(loop until (end-of-buffer-p mark)
until (constituentp (object-after mark))
do (incf (offset mark)))
......@@ -74,6 +82,7 @@
do (incf (offset mark))))
(defun backward-word (mark)
"Shuttle the mark to the start of the previous word."
(loop until (beginning-of-buffer-p mark)
until (constituentp (object-before mark))
do (decf (offset mark)))
......
;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*-
;;; (c) copyright 2004 by
;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
;;; Robert Strandh (strandh@labri.fr)
;;; (c) copyright 2004 by
;;; Elliott Johnson (ejohnson@fasl.info)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
......@@ -26,25 +28,44 @@
(in-package :climacs-buffer)
(defclass buffer () ())
(defclass buffer () ()
(:documentation "A base class for all buffers. A buffer conceptually contains a
large array of arbitrary objects. Lines of objects are separated by
newline characters. The last object of the buffer is not
necessarily a newline character."))
(defclass standard-buffer (buffer)
((contents :initform (make-instance 'standard-cursorchain))))
((contents :initform (make-instance 'standard-cursorchain)))
(:documentation "The Climacs standard buffer [an instantable subclass of buffer]."))
(defgeneric buffer (mark)
(:documentation "Return the buffer that the mark is positioned in."))
(defgeneric buffer (mark))
(defclass mark () ()
(:documentation "A base class for all marks."))
(defclass mark () ())
(defclass left-sticky-mark (mark) ()
(:documentation "A subclass of mark. A mark of this type will \"stick\" to the left of
an object, i.e. when an object is inserted at this mark, the mark will
be positioned to the left of the object"))
(defclass left-sticky-mark (mark) ())
(defclass right-sticky-mark (mark) ()
(:documentation "A subclass of mark. A mark of this type will \"stick\" to the right of
an object, i.e. when an object is inserted at this mark, the mark will
be positioned to the right of the object."))
(defclass right-sticky-mark (mark) ())
(defgeneric offset (mark)
(:documentation "Return the offset of the mark into the buffer."))
(defgeneric offset (mark))
(defgeneric (setf offset) (new-offset mark))
(defgeneric (setf offset) (new-offset mark)
(:documentation "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."))
(defclass mark-mixin ()
((buffer :initarg :buffer :reader buffer)
(cursor :reader cursor)))
(cursor :reader cursor))
(:documentation "A mixin class used in the initialization of a mark."))
(defmethod offset (mark)
(cursor-pos (cursor mark)))
......@@ -54,11 +75,16 @@
(make-condition 'no-such-offset :offset new-offset))
(setf (cursor-pos (cursor mark)) new-offset))
(defclass standard-left-sticky-mark (left-sticky-mark mark-mixin) ())
(defclass standard-left-sticky-mark (left-sticky-mark mark-mixin) ()
(:documentation "A left-sticky-mark subclass suitable for use in a standard-buffer"))
(defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) ()
(:documentation "A right-sticky-mark subclass suitable for use in a standard-buffer"))
(defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) ())
(defmethod initialize-instance :after ((mark left-sticky-mark) &rest args &key (offset 0))
"Associates a created mark with the buffer it was created for."
(declare (ignore args))
(setf (slot-value mark 'cursor)
(make-instance 'left-sticky-flexicursor
......@@ -66,13 +92,17 @@
:position offset)))
(defmethod initialize-instance :after ((mark right-sticky-mark) &rest args &key (offset 0))
"Associates a created mark with the buffer it was created for."
(declare (ignore args))
(setf (slot-value mark 'cursor)
(make-instance 'right-sticky-flexicursor
:chain (slot-value (buffer mark) 'contents)
:position offset)))
(defgeneric clone-mark (mark &optional type))
(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."))
(defmethod clone-mark ((mark standard-left-sticky-mark) &optional type)
(unless type
......@@ -87,20 +117,29 @@
(define-condition no-such-offset (simple-error)
((offset :reader offset :initarg :offset))
(:report (lambda (condition stream)
(format stream "No such offset: ~a" (offset condition)))))
(format stream "No such offset: ~a" (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))
(defgeneric size (buffer)
(:documentation "Return the number of objects in the buffer."))
(defmethod size ((buffer standard-buffer))
(nb-elements (slot-value buffer 'contents)))
(defgeneric number-of-lines (buffer))
(defgeneric number-of-lines (buffer)
(:documentation "Return the number of lines of the buffer, or really the number of
newline characters."))
(defmethod number-of-lines ((buffer standard-buffer))
(loop for offset from 0 below (size buffer)
count (eql (buffer-object buffer offset) #\Newline)))
(defgeneric mark< (mark1 mark2))
(defgeneric mark< (mark1 mark2)
(:documentation "Return t if the offset of mark1 is strictly less than that of mark2.
An error is signaled if the two marks are not positioned in the same
buffer. It is acceptable to pass an offset in place of one of the
marks"))
(defmethod mark< ((mark1 mark-mixin) (mark2 mark-mixin))
(assert (eq (buffer mark1) (buffer mark2)))
......@@ -112,7 +151,11 @@
(defmethod mark< ((mark1 integer) (mark2 mark-mixin))
(< mark1 (offset mark2)))
(defgeneric mark<= (mark1 mark2))
(defgeneric mark<= (mark1 mark2)
(:documentation "Return t if the offset of mark1 is less than or equal to that of
mark2. An error is signaled if the two marks are not positioned in
the same buffer. It is acceptable to pass an offset in place of one
of the marks."))
(defmethod mark<= ((mark1 mark-mixin) (mark2 mark-mixin))
(assert (eq (buffer mark1) (buffer mark2)))
......@@ -124,7 +167,10 @@
(defmethod mark<= ((mark1 integer) (mark2 mark-mixin))
(<= mark1 (offset mark2)))
(defgeneric mark= (mark1 mark2))
(defgeneric mark= (mark1 mark2)
(:documentation "Return t if the offset of mark1 is equal to that of mark2. An error
is signaled if the two marks are not positioned in the same buffer.
It is acceptable to pass an offset in place of one of the marks."))
(defmethod mark= ((mark1 mark-mixin) (mark2 mark-mixin))
(assert (eq (buffer mark1) (buffer mark2)))
......@@ -136,7 +182,11 @@
(defmethod mark= ((mark1 integer) (mark2 mark-mixin))
(= mark1 (offset mark2)))
(defgeneric mark> (mark1 mark2))
(defgeneric mark> (mark1 mark2)
(:documentation "Return t if the offset of mark1 is strictly greater than that of
mark2. An error is signaled if the two marks are not positioned in
the same buffer. It is acceptable to pass an offset in place of one
of the marks."))
(defmethod mark> ((mark1 mark-mixin) (mark2 mark-mixin))
(assert (eq (buffer mark1) (buffer mark2)))
......@@ -148,7 +198,11 @@
(defmethod mark> ((mark1 integer) (mark2 mark-mixin))
(> mark1 (offset mark2)))
(defgeneric mark>= (mark1 mark2))
(defgeneric mark>= (mark1 mark2)
(:documentation "Return t if the offset of mark1 is greater than or equal to that of
mark2. An error is signaled if the two marks are not positioned in
the same buffer. It is acceptable to pass an offset in place of one
of the marks."))
(defmethod mark>= ((mark1 mark-mixin) (mark2 mark-mixin))
(assert (eq (buffer mark1) (buffer mark2)))
......@@ -160,53 +214,73 @@
(defmethod mark>= ((mark1 integer) (mark2 mark-mixin))
(>= mark1 (offset mark2)))
(defgeneric beginning-of-buffer (mark))
(defgeneric beginning-of-buffer (mark)
(:documentation "Move the mark to the beginning of the buffer. This is equivalent to
(setf (offset mark) 0)"))
(defmethod beginning-of-buffer ((mark mark-mixin))
(setf (offset mark) 0))
(defgeneric end-of-buffer (mark))
(defgeneric end-of-buffer (mark)
(:documentation "Move the mark to the end of the buffer."))
(defmethod end-of-buffer ((mark mark-mixin))
(setf (offset mark) (size (buffer mark))))
(defgeneric beginning-of-buffer-p (mark))
(defgeneric beginning-of-buffer-p (mark)
(:documentation "Return t if the mark is at the beginning of the buffer, nil
otherwise."))
(defmethod beginning-of-buffer-p ((mark mark-mixin))
(zerop (offset mark)))
(defgeneric end-of-buffer-p (mark))
(defgeneric end-of-buffer-p (mark)
(:documentation "Return t if the mark is at the end of the buffer, nil otherwise."))
(defmethod end-of-buffer-p ((mark mark-mixin))
(= (offset mark) (size (buffer mark))))
(defgeneric beginning-of-line (mark))
(defgeneric beginning-of-line (mark)
(:documentation "Move the mark to the beginning of the line. The mark will be
positioned either immediately after the closest preceding newline
character, or at the beginning of the buffer if no preceding newline
character exists."))
(defmethod beginning-of-line ((mark mark-mixin))
(loop until (or (beginning-of-buffer-p mark)
(eql (object-before mark) #\Newline))
do (decf (offset mark))))
(defgeneric end-of-line (mark))
(defgeneric end-of-line (mark)
(:documentation "Move the mark to the end of the line. The mark will be positioned
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))
(loop until (or (end-of-buffer-p mark)
(eql (object-after mark) #\Newline))
do (incf (offset mark))))
(defgeneric beginning-of-line-p (mark))
(defgeneric beginning-of-line-p (mark)
(:documentation "Return t if the mark is at the beginning of the line (i.e., if the
character preceding the mark is a newline character or if the mark is
at the beginning of the buffer), nil otherwise."))
(defmethod beginning-of-line-p ((mark mark-mixin))
(or (beginning-of-buffer-p mark)
(eql (object-before mark) #\Newline)))
(defgeneric end-of-line-p (mark))
(defgeneric end-of-line-p (mark)
(:documentation "Return t if the mark is at the end of the line (i.e., if the character
following the mark is a newline character, or if the mark is at the
end of the buffer), nil otherwise."))
(defmethod end-of-line-p ((mark mark-mixin))
(or (end-of-buffer-p mark)
(eql (object-after mark) #\Newline)))
(defgeneric line-number (mark))
(defgeneric line-number (mark)
(:documentation "Return the line number of the mark. Lines are numbered from zero."))
(defmethod line-number ((mark mark-mixin))
(loop with buffer = (buffer mark)
......@@ -214,7 +288,11 @@
for offset from 0 below end
count (eql (buffer-object buffer offset) #\Newline)))
(defgeneric column-number (mark))
(defgeneric column-number (mark)
(:documentation "Return the column number of the mark. The column number of a mark is
the number of objects between it and the preceding newline, or
between it and the beginning of the buffer if the mark is on the
first line of the buffer."))
(defmethod column-number ((mark mark-mixin))
(loop for offset downfrom (offset mark)
......@@ -222,31 +300,45 @@
until (eql (buffer-object (buffer mark) (1- offset)) #\Newline)
count t))
(defgeneric insert-buffer-object (buffer offset object))
(defgeneric insert-buffer-object (buffer offset object)
(:documentation "Insert the object at the offset in the buffer. Any left-sticky marks
that are placed at the offset will remain positioned before the
inserted object. Any right-sticky marks that are placed at the
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))
(insert* (slot-value buffer 'contents) offset object))
(defgeneric insert-buffer-sequence (buffer offset sequence))
(defgeneric insert-buffer-sequence (buffer offset sequence)
(:documentation "Like calling insert-buffer-object on each of the objects in the
sequence."))
(defmethod insert-buffer-sequence ((buffer standard-buffer) offset sequence)
(loop for elem across sequence
do (insert-buffer-object buffer offset elem)
(incf offset)))
(defgeneric insert-object (mark object))
(defgeneric insert-object (mark object)
(:documentation "Insert the object at the mark. This function simply calls
insert-buffer-object with the buffer and the position of the mark."))
(defmethod insert-object ((mark mark-mixin) object)
(insert-buffer-object (buffer mark) (offset mark) object))
(defgeneric insert-sequence (mark sequence))
(defgeneric insert-sequence (mark string)
(:documentation "Insert the objects in the sequence at the mark. This function simply
calls insert-buffer-sequence with the buffer and the position of the
mark."))
(defmethod insert-sequence ((mark mark-mixin) sequence)
(insert-buffer-sequence (buffer mark) (offset mark) sequence))
(defgeneric delete-buffer-range (buffer offset n))
(defgeneric delete-buffer-range (buffer offset n)
(:documentation "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."))
(defmethod delete-buffer-range ((buffer standard-buffer) offset n)
(assert (<= 0 offset (size buffer)) ()
......@@ -254,14 +346,24 @@
(loop repeat n
do (delete* (slot-value buffer 'contents) offset)))
(defgeneric delete-range (mark &optional n))
(defgeneric delete-range (mark &optional n)
(:documentation "Delete n objects after (if n > 0) or before (if n < 0) the mark.
This function eventually calls delete-buffer-range, provided that n
is not zero."))
(defmethod delete-range ((mark 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)))
(defgeneric delete-region (mark1 mark2))
(defgeneric delete-region (mark1 mark2)
(:documentation "Delete the objects in the buffer that are 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, no objects are deleted. If objects are
to be deleted, this function calls delete-buffer-range with the
appropriate arguments. It is acceptable to pass an offset in place
of one of the marks."))
(defmethod delete-region ((mark1 mark-mixin) (mark2 mark-mixin))
(assert (eq (buffer mark1) (buffer mark2)))
......@@ -282,14 +384,22 @@
offset1
(- (offset mark2) offset1))))
(defgeneric buffer-object (buffer offset))
(defgeneric buffer-object (buffer offset)
(:documentation "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."))
(defmethod buffer-object ((buffer standard-buffer) offset)
(assert (<= 0 offset (1- (size buffer))) ()
(make-condition 'no-such-offset :offset offset))
(element* (slot-value buffer 'contents) offset))
(defgeneric buffer-sequence (buffer offset1 offset2))
(defgeneric buffer-sequence (buffer offset1 offset2)
(:documentation "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."))
(defmethod buffer-sequence ((buffer standard-buffer) offset1 offset2)
(assert (<= 0 offset1 (size buffer)) ()
......@@ -300,17 +410,30 @@
collect (buffer-object buffer offset))
'vector))
(defgeneric object-before (mark))
(defgeneric object-before (mark)
(:documentation "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."))
(defmethod object-before ((mark mark-mixin))
(buffer-object (buffer mark) (1- (offset mark))))
(defgeneric object-after (mark))
(defgeneric object-after (mark)
(:documentation "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 mark is at the end of a line, but not at the end of the buffer, a
newline character is returned."))
(defmethod object-after ((mark mark-mixin))
(buffer-object (buffer mark) (offset mark)))
(defgeneric region-to-sequence (mark1 mark2))
(defgeneric region-to-sequence (mark1 mark2)
(:documentation "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."))
(defmethod region-to-sequence ((mark1 mark-mixin) (mark2 mark-mixin))
(assert (eq (buffer mark1) (buffer mark2)))
......
;;; -*- Mode: Lisp; Package: CLIMACS-GUI -*-
;;; (c) copyright 2004 by
;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
;;; Robert Strandh (strandh@labri.fr)
;;; (c) copyright 2004 by
;;; Elliott Johnson (ejohnson@fasl.info)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
......@@ -54,10 +56,12 @@
(:top-level (climacs-top-level)))
(defun climacs ()
"Starts up a climacs session"
(let ((frame (make-application-frame 'climacs)))
(run-frame-top-level frame)))
(defun display-win (frame pane)
"The display function used by the climacs application frame."
(let* ((medium (sheet-medium pane))
(style (medium-text-style medium))
(height (text-style-height style medium))
......@@ -200,7 +204,8 @@
(define-command com-extended-command ()
(accept 'command :prompt "Extended Command"))
(defclass weird () ())
(defclass weird () ()
(:documentation "An open ended class."))
(define-command com-insert-weird-stuff ()
(insert-object (point (win *application-frame*)) (make-instance 'weird)))
......@@ -283,7 +288,8 @@
(let ((filename (accept 'completable-pathname
:prompt "Find File"))
(buffer (make-instance 'climacs-buffer)))
(setf (buffer (win *application-frame*)) buffer)
(setf (buffer (win *application-frame*)) buffer
(filename (buffer (win *application-frame*)) filename))
(with-open-file (stream filename :direction :input)
(input-from-stream stream buffer 0))
(setf (slot-value (win *application-frame*) 'point)
......
;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*-
;;; (c) copyright 2004 by
;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
;;; Robert Strandh (strandh@labri.fr)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
......
;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*-
;;; (c) copyright 2004 by
;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
;;; Robert Strandh (strandh@labri.fr)
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Library General Public
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment