Commit 986fed5e authored by Troels Henriksen's avatar Troels Henriksen
Browse files

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.
parent a3215d4d
......@@ -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))
......
......@@ -459,7 +459,7 @@ spaces only."))
: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 @@ spaces only."))
(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)
......
......@@ -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
......
......@@ -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))
......
......@@ -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)
......
......@@ -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))
......
......@@ -260,7 +260,7 @@ is made to alter a buffer which has been set read only."))
(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 @@ is made to alter a buffer which has been set read only."))
(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 @@ is made to alter a buffer which has been set read only."))
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 @@ is made to alter a buffer which has been set read only."))
(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)