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))