[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Sat Sep 2 21:43:59 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv25834
Modified Files:
ttcn3-syntax.lisp text-syntax.lisp syntax.lisp slidemacs.lisp
prolog-syntax.lisp pane.lisp packages.lisp lisp-syntax.lisp
html-syntax.lisp fundamental-syntax.lisp core.lisp
cl-syntax.lisp
Log Message:
Removed the Basic syntax and the `cache' slot in the `climacs-pane'
class. Fundamental syntax is now the default. This also required
moving some things around, but there has not been any functionality
changes.
--- /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/06/12 19:10:58 1.6
+++ /project/climacs/cvsroot/climacs/ttcn3-syntax.lisp 2006/09/02 21:43:56 1.7
@@ -22,7 +22,7 @@
(defpackage :climacs-ttcn3-syntax
(:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane)
+ :climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax)
(:export))
(in-package :climacs-ttcn3-syntax)
@@ -119,7 +119,7 @@
(make-instance 'identifier))
(t (fo) (make-instance 'other-entry)))))))))
-(define-syntax ttcn3-syntax (basic-syntax)
+(define-syntax ttcn3-syntax (fundamental-syntax)
((lexer :reader lexer)
(valid-parse :initform 1)
(parser))
--- /project/climacs/cvsroot/climacs/text-syntax.lisp 2006/06/12 19:10:58 1.10
+++ /project/climacs/cvsroot/climacs/text-syntax.lisp 2006/09/02 21:43:56 1.11
@@ -65,7 +65,7 @@
(setf low-position (floor (+ low-position 1 high-position) 2)))
finally (return low-position)))
-(define-syntax text-syntax (basic-syntax)
+(define-syntax text-syntax (climacs-fundamental-syntax:fundamental-syntax)
((paragraphs :initform (make-instance 'standard-flexichain))
(sentence-beginnings :initform (make-instance 'standard-flexichain))
(sentence-endings :initform (make-instance 'standard-flexichain)))
@@ -79,74 +79,75 @@
(let ((pos1 (index-of-mark-after-offset paragraphs low-offset))
(pos-sentence-beginnings (index-of-mark-after-offset sentence-beginnings low-offset))
(pos-sentence-endings (index-of-mark-after-offset sentence-endings low-offset)))
- ;; start by deleting all syntax marks that are between the low and
- ;; the high marks
- (loop repeat (- (nb-elements paragraphs) pos1)
- while (mark<= (element* paragraphs pos1) high-offset)
- do (delete* paragraphs pos1))
- (loop repeat (- (nb-elements sentence-beginnings) pos-sentence-beginnings)
- while (mark<= (element* sentence-beginnings pos-sentence-beginnings) high-offset)
- do (delete* sentence-beginnings pos-sentence-beginnings))
- (loop repeat (- (nb-elements sentence-endings) pos-sentence-endings)
- while (mark<= (element* sentence-endings pos-sentence-endings) high-offset)
- do (delete* sentence-endings pos-sentence-endings))
-
- ;; check the zone between low-offset and high-offset for
- ;; paragraph delimiters and sentence delimiters
- (loop with buffer-size = (size buffer)
- for offset from low-offset to high-offset ;; Could be rewritten with even fewer buffer-object calls,
- for current-object = nil then (if (>= offset high-offset) nil (buffer-object buffer offset)) ;; but it'd be premature optimization, and messy besides.
- for next-object = nil then (if (>= offset (- high-offset 1)) nil (buffer-object buffer (1+ offset)))
- for prev-object = nil then (if (= offset low-offset) nil (buffer-object buffer (1- offset)))
- for before-prev-object = nil then (if (<= offset (1+ low-offset)) nil (buffer-object buffer (- offset 2)))
- do (progn
- (cond ((and (< offset buffer-size)
- (member prev-object '(#\. #\? #\!))
- (or (= offset (1- buffer-size))
- (and (member current-object '(#\Newline #\Space #\Tab))
- (or (= offset 1)
- (not (member before-prev-object '(#\Newline #\Space #\Tab)))))))
- (let ((m (clone-mark (low-mark buffer) :left)))
- (setf (offset m) offset)
- (insert* sentence-endings pos-sentence-endings m))
- (incf pos-sentence-endings))
-
- ((and (>= offset 0)
- (not (member current-object '(#\. #\? #\! #\Newline #\Space #\Tab)))
- (or (= offset 0)
- (member prev-object '(#\Newline #\Space #\Tab)))
- (or (<= offset 1)
- (member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab))))
- (let ((m (clone-mark (low-mark buffer) :right)))
- (setf (offset m) offset)
- (insert* sentence-beginnings pos-sentence-beginnings m))
- (incf pos-sentence-beginnings))
- (t nil))
-
- ;; Paragraphs
-
- (cond ((and (< offset buffer-size) ;; Ends
- (not (eql current-object #\Newline))
- (or (zerop offset)
- (and (eql prev-object #\Newline)
- (or (= offset 1)
- (eql before-prev-object #\Newline)))))
- (let ((m (clone-mark (low-mark buffer) :left)))
- (setf (offset m) offset)
- (insert* paragraphs pos1 m))
- (incf pos1))
-
- ((and (plusp offset) ;;Beginnings
- (not (eql prev-object #\Newline))
- (or (= offset buffer-size)
- (and (eql current-object #\Newline)
- (or (= offset (1- buffer-size))
- (eql next-object #\Newline)))))
- (let ((m (clone-mark (low-mark buffer) :right)))
- (setf (offset m) offset)
- (insert* paragraphs pos1 m))
- (incf pos1))
- (t nil))))))))
+ ;; start by deleting all syntax marks that are between the low and
+ ;; the high marks
+ (loop repeat (- (nb-elements paragraphs) pos1)
+ while (mark<= (element* paragraphs pos1) high-offset)
+ do (delete* paragraphs pos1))
+ (loop repeat (- (nb-elements sentence-beginnings) pos-sentence-beginnings)
+ while (mark<= (element* sentence-beginnings pos-sentence-beginnings) high-offset)
+ do (delete* sentence-beginnings pos-sentence-beginnings))
+ (loop repeat (- (nb-elements sentence-endings) pos-sentence-endings)
+ while (mark<= (element* sentence-endings pos-sentence-endings) high-offset)
+ do (delete* sentence-endings pos-sentence-endings))
+
+ ;; check the zone between low-offset and high-offset for
+ ;; paragraph delimiters and sentence delimiters
+ (loop with buffer-size = (size buffer)
+ for offset from low-offset to high-offset ;; Could be rewritten with even fewer buffer-object calls,
+ for current-object = nil then (if (>= offset high-offset) nil (buffer-object buffer offset)) ;; but it'd be premature optimization, and messy besides.
+ for next-object = nil then (if (>= offset (- high-offset 1)) nil (buffer-object buffer (1+ offset)))
+ for prev-object = nil then (if (= offset low-offset) nil (buffer-object buffer (1- offset)))
+ for before-prev-object = nil then (if (<= offset (1+ low-offset)) nil (buffer-object buffer (- offset 2)))
+ do (progn
+ (cond ((and (< offset buffer-size)
+ (member prev-object '(#\. #\? #\!))
+ (or (= offset (1- buffer-size))
+ (and (member current-object '(#\Newline #\Space #\Tab))
+ (or (= offset 1)
+ (not (member before-prev-object '(#\Newline #\Space #\Tab)))))))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) offset)
+ (insert* sentence-endings pos-sentence-endings m))
+ (incf pos-sentence-endings))
+
+ ((and (>= offset 0)
+ (not (member current-object '(#\. #\? #\! #\Newline #\Space #\Tab)))
+ (or (= offset 0)
+ (member prev-object '(#\Newline #\Space #\Tab)))
+ (or (<= offset 1)
+ (member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab))))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) offset)
+ (insert* sentence-beginnings pos-sentence-beginnings m))
+ (incf pos-sentence-beginnings))
+ (t nil))
+
+ ;; Paragraphs
+
+ (cond ((and (< offset buffer-size) ;; Ends
+ (not (eql current-object #\Newline))
+ (or (zerop offset)
+ (and (eql prev-object #\Newline)
+ (or (= offset 1)
+ (eql before-prev-object #\Newline)))))
+ (let ((m (clone-mark (low-mark buffer) :left)))
+ (setf (offset m) offset)
+ (insert* paragraphs pos1 m))
+ (incf pos1))
+
+ ((and (plusp offset) ;;Beginnings
+ (not (eql prev-object #\Newline))
+ (or (= offset buffer-size)
+ (and (eql current-object #\Newline)
+ (or (= offset (1- buffer-size))
+ (eql next-object #\Newline)))))
+ (let ((m (clone-mark (low-mark buffer) :right)))
+ (setf (offset m) offset)
+ (insert* paragraphs pos1 m))
+ (incf pos1))
+ (t nil)))))))
+ (call-next-method))
(defmethod backward-one-paragraph (mark (syntax text-syntax))
(with-slots (paragraphs) syntax
--- /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/02 10:17:52 1.70
+++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/09/02 21:43:56 1.71
@@ -112,11 +112,15 @@
(defgeneric name-for-info-pane (syntax &key &allow-other-keys)
(:documentation "Return the name that should be used for the
- info-pane for panes displaying a buffer in this syntax."))
+ info-pane for panes displaying a buffer in this syntax.")
+ (:method (syntax &key &allow-other-keys)
+ (name syntax)))
(defgeneric display-syntax-name (syntax stream &key &allow-other-keys)
(:documentation "Draw the name of the syntax `syntax' to
- `stream'. This is meant to be called for the info-pane."))
+ `stream'. This is meant to be called for the info-pane.")
+ (:method (syntax stream &rest args &key)
+ (princ (apply #'name-for-info-pane syntax args) stream)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -124,6 +128,12 @@
(defparameter *syntaxes* '())
+(defvar *default-syntax* nil
+ "The name of the default syntax. Must be a symbol.
+
+This syntax will be used by default, when no other syntax is
+mandated by file types or attribute lists.")
+
(defstruct (syntax-description (:type list))
(name (error "required argument") :type string)
(class-name (error "required argument") :type symbol)
@@ -251,37 +261,6 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
-;;; Basic syntax
-
-;;; FIXME: this is a really bad name. It's even worse if it's
-;;; case-insensitive. Emacs' "Fundamental" isn't too bad.
-(define-syntax basic-syntax (syntax)
- ()
- (:name "Basic"))
-
-(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 name-for-info-pane ((syntax basic-syntax) &key)
- (name syntax))
-
-(defmethod display-syntax-name ((syntax basic-syntax) stream &rest args &key)
- (princ (apply #'name-for-info-pane syntax args) stream))
-
-(defmethod syntax-line-indentation (mark tab-width (syntax basic-syntax))
- (declare (ignore mark tab-width))
- 0)
-
-(defmethod eval-defun (mark syntax)
- (error 'no-such-operation))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
;;; Incremental Earley parser
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
--- /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/06/12 19:10:58 1.10
+++ /project/climacs/cvsroot/climacs/slidemacs.lisp 2006/09/02 21:43:56 1.11
@@ -22,7 +22,7 @@
(defpackage :climacs-slidemacs-editor
(:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane)
+ :climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax)
(:export))
(in-package :climacs-slidemacs-editor)
@@ -105,7 +105,7 @@
(make-instance 'slidemacs-keyword))
(t (fo) (make-instance 'other-entry)))))))))
-(define-syntax slidemacs-editor-syntax (basic-syntax)
+(define-syntax slidemacs-editor-syntax (fundamental-syntax)
((lexer :reader lexer)
(valid-parse :initform 1) (parser))
(:name "Slidemacs-Editor")
--- /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/06/12 19:10:58 1.28
+++ /project/climacs/cvsroot/climacs/prolog-syntax.lisp 2006/09/02 21:43:56 1.29
@@ -26,7 +26,7 @@
(defclass prolog-parse-tree (parse-tree)
())
-(define-syntax prolog-syntax (basic-syntax)
+(define-syntax prolog-syntax (fundamental-syntax)
((lexer :reader lexer)
(valid-parse :initform 1)
(parser)
--- /project/climacs/cvsroot/climacs/pane.lisp 2006/09/01 18:22:15 1.51
+++ /project/climacs/cvsroot/climacs/pane.lisp 2006/09/02 21:43:56 1.52
@@ -260,7 +260,7 @@
(declare (ignore args))
(with-slots (syntax point) buffer
(setf syntax (make-instance
- 'basic-syntax :buffer (implementation buffer))
+ *default-syntax* :buffer (implementation buffer))
point (clone-mark (low-mark buffer) :right))))
(defmethod (setf syntax) :after (syntax (buffer climacs-buffer))
@@ -286,22 +286,10 @@
(query-replace-mode :initform nil :accessor query-replace-mode)
(query-replace-state :initform nil :accessor query-replace-state)
(region-visible-p :initform nil :accessor region-visible-p)
- (full-redisplay-p :initform nil :accessor full-redisplay-p)
- (cache :initform (let ((cache (make-instance 'standard-flexichain)))
- (insert* cache 0 nil)
- cache)))
+ (full-redisplay-p :initform nil :accessor full-redisplay-p))
(:default-initargs
:default-view +climacs-textual-view+))
-(defgeneric clear-cache (pane)
- (:documentation "Clear the cache for `pane.'"))
-
-(defmethod clear-cache ((pane climacs-pane))
- (with-slots (cache) pane
- (setf cache (let ((cache (make-instance 'standard-flexichain)))
- (insert* cache 0 nil)
- cache))))
-
(defmethod tab-width ((pane climacs-pane))
(tab-width (stream-default-view pane)))
@@ -343,95 +331,10 @@
top (clone-mark (low-mark buffer) :left)
bot (clone-mark (high-mark buffer) :right))))
+;; FIXME: Move this somewhere else.
(define-presentation-type url ()
:inherit-from 'string)
-(defgeneric present-contents (contents pane))
-
-(defmethod present-contents (contents pane)
- (unless (null contents)
- (present contents
- (if (and (>= (length contents) 7) (string= (subseq contents 0 7) "http://"))
- 'url
- 'string)
- :stream pane)))
-
-(defgeneric display-line (pane line offset syntax view))
-
-(defmethod display-line (pane line offset (syntax basic-syntax) (view textual-view))
- (declare (ignore offset))
- (let ((saved-index nil)
- (id 0))
- (flet ((output-word (index)
- (unless (null saved-index)
- (let ((contents (coerce (subseq line saved-index index) 'string)))
- (updating-output (pane :unique-id (incf id)
- :id-test #'=
- :cache-value contents
- :cache-test #'equal)
- (present-contents contents pane)))
- (setf saved-index nil))))
- (with-slots (bot scan cursor-x cursor-y) pane
- (loop with space-width = (space-width pane)
- with tab-width = (tab-width pane)
- for index from 0
- for obj across line
- when (mark= scan (point pane))
- do (multiple-value-bind (x y) (stream-cursor-position pane)
- (setf cursor-x (+ x (if (null saved-index)
- 0
- (* space-width (- index saved-index))))
- cursor-y y))
- do (cond ((eql obj #\Space)
- (output-word index)
- (stream-increment-cursor-position pane space-width 0))
- ((eql obj #\Tab)
- (output-word index)
- (let ((x (stream-cursor-position pane)))
- (stream-increment-cursor-position
- pane (- tab-width (mod x tab-width)) 0)))
- ((constituentp obj)
- (when (null saved-index)
- (setf saved-index index)))
- ((characterp obj)
- (output-word index)
- (updating-output (pane :unique-id (incf id)
- :id-test #'=
- :cache-value obj
- :cache-test #'equal)
- (present obj 'character :stream pane)))
- (t
- (output-word index)
- (updating-output (pane :unique-id (incf id)
- :id-test #'=
- :cache-value obj
- :cache-test #'equal)
- (present obj 'character :stream pane))))
- (incf scan)
- finally (output-word index)
- (when (mark= scan (point pane))
- (multiple-value-bind (x y) (stream-cursor-position pane)
- (setf cursor-x x
- cursor-y y)))
- (terpri pane)
- (incf scan))))))
-
-(defgeneric fill-cache (pane)
- (:documentation "fill nil cache entries from the buffer"))
-
-(defmethod fill-cache (pane)
- (with-slots (top bot cache) pane
- (let ((mark1 (clone-mark top))
- (mark2 (clone-mark top)))
- (loop for line from 0 below (nb-elements cache)
- do (beginning-of-line mark1)
- (end-of-line mark2)
- when (null (element* cache line))
- do (setf (element* cache line) (region-to-sequence mark1 mark2))
- unless (end-of-buffer-p mark2)
- do (setf (offset mark1) (1+ (offset mark2))
- (offset mark2) (offset mark1))))))
-
(defun nb-lines-in-pane (pane)
(let* ((medium (sheet-medium pane))
(style (medium-text-style medium))
@@ -441,91 +344,53 @@
(max 1 (floor h (+ height (stream-vertical-spacing pane)))))))
;;; make the region on display fit the size of the pane as closely as
-;;; possible by adjusting bot leaving top intact. Also make the cache
-;;; size fit the size of the region on display.
-(defun adjust-cache-size-and-bot (pane)
+;;; possible by adjusting bot leaving top intact.
+(defun adjust-pane-bot (pane)
(let ((nb-lines-in-pane (nb-lines-in-pane pane)))
- (with-slots (top bot cache) pane
+ (with-slots (top bot) pane
(setf (offset bot) (offset top))
(end-of-line bot)
(loop until (end-of-buffer-p bot)
repeat (1- nb-lines-in-pane)
do (forward-object bot)
- (end-of-line bot))
- (let ((nb-lines-on-display (1+ (number-of-lines-in-region top bot))))
- (loop repeat (- (nb-elements cache) nb-lines-on-display)
- do (pop-end cache))
- (loop repeat (- nb-lines-on-display (nb-elements cache))
- do (push-end cache nil))))))
-
-;;; put all-nil entries in the cache
-(defun empty-cache (cache)
- (loop for i from 0 below (nb-elements cache)
- do (setf (element* cache i) nil)))
-
-;;; empty the cache and try to put point close to the middle
-;;; of the pane by moving top half a pane-size up.
-(defun reposition-window (pane)
+ (end-of-line bot)))))
+
+;;; Try to put point close to the middle of the pane by moving top
+;;; half a pane-size up.
+(defun reposition-pane (pane)
(let ((nb-lines-in-pane (nb-lines-in-pane pane)))
- (with-slots (top cache) pane
- (empty-cache cache)
- (setf (offset top) (offset (point pane)))
- (loop do (beginning-of-line top)
- repeat (floor nb-lines-in-pane 2)
- until (beginning-of-buffer-p top)
- do (decf (offset top))
- (beginning-of-line top)))))
-
-;;; Make the cache reflect the contents of the buffer starting at top,
-;;; trying to preserve contents as much as possible, and inserting a
-;;; nil entry where buffer contents is unknonwn. The size of the
-;;; cache at the end may be smaller than, equal to, or greater than
-;;; the number of lines in the pane.
-(defun adjust-cache (pane)
+ (with-slots (top) pane
+ (setf (offset top) (offset (point pane)))
+ (loop do (beginning-of-line top)
+ repeat (floor nb-lines-in-pane 2)
+ until (beginning-of-buffer-p top)
+ do (decf (offset top))
+ (beginning-of-line top)))))
+
+;; Adjust the bottom and top marks of the pane to be correct, and
+;; reposition the pane if point is outside the visible area.
+(defun adjust-pane (pane)
(let* ((buffer (buffer pane))
- (high-mark (high-mark buffer))
(low-mark (low-mark buffer))
(nb-lines-in-pane (nb-lines-in-pane pane)))
- (with-slots (top bot cache) pane
- (beginning-of-line top)
- (end-of-line bot)
- (if (or (mark< (point pane) top)
- (>= (number-of-lines-in-region top (point pane)) nb-lines-in-pane)
- (and (mark< low-mark top)
- (>= (number-of-lines-in-region top high-mark) (nb-elements cache))))
- (reposition-window pane)
- (when (mark>= high-mark low-mark)
- (let* ((n1 (number-of-lines-in-region top low-mark))
- (n2 (1+ (number-of-lines-in-region low-mark high-mark)))
- (n3 (number-of-lines-in-region high-mark bot))
- (diff (- (+ n1 n2 n3) (nb-elements cache))))
- (cond ((>= (+ n1 n2 n3) (+ (nb-elements cache) 20))
- (setf (offset bot) (offset top))
- (end-of-line bot)
- (loop for i from n1 below (nb-elements cache)
- do (setf (element* cache i) nil)))
- ((>= diff 0)
- (loop repeat diff do (insert* cache n1 nil))
- (loop for i from (+ n1 diff) below (+ n1 n2)
- do (setf (element* cache i) nil)))
- (t
- (loop repeat (- diff) do (delete* cache n1))
- (loop for i from n1 below (+ n1 n2)
- do (setf (element* cache i) nil)))))))))
- (adjust-cache-size-and-bot pane))
+ (with-slots (top bot) pane
+ (beginning-of-line top)
+ (end-of-line bot)
+ (when (or (mark< (point pane) top)
+ (>= (number-of-lines-in-region top (point pane)) nb-lines-in-pane)
+ (mark< low-mark top))
+ (reposition-pane pane))))
+ (adjust-pane-bot pane))
(defun page-down (pane)
- (adjust-cache pane)
- (with-slots (top bot cache) pane
+ (with-slots (top bot) pane
(when (mark> (size (buffer bot)) bot)
- (empty-cache cache)
(setf (offset top) (offset bot))
(beginning-of-line top)
(setf (offset (point pane)) (offset top)))))
(defun page-up (pane)
- (adjust-cache pane)
- (with-slots (top bot cache) pane
+ (with-slots (top bot) pane
(when (> (offset top) 0)
(let ((nb-lines-in-region (number-of-lines-in-region top bot)))
(setf (offset bot) (offset top))
@@ -535,48 +400,25 @@
do (decf (offset top))
(beginning-of-line top))
(setf (offset (point pane)) (offset top))
- (adjust-cache pane)
(setf (offset (point pane)) (offset bot))
- (beginning-of-line (point pane))
- (empty-cache cache)))))
-
-(defun display-cache (pane)
- (with-slots (top bot scan cache cursor-x cursor-y) pane
- (loop with start-offset = (offset top)
- for id from 0 below (nb-elements cache)
- do (setf scan start-offset)
- (updating-output
- (pane :unique-id id
- :id-test #'equal
- :cache-value (element* cache id)
- :cache-test #'equal)
- (display-line pane (element* cache id) start-offset
- (syntax (buffer pane)) (stream-default-view pane)))
- (incf start-offset (1+ (length (element* cache id)))))
- (when (mark= scan (point pane))
- (multiple-value-bind (x y) (stream-cursor-position pane)
- (setf cursor-x x
- cursor-y y)))))
+ (beginning-of-line (point pane))))))
(defgeneric fix-pane-viewport (pane))
(defmethod fix-pane-viewport ((pane climacs-pane))
- (change-space-requirements pane :min-width (bounding-rectangle-width (stream-current-output-record pane))))
-
-(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax basic-syntax) current-p)
- (display-cache pane)
- (when (region-visible-p pane) (display-region pane syntax))
- (display-cursor pane syntax current-p))
+ (change-space-requirements
+ pane
+ :min-width (bounding-rectangle-width (stream-current-output-record pane))
+ :max-height (bounding-rectangle-width (or (pane-viewport pane) pane))))
(defgeneric redisplay-pane (pane current-p))
(defmethod redisplay-pane ((pane climacs-pane) current-p)
(if (full-redisplay-p pane)
- (progn (reposition-window pane)
- (adjust-cache-size-and-bot pane)
+ (progn (reposition-pane pane)
+ (adjust-pane-bot pane)
(setf (full-redisplay-p pane) nil))
- (adjust-cache pane))
- (fill-cache pane)
+ (adjust-pane pane))
(update-syntax-for-display (buffer pane) (syntax (buffer pane)) (top pane) (bot pane))
(redisplay-pane-with-syntax pane (syntax (buffer pane)) current-p)
(fix-pane-viewport pane))
@@ -588,165 +430,8 @@
(defgeneric display-cursor (pane syntax current-p))
-(defmethod display-cursor ((pane climacs-pane) (syntax basic-syntax) current-p)
- (let ((point (point pane)))
- (multiple-value-bind (cursor-x cursor-y line-height)
- (offset-to-screen-position (offset point) pane)
- (updating-output (pane :unique-id -1 :cache-value (offset point))
- (draw-rectangle* pane
- (1- cursor-x) cursor-y
- (+ cursor-x 2) (+ cursor-y line-height)
- :ink (if current-p +red+ +blue+))
- ;; Move the position of the viewport if point is outside the
- ;; visible area. The trick is that we do this inside the body
- ;; of `updating-output', so the view will only be re-focused
- ;; when point is actually moved.
- (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0)))
- (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane))))
- #+nil(print (list cursor-x (+ x-position (bounding-rectangle-width (pane-viewport pane)))) *terminal-io*)
- (cond ((> cursor-x (+ x-position viewport-width))
- (move-sheet pane (round (- (- cursor-x viewport-width))) 0))
- ((> x-position cursor-x)
- (move-sheet pane (if (> viewport-width cursor-x)
- 0
- (round (- cursor-x)))
- 0))))))))
-
(defgeneric display-region (pane syntax))
-(defmethod display-region ((pane climacs-pane) (syntax basic-syntax))
- (highlight-region pane (point pane) (mark pane)))
-
-(defgeneric highlight-region (pane mark1 offset2 &optional ink))
-
-(defmethod highlight-region ((pane climacs-pane) (offset1 integer) (offset2 integer)
- &optional (ink (compose-in +green+ (make-opacity .1))))
- ;; FIXME stream-vertical-spacing between lines
- ;; FIXME note sure updating output is working properly...
- ;; we'll call offset1 CURSOR and offset2 MARK
- (multiple-value-bind (cursor-x cursor-y line-height)
- (offset-to-screen-position offset1 pane)
- (multiple-value-bind (mark-x mark-y)
- (offset-to-screen-position offset2 pane)
- (cond
- ;; mark and point are above the screen
- ((and (null cursor-y) (null mark-y)
- (null cursor-x) (null mark-x))
- nil)
- ;; mark and point are below the screen
- ((and (null cursor-y) (null mark-y)
- cursor-x mark-x)
- nil)
- ;; mark or point is above the screen, and point or mark below it
- ((and (null cursor-y) (null mark-y)
- (or (and cursor-x (null mark-x))
- (and (null cursor-x) mark-x)))
- (let ((width (stream-text-margin pane))
- (height (bounding-rectangle-height
- (window-viewport pane))))
- (updating-output (pane :unique-id -3
- :cache-value (list cursor-y mark-y cursor-x mark-x
- height width ink))
- (draw-rectangle* pane
- 0 0
- width height
- :ink ink))))
- ;; mark is above the top of the screen
- ((and (null mark-y) (null mark-x))
- (let ((width (stream-text-margin pane)))
- (updating-output (pane :unique-id -3
- :cache-value ink)
- (updating-output (pane :cache-value (list mark-y mark-x cursor-y width))
- (draw-rectangle* pane
- 0 0
- width cursor-y
- :ink ink))
- (updating-output (pane :cache-value (list cursor-y cursor-x))
- (draw-rectangle* pane
- 0 cursor-y
- cursor-x (+ cursor-y line-height)
- :ink ink)))))
- ;; mark is below the bottom of the screen
- ((and (null mark-y) mark-x)
- (let ((width (stream-text-margin pane))
- (height (bounding-rectangle-height
- (window-viewport pane))))
- (updating-output (pane :unique-id -3
- :cache-value ink)
- (updating-output (pane :cache-value (list cursor-y width height))
[76 lines skipped]
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/08/20 13:06:38 1.112
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/09/02 21:43:56 1.113
@@ -118,13 +118,12 @@
(defpackage :climacs-syntax
(:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain)
- (:export #:syntax #:define-syntax
+ (:export #:syntax #:define-syntax #:*default-syntax*
#:eval-option
#:define-option-for-syntax
#:current-attributes-for-syntax
#:make-attribute-line
#:syntax-from-name
- #:basic-syntax
#:update-syntax #:update-syntax-for-display
#:grammar #:grammar-rule #:add-rule
#:parser #:initial-state
@@ -179,6 +178,7 @@
#:redisplay-pane #:full-redisplay
#:display-cursor
#:display-region
+ #:offset-to-screen-position
#:page-down #:page-up
#:top #:bot
#:tab-space-count #:space-width #:tab-width
@@ -311,6 +311,11 @@
manipulating belong to. These functions are also directly used
to implement the editing commands."))
+(defpackage :climacs-fundamental-syntax
+ (:use :clim-lisp :clim :climacs-buffer :climacs-base
+ :climacs-syntax :flexichain :climacs-pane)
+ (:export #:fundamental-syntax))
+
(defpackage :climacs-gui
(:use :clim-lisp :clim :climacs-buffer :climacs-base
:climacs-abbrev :climacs-syntax :climacs-motion
@@ -367,7 +372,7 @@
))
(defpackage :climacs-core
- (:use :clim-lisp :climacs-base :climacs-buffer
+ (:use :clim-lisp :climacs-base :climacs-buffer :climacs-fundamental-syntax
:climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring
:climacs-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io)
(:export #:display-string
@@ -432,28 +437,23 @@
command definitions, as well as some useful automatic
command-defining facilities."))
-(defpackage :climacs-fundamental-syntax
- (:use :clim-lisp :clim :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane)
- (:export #:fundamental-syntax))
-
(defpackage :climacs-html-syntax
(:use :clim-lisp :clim :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane))
+ :climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax))
(defpackage :climacs-prolog-syntax
(:use :clim-lisp :clim :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane :climacs-core)
+ :climacs-syntax :flexichain :climacs-pane :climacs-core :climacs-fundamental-syntax)
(:shadow #:atom #:close #:exp #:integer #:open #:variable))
(defpackage :climacs-cl-syntax
(:use :clim-lisp :clim :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane)
+ :climacs-syntax :flexichain :climacs-pane :climacs-fundamental-syntax)
(:export))
(defpackage :climacs-lisp-syntax
(:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane :climacs-gui
+ :climacs-syntax :climacs-fundamental-syntax :flexichain :climacs-pane :climacs-gui
:climacs-motion :climacs-editing :climacs-core)
(:export #:lisp-string
#:edit-definition))
--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/02 19:38:29 1.111
+++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/09/02 21:43:56 1.112
@@ -60,7 +60,7 @@
;;;
;;; the syntax object
-(define-syntax lisp-syntax (basic-syntax)
+(define-syntax lisp-syntax (fundamental-syntax)
((stack-top :initform nil)
(potentially-valid-trees)
(lookahead-lexeme :initform nil :accessor lookahead-lexeme)
--- /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/06/12 19:10:58 1.34
+++ /project/climacs/cvsroot/climacs/html-syntax.lisp 2006/09/02 21:43:56 1.35
@@ -22,7 +22,7 @@
(in-package :climacs-html-syntax)
-(define-syntax html-syntax (basic-syntax)
+(define-syntax html-syntax (fundamental-syntax)
((lexer :reader lexer)
(valid-parse :initform 1)
(parser))
--- /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/06/12 19:10:58 1.4
+++ /project/climacs/cvsroot/climacs/fundamental-syntax.lisp 2006/09/02 21:43:56 1.5
@@ -26,9 +26,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
-;;; the syntax object
+;;; The syntax object and misc stuff.
-(define-syntax fundamental-syntax (basic-syntax)
+(define-syntax fundamental-syntax (syntax)
((lines :initform (make-instance 'standard-flexichain))
(scan))
(:name "Fundamental"))
@@ -38,6 +38,8 @@
(with-slots (buffer scan) syntax
(setf scan (clone-mark (low-mark buffer) :left))))
+(setf *default-syntax* 'fundamental-syntax)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; update syntax
@@ -120,74 +122,231 @@
'string)))
(updating-output (pane :unique-id (incf id)
:cache-value contents
- :cache-test #'string=)
+ :cache-test #'eql)
(unless (null contents)
(present contents 'string :stream pane))))
(setf saved-offset nil))))
(with-slots (bot scan cursor-x cursor-y) pane
- (loop with space-width = (space-width pane)
- with tab-width = (tab-width pane)
- until (end-of-line-p mark)
- do (let ((obj (object-after mark)))
- (cond ((eql obj #\Space)
- (output-word)
- (stream-increment-cursor-position pane space-width 0))
- ((eql obj #\Tab)
- (output-word)
- (let ((x (stream-cursor-position pane)))
- (stream-increment-cursor-position
- pane (- tab-width (mod x tab-width)) 0)))
- ((constituentp obj)
- (when (null saved-offset)
- (setf saved-offset (offset mark))))
- ((characterp obj)
- (output-word)
- (updating-output (pane :unique-id (incf id)
- :cache-value obj)
- (present obj 'character :stream pane)))
- (t
- (output-word)
- (updating-output (pane :unique-id (incf id)
- :cache-value obj
- :cache-test #'eq)
- (present obj 'character :stream pane)))))
- do (forward-object mark)
- finally (output-word)
- (terpri pane))))))
+ (loop with space-width = (space-width pane)
+ with tab-width = (tab-width pane)
+ until (end-of-line-p mark)
+ do (let ((obj (object-after mark)))
+ (cond ((eql obj #\Space)
+ (output-word)
+ (stream-increment-cursor-position pane space-width 0))
+ ((eql obj #\Tab)
+ (output-word)
+ (let ((x (stream-cursor-position pane)))
+ (stream-increment-cursor-position
+ pane (- tab-width (mod x tab-width)) 0)))
+ ((constituentp obj)
+ (when (null saved-offset)
+ (setf saved-offset (offset mark))))
+ ((characterp obj)
+ (output-word)
+ (updating-output (pane :unique-id (incf id)
+ :cache-value obj)
+ (present obj 'character :stream pane)))
+ (t
+ (output-word)
+ (updating-output (pane :unique-id (incf id)
+ :cache-value obj
+ :cache-test #'eq)
+ (present obj 'character :stream pane)))))
+ do (forward-object mark)
+ finally
+ (output-word)
+ (terpri))))))
(defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax fundamental-syntax) current-p)
(with-slots (top bot) pane
- (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
- *current-line* 0
- (aref *cursor-positions* 0) (stream-cursor-position pane))
- (setf *white-space-start* (offset top))
- (with-slots (lines) syntax
- (with-slots (lines scan) syntax
- (let ((low-index 0)
- (high-index (nb-elements lines)))
- (loop while (< low-index high-index)
- do (let* ((middle (floor (+ low-index high-index) 2))
- (line-start (start-mark (element* lines middle))))
- (cond ((mark> top line-start)
- (setf low-index (1+ middle)))
- ((mark< top line-start)
- (setf high-index middle))
- (t
- (setf low-index middle
- high-index middle)))))
- (loop for i from low-index
- while (and (< i (nb-elements lines))
- (mark< (start-mark (element* lines i))
- bot))
- do (let ((line (element* lines i)))
- (updating-output (pane :unique-id line
- :id-test #'eq
- :cache-value line
- :cache-test #'eq)
- (display-line pane (start-mark (element* lines i))))))))))
+ (setf *cursor-positions* (make-array (1+ (number-of-lines-in-region top bot)))
+ *current-line* 0
+ (aref *cursor-positions* 0) (stream-cursor-position pane))
+ (setf *white-space-start* (offset top))
+ (with-slots (lines scan) syntax
+ (let ((low-index 0)
+ (high-index (nb-elements lines)))
+ (loop while (< low-index high-index)
+ do (let* ((middle (floor (+ low-index high-index) 2))
+ (line-start (start-mark (element* lines middle))))
+ (cond ((mark> top line-start)
+ (setf low-index (1+ middle)))
+ ((mark< top line-start)
+ (setf high-index middle))
+ (t
+ (setf low-index middle
+ high-index middle)))))
+ (loop for i from low-index
+ while (and (< i (nb-elements lines))
+ (mark< (start-mark (element* lines i))
+ bot))
+ do (let ((line (element* lines i)))
+ (updating-output (pane :unique-id i
+ :id-test #'eql
+ :cache-value line
+ :cache-test #'equal)
+ (display-line pane (start-mark (element* lines i)))))))))
(when (region-visible-p pane) (display-region pane syntax))
(display-cursor pane syntax current-p))
+(defmethod display-cursor ((pane climacs-pane) (syntax fundamental-syntax) current-p)
+ (let ((point (point pane)))
+ (multiple-value-bind (cursor-x cursor-y line-height)
+ (offset-to-screen-position (offset point) pane)
+ (updating-output (pane :unique-id -1 :cache-value (offset point))
+ (draw-rectangle* pane
+ (1- cursor-x) cursor-y
+ (+ cursor-x 2) (+ cursor-y line-height)
+ :ink (if current-p +red+ +blue+))
+ ;; Move the position of the viewport if point is outside the
+ ;; visible area. The trick is that we do this inside the body
+ ;; of `updating-output', so the view will only be re-focused
+ ;; when point is actually moved.
+ (let ((x-position (abs (transform-position (sheet-transformation pane) 0 0)))
+ (viewport-width (bounding-rectangle-width (or (pane-viewport pane) pane))))
+ #+nil(print (list cursor-x (+ x-position (bounding-rectangle-width (pane-viewport pane)))) *terminal-io*)
+ (cond ((> cursor-x (+ x-position viewport-width))
+ (move-sheet pane (round (- (- cursor-x viewport-width))) 0))
+ ((> x-position cursor-x)
+ (move-sheet pane (if (> viewport-width cursor-x)
+ 0
+ (round (- cursor-x)))
+ 0))))))))
+
+(defmethod display-region ((pane climacs-pane) (syntax fundamental-syntax))
+ (highlight-region pane (point pane) (mark pane)))
+
+(defgeneric highlight-region (pane mark1 offset2 &optional ink))
+
+(defmethod highlight-region ((pane climacs-pane) (offset1 integer) (offset2 integer)
+ &optional (ink (compose-in +green+ (make-opacity .1))))
+ ;; FIXME stream-vertical-spacing between lines
+ ;; FIXME note sure updating output is working properly...
+ ;; we'll call offset1 CURSOR and offset2 MARK
+ (multiple-value-bind (cursor-x cursor-y line-height)
+ (offset-to-screen-position offset1 pane)
+ (multiple-value-bind (mark-x mark-y)
+ (offset-to-screen-position offset2 pane)
+ (cond
+ ;; mark and point are above the screen
+ ((and (null cursor-y) (null mark-y)
+ (null cursor-x) (null mark-x))
+ nil)
+ ;; mark and point are below the screen
+ ((and (null cursor-y) (null mark-y)
+ cursor-x mark-x)
+ nil)
+ ;; mark or point is above the screen, and point or mark below it
+ ((and (null cursor-y) (null mark-y)
+ (or (and cursor-x (null mark-x))
+ (and (null cursor-x) mark-x)))
+ (let ((width (stream-text-margin pane))
+ (height (bounding-rectangle-height
+ (window-viewport pane))))
+ (updating-output (pane :unique-id -3
+ :cache-value (list cursor-y mark-y cursor-x mark-x
+ height width ink))
+ (draw-rectangle* pane
+ 0 0
+ width height
+ :ink ink))))
+ ;; mark is above the top of the screen
+ ((and (null mark-y) (null mark-x))
+ (let ((width (stream-text-margin pane)))
+ (updating-output (pane :unique-id -3
+ :cache-value ink)
+ (updating-output (pane :cache-value (list mark-y mark-x cursor-y width))
+ (draw-rectangle* pane
+ 0 0
+ width cursor-y
+ :ink ink))
+ (updating-output (pane :cache-value (list cursor-y cursor-x))
+ (draw-rectangle* pane
+ 0 cursor-y
+ cursor-x (+ cursor-y line-height)
+ :ink ink)))))
+ ;; mark is below the bottom of the screen
+ ((and (null mark-y) mark-x)
+ (let ((width (stream-text-margin pane))
+ (height (bounding-rectangle-height
+ (window-viewport pane))))
+ (updating-output (pane :unique-id -3
+ :cache-value ink)
+ (updating-output (pane :cache-value (list cursor-y width height))
+ (draw-rectangle* pane
+ 0 (+ cursor-y line-height)
+ width height
+ :ink ink))
+ (updating-output (pane :cache-value (list cursor-x cursor-y width))
+ (draw-rectangle* pane
+ cursor-x cursor-y
+ width (+ cursor-y line-height)
+ :ink ink)))))
+ ;; mark is at point
+ ((and (= mark-x cursor-x) (= mark-y cursor-y))
+ nil)
+ ;; mark and point are on the same line
+ ((= mark-y cursor-y)
+ (updating-output (pane :unique-id -3
+ :cache-value (list offset1 offset2 ink))
+ (draw-rectangle* pane
+ mark-x mark-y
+ cursor-x (+ cursor-y line-height)
+ :ink ink)))
+ ;; mark and point are both visible, mark above point
+ ((< mark-y cursor-y)
+ (let ((width (stream-text-margin pane)))
+ (updating-output (pane :unique-id -3
+ :cache-value ink)
+ (updating-output (pane :cache-value (list mark-x mark-y width))
+ (draw-rectangle* pane
+ mark-x mark-y
+ width (+ mark-y line-height)
+ :ink ink))
+ (updating-output (pane :cache-value (list cursor-x cursor-y))
+ (draw-rectangle* pane
+ 0 cursor-y
+ cursor-x (+ cursor-y line-height)
+ :ink ink))
+ (updating-output (pane :cache-value (list mark-y cursor-y width))
+ (draw-rectangle* pane
+ 0 (+ mark-y line-height)
+ width cursor-y
+ :ink ink)))))
+ ;; mark and point are both visible, point above mark
+ (t
+ (let ((width (stream-text-margin pane)))
+ (updating-output (pane :unique-id -3
+ :cache-value ink)
+ (updating-output (pane :cache-value (list cursor-x cursor-y width))
+ (draw-rectangle* pane
+ cursor-x cursor-y
+ width (+ cursor-y line-height)
+ :ink ink))
+ (updating-output (pane :cache-value (list mark-x mark-y))
+ (draw-rectangle* pane
+ 0 mark-y
+ mark-x (+ mark-y line-height)
+ :ink ink))
+ (updating-output (pane :cache-value (list cursor-y mark-y width))
+ (draw-rectangle* pane
+ 0 (+ cursor-y line-height)
+ width mark-y
+ :ink ink)))))))))
+
+(defmethod highlight-region ((pane climacs-pane) (mark1 mark) (mark2 mark)
+ &optional (ink (compose-in +green+ (make-opacity .1))))
+ (highlight-region pane (offset mark1) (offset mark2) ink))
+
+(defmethod highlight-region ((pane climacs-pane) (mark1 mark) (offset2 integer)
+ &optional (ink (compose-in +green+ (make-opacity .1))))
+ (highlight-region pane (offset mark1) offset2 ink))
+
+(defmethod highlight-region ((pane climacs-pane) (offset1 integer) (mark2 mark)
+ &optional (ink (compose-in +green+ (make-opacity .1))))
+ (highlight-region pane offset1 (offset mark2) ink))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; exploit the parse
--- /project/climacs/cvsroot/climacs/core.lisp 2006/09/02 10:17:52 1.6
+++ /project/climacs/cvsroot/climacs/core.lisp 2006/09/02 21:43:56 1.7
@@ -459,7 +459,7 @@
:test (lambda (x y)
(member x y :test #'string-equal))
:key #'climacs-syntax::syntax-description-pathname-types))
- 'basic-syntax))
+ *default-syntax*))
(defun evaluate-attributes (buffer options)
"Evaluate the attributes `options' and modify `buffer' as
@@ -627,10 +627,6 @@
(make-buffer-from-stream stream *application-frame*))
(make-new-buffer *application-frame*)))
(pane (current-window)))
- ;; Clear the pane's cache; otherwise residue from the
- ;; previously displayed buffer may under certain
- ;; circumstances be displayed.
- (clear-cache pane)
(setf (offset (point (buffer pane))) (offset (point pane))
(buffer (current-window)) buffer
(syntax buffer) (make-instance (syntax-class-name-for-filepath filepath)
--- /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/06/12 19:10:58 1.19
+++ /project/climacs/cvsroot/climacs/cl-syntax.lisp 2006/09/02 21:43:56 1.20
@@ -111,7 +111,7 @@
(make-instance 'other-entry))))))))
-(define-syntax cl-syntax (basic-syntax)
+(define-syntax cl-syntax (fundamental-syntax)
((lexer :reader lexer)
(valid-parse :initform 1)
(parser))
More information about the Climacs-cvs
mailing list