mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 09 Jan '08

09 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv28792/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax.lisp lr-syntax.lisp packages.lisp Log Message: Improved performance of LR syntax, and Lisp syntax's handling of non-character buffer objects. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/09 08:55:24 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/09 11:14:08 1.12 @@ -588,7 +588,7 @@ (operands (when (and form (form-list-p form)) (mapcar #'(lambda (operand) (when operand - (form-to-object syntax operand))) + (form-to-object syntax operand :no-error t))) (form-operands syntax form)))) (current-operand-indices (when form (find-operand-info syntax offset form)))) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/09 08:55:24 1.61 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/09 11:14:08 1.62 @@ -2571,9 +2571,11 @@ (defun invoke-reader (syntax form) "Use the system reader to handle `form' and signal a `reader-invoked' condition with the resulting data." - (let* ((start-mark (make-buffer-mark (buffer syntax) (start-offset form)))) + (let* ((start-mark (make-buffer-mark (buffer syntax) (start-offset form))) + (end-mark (make-buffer-mark (buffer syntax) (end-offset form)))) (let* ((stream (make-buffer-stream :buffer (buffer syntax) - :start-mark start-mark)) + :start-mark start-mark + :end-mark end-mark)) (object (read-preserving-whitespace stream))) (signal 'reader-invoked :end-mark (point stream) :object object)))) @@ -2920,7 +2922,10 @@ (defmethod form-to-object ((syntax lisp-syntax) (form complete-string-form) &key &allow-other-keys) - (invoke-reader syntax form)) + (if (notany #'literal-object-p (children form)) + (invoke-reader syntax form) + (form-conversion-error + syntax form "String form contains non-character element"))) (defmethod form-to-object ((syntax lisp-syntax) (form function-form) &rest args) (list 'cl:function (apply #'form-to-object syntax (second (children form)) args))) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/09 08:55:24 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/09 11:14:08 1.16 @@ -99,6 +99,11 @@ (:documentation "Mixin for parser symbols representing literal (non-character) objects in the buffer.")) +(defun literal-object-p (parser-symbol) + "Return true if `parser-symbol' is of type +`literal-object-mixin'." + (typep parser-symbol 'literal-object-mixin)) + (defmethod start-offset ((state parser-symbol)) (let ((mark (start-mark state))) (when mark @@ -378,7 +383,7 @@ (parser-state stack-top) stack-top))) (loop do (parse-patch syntax))))) - (values 0 (offset (scan syntax))))) + (values 0 (size (buffer syntax))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:55:11 1.37 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/09 11:14:08 1.38 @@ -515,7 +515,7 @@ #:parser-symbol #:parent #:children #:start-offset #:end-offset #:parser-state #:preceding-parse-tree - #:literal-object-mixin + #:literal-object-mixin #:literal-object-p #:define-parser-state #:lexeme #:nonterminal #:action #:new-state #:done

1 0

[mcclim-cvs] CVS mcclim/Extensions/Images
by thenriksen 09 Jan '08

09 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv14506/Extensions/Images Modified Files: gif.lisp Log Message: Handle GIFs with no transparency. --- /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/07 14:18:15 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/09 10:20:23 1.3 @@ -26,8 +26,9 @@ (pattern-array (make-array (list (skippy:height first-image) (skippy:width first-image)))) (designs (coerce (loop with color-table = (skippy:color-table data-stream) + with transparency-index = (skippy:transparency-index first-image) for i below (skippy:color-table-size color-table) - when (= i (skippy:transparency-index first-image)) + when (and transparency-index (= i transparency-index)) collect +transparent-ink+ else collect (multiple-value-bind (r g b)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 09 Jan '08

09 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv30926/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax.lisp lr-syntax.lisp Log Message: Do less incrementality-pretending in Lr syntax, but be more aware of the possibility in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2007/12/16 14:42:07 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/09 08:55:24 1.11 @@ -566,7 +566,7 @@ provided are, in order: the form, the forms operator, the indices to the operand at `offset', or the indices to an operand entered at that position if none is there, and the operands in the form." - (update-parse syntax 0 offset) + (update-parse syntax) (let* ((form ;; Find a form with a valid (fboundp) operator. (let ((immediate-form --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/08 21:16:16 1.60 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/09 08:55:24 1.61 @@ -1209,7 +1209,6 @@ (defun need-to-update-package-list-p (prefix-size suffix-size syntax) (let ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) - (update-parse syntax) (flet ((test (x) (let ((start-offset (start-offset x)) (end-offset (end-offset x))) @@ -1249,17 +1248,18 @@ (defun update-package-list (syntax) (setf (package-list syntax) nil) + (update-parse syntax) (flet ((test (x) (when (form-list-p x) (let ((candidate (first-form (children x)))) (and (form-token-p candidate) (eq (form-to-object syntax candidate - :no-error t) + :no-error t) 'cl:in-package))))) (extract (x) (let ((designator (second-form (children x)))) (form-to-object syntax designator - :no-error t)))) + :no-error t)))) (with-slots (stack-top) syntax (loop for child in (children stack-top) when (test child) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/08 21:05:50 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/09 08:55:24 1.15 @@ -267,8 +267,7 @@ (print-unreadable-object (mark stream :type t :identity t) (format stream "~s" (offset mark)))) -(defun parse-patch (syntax begin end) - (declare (ignore begin)) +(defun parse-patch (syntax) (with-slots (current-state stack-top scan potentially-valid-trees) syntax (parser-step syntax) (finish-output *trace-output*) @@ -359,12 +358,13 @@ (defmethod update-syntax values-max-min ((syntax lr-syntax-mixin) prefix-size suffix-size &optional (begin 0) (end (size (buffer syntax)))) + (declare (ignore begin end)) (let* ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) (when (<= low-mark-offset high-mark-offset) (catch 'done - (with-slots (current-state stack-top scan potentially-valid-trees - initial-state) syntax + (with-slots (current-state stack-top scan potentially-valid-trees + initial-state) syntax (setf potentially-valid-trees (if (null stack-top) nil @@ -373,12 +373,12 @@ (setf stack-top (find-last-valid-lexeme stack-top low-mark-offset)) (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top)) current-state (if (null stack-top) - initial-state + initial-state (new-state syntax (parser-state stack-top) stack-top))) - (loop do (parse-patch syntax begin end))))) - (values 0 end))) + (loop do (parse-patch syntax))))) + (values 0 (offset (scan syntax))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Jan '08

08 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12250/Drei Modified Files: lisp-syntax.lisp Log Message: So, as long as I'm just pretending to be clever at reparsing, I might as well reactivate package handling in the old, inefficient way. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/08 21:05:50 1.59 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/08 21:16:16 1.60 @@ -1209,31 +1209,32 @@ (defun need-to-update-package-list-p (prefix-size suffix-size syntax) (let ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) + (update-parse syntax) (flet ((test (x) (let ((start-offset (start-offset x)) (end-offset (end-offset x))) - (when (and (or (<= start-offset - low-mark-offset - end-offset - high-mark-offset) - (<= low-mark-offset - start-offset - high-mark-offset - end-offset) - (<= low-mark-offset - start-offset - end-offset - high-mark-offset) - (<= start-offset - low-mark-offset - high-mark-offset - end-offset)) - (typep x 'complete-list-form)) - (let ((candidate (first-form (children x)))) - (and (form-token-p candidate) - (eq (form-to-object syntax candidate - :no-error t) - 'cl:in-package))))))) + (when (and (or (<= start-offset + low-mark-offset + end-offset + high-mark-offset) + (<= low-mark-offset + start-offset + high-mark-offset + end-offset) + (<= low-mark-offset + start-offset + end-offset + high-mark-offset) + (<= start-offset + low-mark-offset + high-mark-offset + end-offset)) + (typep x 'complete-list-form)) + (let ((candidate (first-form (children x)))) + (and (form-token-p candidate) + (eq (form-to-object syntax candidate + :no-error t) + 'cl:in-package))))))) (with-slots (stack-top) syntax (or (not (slot-boundp syntax '%package-list)) (loop @@ -1272,9 +1273,8 @@ (setf (form-before-cache syntax) (make-hash-table :test #'equal) (form-after-cache syntax) (make-hash-table :test #'equal) (form-around-cache syntax) (make-hash-table :test #'equal)) - #+nil(when (need-to-update-package-list-p prefix-size suffix-size syntax) - (update-package-list syntax)) - (setf (package-list syntax) nil)) + (when (need-to-update-package-list-p prefix-size suffix-size syntax) + (update-package-list syntax))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Jan '08

08 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9990/Drei Modified Files: lisp-syntax.lisp lr-syntax.lisp views.lisp Log Message: Pretend to to incremental reparse for Lr syntaxes. This required some fixed in the view mechanism, and doesn't affect much yet. Except that I had to disable intelligent package-handling in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 23:00:51 1.58 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/08 21:05:50 1.59 @@ -1272,8 +1272,9 @@ (setf (form-before-cache syntax) (make-hash-table :test #'equal) (form-after-cache syntax) (make-hash-table :test #'equal) (form-around-cache syntax) (make-hash-table :test #'equal)) - (when (need-to-update-package-list-p prefix-size suffix-size syntax) - (update-package-list syntax))) + #+nil(when (need-to-update-package-list-p prefix-size suffix-size syntax) + (update-package-list syntax)) + (setf (package-list syntax) nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:55:11 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/08 21:05:50 1.14 @@ -267,30 +267,31 @@ (print-unreadable-object (mark stream :type t :identity t) (format stream "~s" (offset mark)))) -(defun parse-patch (syntax) +(defun parse-patch (syntax begin end) + (declare (ignore begin)) (with-slots (current-state stack-top scan potentially-valid-trees) syntax - (parser-step syntax) - (finish-output *trace-output*) - (cond ((parse-tree-equal stack-top potentially-valid-trees) - (unless (or (null (parent potentially-valid-trees)) - (eq potentially-valid-trees - (car (last (children (parent potentially-valid-trees)))))) - (loop for tree = (cadr (member potentially-valid-trees - (children (parent potentially-valid-trees)) - :test #'eq)) - then (car (children tree)) - until (null tree) - do (setf (slot-value tree 'preceding-parse-tree) - stack-top)) - (setf stack-top (prev-tree (parent potentially-valid-trees)))) - (setf potentially-valid-trees (parent potentially-valid-trees)) - (setf current-state (new-state syntax (parser-state stack-top) stack-top)) - (setf (offset scan) (end-offset stack-top))) - (t (loop until (or (null potentially-valid-trees) - (>= (start-offset potentially-valid-trees) - (end-offset stack-top))) - do (setf potentially-valid-trees - (next-tree potentially-valid-trees))))))) + (parser-step syntax) + (finish-output *trace-output*) + (cond ((parse-tree-equal stack-top potentially-valid-trees) + (unless (or (null (parent potentially-valid-trees)) + (eq potentially-valid-trees + (car (last (children (parent potentially-valid-trees)))))) + (loop for tree = (cadr (member potentially-valid-trees + (children (parent potentially-valid-trees)) + :test #'eq)) + then (car (children tree)) + until (null tree) + do (setf (slot-value tree 'preceding-parse-tree) + stack-top)) + (setf stack-top (prev-tree (parent potentially-valid-trees)))) + (setf potentially-valid-trees (parent potentially-valid-trees)) + (setf current-state (new-state syntax (parser-state stack-top) stack-top)) + (setf (offset scan) (end-offset stack-top))) + (t (loop until (or (null potentially-valid-trees) + (>= (start-offset potentially-valid-trees) + (end-offset stack-top))) + do (setf potentially-valid-trees + (next-tree potentially-valid-trees))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -357,8 +358,7 @@ ;;; update syntax (defmethod update-syntax values-max-min ((syntax lr-syntax-mixin) prefix-size suffix-size - &optional begin end) - (declare (ignore begin end)) + &optional (begin 0) (end (size (buffer syntax)))) (let* ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) (when (<= low-mark-offset high-mark-offset) @@ -377,8 +377,8 @@ (new-state syntax (parser-state stack-top) stack-top))) - (loop do (parse-patch syntax)))))) - (values 0 (size (buffer syntax)))) + (loop do (parse-patch syntax begin end))))) + (values 0 end))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -496,7 +496,7 @@ (defmethod pump-state-for-offset-with-syntax ((view textual-drei-syntax-view) (syntax lr-syntax-mixin) (offset integer)) - (update-parse syntax 0 offset) + (update-parse syntax 0 (size (buffer view))) (let ((parser-symbol (parser-symbol-containing-offset syntax offset)) (highlighting-rules (syntax-highlighting-rules syntax))) (labels ((initial-drawing-options (parser-symbol) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/08 19:53:28 1.14 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/08 21:05:50 1.15 @@ -657,8 +657,7 @@ (when (or (and (> begin (prefix-size view)) (> high-offset begin)) (and (> end (prefix-size view)) - (or (> end high-offset) - (>= (prefix-size view) begin))) + (>= (prefix-size view) begin)) (/= (size (buffer view)) (buffer-size view)) force-p) (call-next-method)))) @@ -673,12 +672,14 @@ (suffix-size (suffix-size view))) ;; Set some minimum values here so if `update-syntax' calls ;; `update-parse' itself, we won't end with infinite recursion. - (setf (prefix-size view) (if (> begin prefix-size) - prefix-size - end) - (suffix-size view) (if (>= end (- (size (buffer view)) suffix-size)) - (- (size (buffer view)) (prefix-size view)) - suffix-size) + (setf (prefix-size view) (max (if (> begin prefix-size) + prefix-size + end) + prefix-size) + (suffix-size view) (max (if (>= end (- (size (buffer view)) suffix-size)) + (max (- (size (buffer view)) begin) suffix-size) + suffix-size) + suffix-size) (buffer-size view) (size (buffer view))) (multiple-value-bind (parsed-start parsed-end) (update-syntax (syntax view) prefix-size suffix-size begin end)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Jan '08

08 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21319/Drei Modified Files: views.lisp Log Message: Made the view mechanisms more capable of handling incremental/lazy parsing. Still haven't been able to create a lazy LR parser. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/07 22:01:58 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/08 19:53:28 1.14 @@ -616,24 +616,15 @@ view-syntax (make-syntax-for-view view (class-of view-syntax)) prefix-size 0 suffix-size 0 - buffer-size (size buffer) + buffer-size -1 ; For reparse even if buffer is empty. ;; Also set the top and bot marks. top (make-buffer-mark buffer 0 :left) - bot (make-buffer-mark buffer (size buffer) :right)) - ;; We resynchronize here, instead of delaying a potentially large - ;; reparse until the next time some hapless command (or redisplay - ;; function) needs a parse tree. Force the resynchronisation so - ;; that even if the buffer is empty, `update-syntax' will still be - ;; called. - (synchronize-view view :force-p t))) + bot (make-buffer-mark buffer (size buffer) :right)))) (defmethod (setf syntax) :after (syntax (view drei-syntax-view)) - ;; We need to reparse the buffer completely. Might as well do it - ;; now. (setf (prefix-size view) 0 (suffix-size view) 0 - (buffer-size view) (size (buffer view))) - (synchronize-view view :force-p t)) + (buffer-size view) -1)) (defmethod mode-enabled-p or ((modual drei-syntax-view) mode-name) (mode-enabled-p (syntax modual) mode-name)) @@ -660,10 +651,14 @@ (defmethod synchronize-view :around ((view drei-syntax-view) &key force-p (begin 0) (end (size (buffer view)))) + (assert (>= end begin)) ;; If nothing changed, then don't call the other methods. (let ((high-offset (- (size (buffer view)) (suffix-size view)))) - (when (or (and (>= begin (prefix-size view)) - (>= high-offset end)) + (when (or (and (> begin (prefix-size view)) + (> high-offset begin)) + (and (> end (prefix-size view)) + (or (> end high-offset) + (>= (prefix-size view) begin))) (/= (size (buffer view)) (buffer-size view)) force-p) (call-next-method)))) @@ -687,10 +682,17 @@ (buffer-size view) (size (buffer view))) (multiple-value-bind (parsed-start parsed-end) (update-syntax (syntax view) prefix-size suffix-size begin end) - ;; Not set the proper new values for prefix-size and + (assert (>= parsed-end parsed-start)) + ;; Now set the proper new values for prefix-size and ;; suffix-size. - (setf (prefix-size view) parsed-end - (suffix-size view) (- (size (buffer view)) parsed-start))) + (setf (prefix-size view) (max (if (>= prefix-size parsed-start) + parsed-end + prefix-size) + prefix-size) + (suffix-size view) (max (if (>= parsed-end (- (size (buffer view)) suffix-size)) + (- (size (buffer view)) parsed-start) + suffix-size) + suffix-size))) (call-next-method))) (defun make-syntax-for-view (view syntax-symbol &rest args)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 08 Jan '08

08 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv649/Drei Modified Files: drei-redisplay.lisp Log Message: Try harder to only redraw the strokes that have actually changed. I think this should improve redisplay performance by 30-40% (when changing the buffer), but I don't want to affect the result by measuring it. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/07 20:23:45 1.22 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/08 14:52:18 1.23 @@ -191,7 +191,7 @@ `stroke' are actually live, and how many are old, stale objects to prevent the need for consing if new strokes are added to the line." - (start-offset) + (start-offset 0) (end-offset) (dimensions (make-dimensions)) (strokes (make-array 0 :adjustable t)) @@ -214,21 +214,6 @@ valid past the next call to `stroke-pump' or `synchronize-view'. It is permissible for `pump-state' to be destructively modified by this function.") - (:method :around ((view drei-buffer-view) stroke pump-state) - ;; `call-next-method' for the next pump state, and compare - ;; the new stroke data with the old one. If it has changed, - ;; mark the stroke as dirty and modified. - (let ((old-start-offset (stroke-start-offset stroke)) - (old-end-offset (stroke-end-offset stroke)) - (old-drawing-options (stroke-drawing-options stroke)) - (new-pump-state (call-next-method))) - (unless (and old-start-offset - (= old-start-offset (stroke-start-offset stroke)) - (= old-end-offset (stroke-end-offset stroke)) - (drawing-options-equal old-drawing-options - (stroke-drawing-options stroke))) - (invalidate-stroke stroke :modified t)) - new-pump-state)) (:method ((view drei-syntax-view) stroke pump-state) (stroke-pump-with-syntax view (syntax view) stroke pump-state))) @@ -372,12 +357,23 @@ some point)." (aref (line-strokes line) (1- (line-stroke-count line)))) -(defun put-stroke (view line pump-state) +(defun put-stroke (view line pump-state line-change) "Use `stroke-pump' with `pump-state' to get a new stroke for `view', and add it to the sequence of displayed strokes in -`line'." - (let* ((stroke (line-stroke-information line (line-stroke-count line)))) +`line'. `Line-change' should be a relative offset specifying how +much the start-offset of `line' has changed since the last time +it was redisplayed." + (let* ((stroke (line-stroke-information line (line-stroke-count line))) + (old-start-offset (stroke-start-offset stroke)) + (old-end-offset (stroke-end-offset stroke)) + (old-drawing-options (stroke-drawing-options stroke))) (prog1 (stroke-pump view stroke pump-state) + (unless (and old-end-offset + (= (+ old-start-offset line-change) (stroke-start-offset stroke)) + (= (+ old-end-offset line-change) (stroke-end-offset stroke)) + (drawing-options-equal old-drawing-options + (stroke-drawing-options stroke))) + (invalidate-stroke stroke :modified t)) (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) @@ -517,14 +513,15 @@ (let* ((line (line-information view (displayed-lines-count view))) (old-line-height (dimensions-height (line-dimensions line))) (old-line-width (dimensions-width (line-dimensions line))) - (orig-x-offset cursor-x)) + (orig-x-offset cursor-x) + (offset-change (- start-offset (line-start-offset line)))) (setf (line-start-offset line) start-offset (line-stroke-count line) 0) (loop for index from 0 for stroke = (line-stroke-information line index) for stroke-dimensions = (stroke-dimensions stroke) - for pump-state = (put-stroke view line initial-pump-state) then - (put-stroke view line pump-state) + for pump-state = (put-stroke view line initial-pump-state offset-change) then + (put-stroke view line pump-state offset-change) do (draw-stroke stream view stroke cursor-x cursor-y) (setf cursor-x (x2 stroke-dimensions)) maximizing (dimensions-height stroke-dimensions) into line-height

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 07 Jan '08

07 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv25009/Drei Modified Files: drawing-options.lisp lisp-syntax.lisp Log Message: Removed references to nonexisting +italic-face-style+. --- /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 22:55:11 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 23:00:51 1.3 @@ -80,7 +80,7 @@ (defvar *string-drawing-options* (make-drawing-options :face (make-face :ink +rosy-brown+ - :style +italic-face-style+)) + :style (make-text-style nil :italic nil))) "The drawing options used for syntax-highlighting strings.") (defvar *comment-drawing-options* (make-drawing-options --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:55:11 1.57 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 23:00:51 1.58 @@ -1854,7 +1854,7 @@ (define-syntax-highlighting-rules retro-highlighting (error-symbol (*error-drawing-options*)) - (string-form (:face :style +italic-face-style+)) + (string-form (:options :face +italic-face+)) (comment (:face :ink +dimgray+)) (literal-object-form (:options :function (object-drawer))) (complete-token-form (:function #'(lambda (syntax form)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 07 Jan '08

07 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22310/Drei Modified Files: drawing-options.lisp lisp-syntax.lisp lr-syntax.lisp packages.lisp Log Message: My last commit was a broken monster, here's the rest. --- /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 22:37:17 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 22:55:11 1.2 @@ -57,7 +57,9 @@ ;;; Some drawing options for specific syntactical elements, ;;; approximately like GNU Emacs. These are not constants, as users -;;; may want to change them to fit their colour scheme. +;;; may want to change them to fit their colour scheme. Of course, +;;; syntax highlighting rules are free to ignore these, but I think +;;; the default rules should at least use these. (defvar *keyword-drawing-options* (make-drawing-options :face (make-face :ink +orchid+)) "The drawing options used for drawing the syntactical @@ -75,3 +77,17 @@ somehow special. In Lisp, this is used for globally bound non-constant variables with dynamic scope. In other language, it should probably be used for global variables or similar.") + +(defvar *string-drawing-options* (make-drawing-options + :face (make-face :ink +rosy-brown+ + :style +italic-face-style+)) + "The drawing options used for syntax-highlighting strings.") + +(defvar *comment-drawing-options* (make-drawing-options + :face (make-face :ink +maroon+ + :style (make-text-style nil :bold nil))) + "The drawing options used for drawing comments in source +code.") + +(defvar *error-drawing-options* (make-drawing-options :face (make-face :ink +red+)) + "The drawing options used for drawing syntax errors.") --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:37:17 1.56 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:55:11 1.57 @@ -1832,10 +1832,9 @@ (global-boundp symbol-form)))) (define-syntax-highlighting-rules emacs-style-highlighting - (error-lexeme (:face :ink +red+)) - (string-form (:face :ink +rosy-brown+ - :style +italic-face-style+)) - (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) + (error-lexeme (*error-drawing-options*)) + (string-form (*string-drawing-options*)) + (comment (*comment-drawing-options*)) (literal-object-form (:options :function (object-drawer))) (complete-token-form (:function #'(lambda (view form) (cond ((symbol-form-is-keyword-p (syntax view) form) @@ -1854,14 +1853,22 @@ +default-drawing-options+))))) (define-syntax-highlighting-rules retro-highlighting - (error-symbol (:face :ink +red+)) + (error-symbol (*error-drawing-options*)) (string-form (:face :style +italic-face-style+)) (comment (:face :ink +dimgray+)) (literal-object-form (:options :function (object-drawer))) (complete-token-form (:function #'(lambda (syntax form) (cond ((symbol-form-is-macrobound-p syntax form) +bold-face-drawing-options+) - (t +default-drawing-options+)))))) + (t +default-drawing-options+))))) + ;; XXX: Ugh, copied from above. + (parenthesis-lexeme (:function #'(lambda (view form) + (if (and (typep view 'point-mark-view) + (or (mark= (point view) (start-offset (parent form))) + (mark= (point view) (end-offset (parent form)))) + (form-complete-p (parent form))) + +bold-face-drawing-options+ + +default-drawing-options+))))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting "The syntax highlighting rules used for highlighting Lisp --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:05:22 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:55:11 1.13 @@ -420,7 +420,7 @@ `parser-symbol' is a type that might be encountered in a parse tree for the syntax. The rule specifies how to highlight that kind of object (and all its children). `Type' can be one of three -symbols. +special symbols. `:face', in which case `args' will be used as arguments to a call to `make-face'. The resulting face will be used to draw @@ -434,7 +434,11 @@ function that takes two arguments. These arguments are the view of the syntax and the parser symbol, and the return value of this function is the `drawing-options' object that will be used - to draw the parser-symbol." + to draw the parser-symbol. + +Alternatively, `type' can be any object (usually a dynamically +bound symbol), in which case it will be evaluated to get the +drawing options." (check-type name symbol) `(progn (fmakunbound ',name) @@ -442,7 +446,7 @@ (:method (view (parser-symbol parser-symbol)) nil)) ,@(flet ((make-rule-exp (type args) - (ecase type + (case type (:face `(let ((options (make-drawing-options :face (make-face ,@args)))) #'(lambda (view parser-symbol) (declare (ignore view parser-symbol)) @@ -450,7 +454,10 @@ (:options `#'(lambda (view parser-symbol) (declare (ignore view parser-symbol)) (make-drawing-options ,@args))) - (:function (first args))))) + (:function (first args)) + (t `#'(lambda (view parser-symbol) + (declare (ignore view parser-symbol)) + ,type))))) (loop for (parser-symbol (type . args)) in rules collect `(let ((rule ,(make-rule-exp type args))) (defmethod ,name (view (parser-symbol ,parser-symbol)) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:37:17 1.36 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:55:11 1.37 @@ -270,6 +270,9 @@ #:*keyword-drawing-options* #:*special-operator-drawing-options* #:*special-variable-drawing-options* + #:*string-drawing-options* + #:*comment-drawing-options* + #:*error-drawing-options* ;; DREI program interface stuff. #:with-drei-options

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 07 Jan '08

07 Jan '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22310 Modified Files: mcclim.asd Log Message: My last commit was a broken monster, here's the rest. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/06 16:05:46 1.72 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/07 22:55:11 1.73 @@ -299,6 +299,7 @@ (:file "drei" :depends-on ("packages" "views" "motion" "editing")) (:file "drei-clim" :depends-on ("drei")) (:file "drei-redisplay" :depends-on ("drei-clim")) + (:file "drawing-options" :depends-on ("drei-redisplay")) (:file "input-editor" :depends-on ("drei-redisplay" "lisp-syntax" "core")) (:file "abbrev" :depends-on ("packages")) (:file "kill-ring" :depends-on ("packages")) @@ -321,7 +322,7 @@ (:file "misc-commands" :depends-on ("basic-commands")) (:file "unicode-commands" :depends-on ("core" "drei-clim")) (:file "search-commands" :depends-on ("core" "targets" "drei-clim")) - (:file "lr-syntax" :depends-on ("fundamental-syntax" "core")) + (:file "lr-syntax" :depends-on ("fundamental-syntax" "core" "drawing-options")) (:file "lisp-syntax" :depends-on ("lr-syntax" "motion" "core")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "misc-commands"))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs