mcclim-cvs January 2008

mcclim-cvs@common-lisp.net

7 participants
255 discussions

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

04 Jan '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv32029/ESA Modified Files: esa-command-parser.lisp Log Message: Restored evaluating of arguments to ESA commands. --- /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2007/12/27 20:31:56 1.3 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2008/01/04 21:56:29 1.4 @@ -123,6 +123,6 @@ (esa-parse-one-arg stream name ptype args)) ((eq command-arg *numeric-argument-marker*) (or numeric-argument (getf args :default))) - (t command-arg)) + (t (eval command-arg))) result) (maybe-clear-input)))))))))))

1 0

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

04 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31757/Drei Modified Files: lisp-syntax.lisp Log Message: Restored the Red Menace to syntax errors. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/04 21:11:36 1.47 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/04 21:55:45 1.48 @@ -1827,7 +1827,7 @@ (macro-drawing-options (make-drawing-options :face (make-face :ink +purple+))) (bound-drawing-options (make-drawing-options :face (make-face :ink +darkgoldenrod+)))) (make-syntax-highlighting-rules emacs-style-highlighting - (error-symbol (:face :ink +red+)) + (error-lexeme (:face :ink +red+)) (string-form (:face :ink +rosy-brown+ :style (make-text-style nil :italic nil))) (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large)))

1 0

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

04 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20648/Drei Modified Files: lisp-syntax.lisp packages.lisp Log Message: Modified Lisp syntax to always convert complete-token-lexemes to complete-token-forms. Used this to implement nifty new highlighting rules for Lisp syntax. Also implemented alternative syntax highlighting rules, (setf drei-lisp-syntax:*syntax-highlighting-rules* 'drei-lisp-syntax:retro-highlighting) to enable it. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/03 21:11:40 1.46 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/04 21:11:36 1.47 @@ -309,10 +309,10 @@ (defclass pathname-start-lexeme (lisp-lexeme) ()) (defclass undefined-reader-macro-lexeme (lisp-lexeme) ()) (defclass bit-vector-form (form-lexeme complete-form-mixin) ()) -(defclass number-lexeme (complete-token-lexeme) ()) (defclass token-mixin () ()) +(defclass number-lexeme (token-mixin form-lexeme complete-form-mixin) ()) (defclass literal-object-form (form-lexeme complete-form-mixin literal-object-mixin) ()) -(defclass complete-token-lexeme (token-mixin form-lexeme complete-form-mixin) ()) +(defclass complete-token-lexeme (token-mixin lisp-lexeme) ()) (defclass multiple-escape-start-lexeme (lisp-lexeme) ()) (defclass multiple-escape-end-lexeme (lisp-lexeme) ()) (defclass incomplete-lexeme (lisp-lexeme incomplete-form-mixin) ()) @@ -845,16 +845,25 @@ ;;; parse trees (defclass token-form (form token-mixin) ()) -(defclass complete-token-form (token-form complete-form-mixin) ()) +(defclass complete-token-form (token-form complete-form-mixin) + ((%keyword-symbol-p :accessor keyword-symbol-p) + (%macroboundp :accessor macroboundp) + (%global-boundp :accessor global-boundp))) (defclass incomplete-token-form (token-form incomplete-form-mixin) ()) +(define-parser-state | complete-lexeme | (lexer-list-state parser-state) ()) (define-parser-state | m-e-start text* | (lexer-escaped-token-state parser-state) ()) (define-parser-state | m-e-start text* m-e-end | (lexer-toplevel-state parser-state) ()) +(define-new-lisp-state (form-may-follow complete-token-lexeme) | complete-lexeme |) (define-new-lisp-state (form-may-follow multiple-escape-start-lexeme) | m-e-start text* |) (define-new-lisp-state (| m-e-start text* | text-lexeme) | m-e-start text* |) (define-new-lisp-state (| m-e-start text* | multiple-escape-end-lexeme) | m-e-start text* m-e-end |) +;;; reduce according to the rule form -> complete-lexeme +(define-lisp-action (| complete-lexeme | t) + (reduce-until-type complete-token-form complete-token-lexeme)) + ;;; reduce according to the rule form -> m-e-start text* m-e-end (define-lisp-action (| m-e-start text* m-e-end | t) (reduce-until-type complete-token-form multiple-escape-start-lexeme)) @@ -1778,16 +1787,71 @@ ;;; ;;; display -;; Note that we do not colour keyword symbols or special forms yet, -;; that is because the only efficient way to do so is to mark them as -;; interesting in the parser itself, it is too slow to check for it in -;; highlighting rules. -(make-syntax-highlighting-rules emacs-style-highlighting - (error-symbol (:face :ink +red+)) - (string-form (:face :ink +rosy-brown+ - :style (make-text-style nil :italic nil))) - (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) - (literal-object-form (:options :function (object-drawer)))) +(defun cache-symbol-info (syntax symbol-form) + "Cache information about the symbol `symbol-form' represents, +so that it can be quickly looked up later." + ;; We don't use `form-to-object' as we want to retrieve information + ;; even about symbol that are not interned. + (multiple-value-bind (symbol package) + (parse-symbol (form-string syntax symbol-form) :package *package*) + (setf (keyword-symbol-p symbol-form) (eq package +keyword-package+) + (macroboundp symbol-form) (or (special-operator-p symbol) + (macro-function symbol)) + (global-boundp symbol-form) (and (boundp symbol) + (not (constantp symbol)))))) + +(defun symbol-form-is-keyword-p (syntax symbol-form) + "Return true if `symbol-form' represents a keyword symbol." + (if (slot-boundp symbol-form '%keyword-symbol-p) + (keyword-symbol-p symbol-form) + (progn (cache-symbol-info syntax symbol-form) + (keyword-symbol-p symbol-form)))) + +(defun symbol-form-is-macrobound-p (syntax symbol-form) + "Return true if `symbol-form' represents a symbol bound to a +macro or special form." + (if (slot-boundp symbol-form '%macroboundp) + (macroboundp symbol-form) + (progn (cache-symbol-info syntax symbol-form) + (macroboundp symbol-form)))) + +(defun symbol-form-is-boundp (syntax symbol-form) + "Return true if `symbol-form' represents a symbol that is +`boundp' and is not a constant." + (if (slot-boundp symbol-form '%global-boundp) + (global-boundp symbol-form) + (progn (cache-symbol-info syntax symbol-form) + (global-boundp symbol-form)))) + +(let ((keyword-drawing-options (make-drawing-options :face (make-face :ink +orchid+))) + (macro-drawing-options (make-drawing-options :face (make-face :ink +purple+))) + (bound-drawing-options (make-drawing-options :face (make-face :ink +darkgoldenrod+)))) + (make-syntax-highlighting-rules emacs-style-highlighting + (error-symbol (:face :ink +red+)) + (string-form (:face :ink +rosy-brown+ + :style (make-text-style nil :italic nil))) + (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) + (literal-object-form (:options :function (object-drawer))) + (complete-token-form (:function #'(lambda (syntax form) + (cond ((symbol-form-is-keyword-p syntax form) + keyword-drawing-options) + ((symbol-form-is-macrobound-p syntax form) + macro-drawing-options) + ((symbol-form-is-boundp syntax form) + bound-drawing-options) + (t +default-drawing-options+))))))) + +(let ((macro-drawing-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) + (make-syntax-highlighting-rules retro-highlighting + (error-symbol (:face :ink +red+)) + (string-form (:face :style (make-text-style nil :italic nil))) + (comment (:face :style (make-text-style nil nil nil) + :ink +dimgray+)) + (literal-object-form (:options :function (object-drawer))) + (complete-token-form (:function #'(lambda (syntax form) + (cond ((symbol-form-is-macrobound-p syntax form) + macro-drawing-options) + (t +default-drawing-options+))))))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting "The syntax highlighting rules used for highlighting Lisp @@ -2798,16 +2862,6 @@ ;;; The atom(-ish) forms. -(defmethod form-to-object ((syntax lisp-syntax) (form complete-token-lexeme) - &key read (case (readtable-case *readtable*)) - &allow-other-keys) - (multiple-value-bind (symbol package status) - (parse-symbol (form-string syntax form) - :package *package* :case case) - (values (cond ((and read (null status)) - (intern (symbol-name symbol) package)) - (t symbol))))) - (defmethod form-to-object ((syntax lisp-syntax) (form complete-token-form) &key read (case (readtable-case *readtable*)) &allow-other-keys) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/03 12:32:08 1.30 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/04 21:11:39 1.31 @@ -608,7 +608,12 @@ ;; Conditions. #:form-conversion-error - #:invalid-lambda-list) + #:invalid-lambda-list + + ;; Configuration + #:*syntax-highlighting-rules* + #:emacs-style-highlighting + #:retro-highlighting) (:shadow clim:form) (:documentation "Implementation of the syntax module used for editing Common Lisp code."))

1 0

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

04 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23422/Drei Modified Files: lr-syntax.lisp Log Message: Don't use the drawing options of the stack-top in Drei. This solves a problem where pretty much the entire buffer would be drawn a beautiful shade of bright red when a syntax error occured. I think the Right Thing is to make Lisp syntax a little more intelligent with respect to syntax errors. --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/03 21:11:40 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/04 14:12:48 1.9 @@ -91,6 +91,10 @@ (preceding-parse-tree :initform nil :reader preceding-parse-tree) (parser-state :initform nil :initarg :parser-state :reader parser-state))) +(defmethod print-object ((object parser-symbol) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "~s ~s" (start-offset object) (end-offset object)))) + (defclass literal-object-mixin () () (:documentation "Mixin for parser symbols representing literal (non-character) objects in the buffer.")) @@ -118,10 +122,6 @@ (defclass lexeme (parser-symbol) ()) -(defmethod print-object ((lexeme lexeme) stream) - (print-unreadable-object (lexeme stream :type t :identity t) - (format stream "~s ~s" (start-offset lexeme) (end-offset lexeme)))) - (defclass nonterminal (parser-symbol) ()) (defmethod initialize-instance :after ((parser-symbol nonterminal) &rest args) @@ -467,8 +467,8 @@ (defun get-drawing-options (highlighting-rules syntax parse-symbol) "Get the drawing options with which `parse-symbol' should be -drawn. If `parse-symbol' is NIL, return NIL." - (when parse-symbol +drawn. If `parse-symbol' or the stack-top of syntax, return NIL." + (when (and parse-symbol (not (eq (stack-top syntax) parse-symbol))) (funcall highlighting-rules syntax parse-symbol))) (defstruct (pump-state @@ -535,7 +535,7 @@ (finish (line-end-offset line) start-symbol)) ((and (typep symbol 'literal-object-mixin)) (finish (start-offset symbol) symbol - (or (get-drawing-options highlighting-rules syntax symbol) + (or symbol-drawing-options (make-drawing-options :function (object-drawer))))) ((and (> (start-offset symbol) offset) (not (drawing-options-equal (or symbol-drawing-options

1 0

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

03 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29822/Drei Modified Files: lisp-syntax.lisp lr-syntax.lisp Log Message: Improved support for non-character buffer objects. Now treated properly by Lisp syntax, and hopefully properly displayed by LR syntax code. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/03 12:32:08 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/03 21:11:40 1.46 @@ -275,6 +275,7 @@ (face))) (defclass error-lexeme (lisp-lexeme) ()) +(defclass literal-object-lexeme (lisp-lexeme literal-object-mixin) ()) (defclass left-parenthesis-lexeme (lisp-lexeme) ()) (defclass simple-vector-start-lexeme (lisp-lexeme) ()) (defclass right-parenthesis-lexeme (lisp-lexeme) ()) @@ -295,6 +296,7 @@ (defclass string-end-lexeme (lisp-lexeme) ()) (defclass word-lexeme (lisp-lexeme) ()) (defclass delimiter-lexeme (lisp-lexeme) ()) +(defclass literal-object-delimiter-lexeme (delimiter-lexeme literal-object-lexeme) ()) (defclass text-lexeme (lisp-lexeme) ()) (defclass sharpsign-equals-lexeme (lisp-lexeme) ()) (defclass sharpsign-sharpsign-form (form-lexeme complete-form-mixin) ()) @@ -309,7 +311,7 @@ (defclass bit-vector-form (form-lexeme complete-form-mixin) ()) (defclass number-lexeme (complete-token-lexeme) ()) (defclass token-mixin () ()) -(defclass literal-object-form (form-lexeme complete-form-mixin) ()) +(defclass literal-object-form (form-lexeme complete-form-mixin literal-object-mixin) ()) (defclass complete-token-lexeme (token-mixin form-lexeme complete-form-mixin) ()) (defclass multiple-escape-start-lexeme (lisp-lexeme) ()) (defclass multiple-escape-end-lexeme (lisp-lexeme) ()) @@ -473,7 +475,10 @@ (not (constituentp (object-after scan)))) do (fo)) (make-instance 'word-lexeme)) - (t (fo) (make-instance 'delimiter-lexeme)))))) + (t (fo) (make-instance + (if (characterp object) + 'delimiter-lexeme + 'literal-object-delimiter-lexeme))))))) (defmethod lex ((syntax lisp-syntax) (state lexer-long-comment-state) scan) (flet ((fo () (forward-object scan))) @@ -495,7 +500,10 @@ (not (constituentp (object-after scan)))) do (fo)) (make-instance 'word-lexeme)) - (t (fo) (make-instance 'delimiter-lexeme)))))) + (t (fo) (make-instance + (if (characterp object) + 'delimiter-lexeme + 'literal-object-delimiter-lexeme))))))) (defmethod skip-inter ((syntax lisp-syntax) (state lexer-line-comment-state) scan) (macrolet ((fo () `(forward-object scan))) @@ -513,7 +521,10 @@ (not (constituentp (object-after scan)))) do (fo)) (make-instance 'word-lexeme)) - (t (fo) (make-instance 'delimiter-lexeme))))) + (t (fo) (make-instance + (if (characterp (object-before scan)) + 'delimiter-lexeme + 'literal-object-delimiter-lexeme)))))) (defun lex-token (syntax scan) ;; May need more work. Can recognize symbols and numbers. This can @@ -1775,7 +1786,8 @@ (error-symbol (:face :ink +red+)) (string-form (:face :ink +rosy-brown+ :style (make-text-style nil :italic nil))) - (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large)))) + (comment (:face :ink +maroon+ :style (make-text-style :serif :bold :large))) + (literal-object-form (:options :function (object-drawer)))) (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/03 12:32:08 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/03 21:11:40 1.8 @@ -91,6 +91,10 @@ (preceding-parse-tree :initform nil :reader preceding-parse-tree) (parser-state :initform nil :initarg :parser-state :reader parser-state))) +(defclass literal-object-mixin () () + (:documentation "Mixin for parser symbols representing +literal (non-character) objects in the buffer.")) + (defmethod start-offset ((state parser-symbol)) (let ((mark (start-mark state))) (when mark @@ -517,29 +521,39 @@ drawing-options)) (return-from find-next-stroke-end offset))) - (if (null start-symbol) - ;; This means that all remaining lines are blank. - (finish (line-end-offset line) nil) - (or (do-parse-symbols-forward (symbol offset start-symbol) - (let ((symbol-drawing-options - (get-drawing-options highlighting-rules syntax symbol))) - (cond ((> (start-offset symbol) (line-end-offset line)) - (finish (line-end-offset line) start-symbol)) - ((and (> (start-offset symbol) offset) - (not (drawing-options-equal (or symbol-drawing-options - +default-drawing-options+) - (cdr (first drawing-options))))) - (finish (start-offset symbol) symbol symbol-drawing-options)) - ((and (= (start-offset symbol) offset) - (offset-beginning-of-line-p (buffer syntax) offset) - (and symbol-drawing-options - (not (drawing-options-equal symbol-drawing-options - (cdr (first drawing-options)))))) - (finish (start-offset symbol) symbol symbol-drawing-options))))) - ;; If there are no more parse symbols, we just go - ;; line-by-line from here. This should mean that all - ;; remaining lines are blank. - (finish (line-end-offset line) nil))))))) + (cond ((null start-symbol) + ;; This means that all remaining lines are blank. + (finish (line-end-offset line) nil)) + ((and (typep start-symbol 'literal-object-mixin) + (= offset (start-offset start-symbol))) + (finish (end-offset start-symbol) start-symbol nil)) + (t + (or (do-parse-symbols-forward (symbol offset start-symbol) + (let ((symbol-drawing-options + (get-drawing-options highlighting-rules syntax symbol))) + (cond ((> (start-offset symbol) (line-end-offset line)) + (finish (line-end-offset line) start-symbol)) + ((and (typep symbol 'literal-object-mixin)) + (finish (start-offset symbol) symbol + (or (get-drawing-options highlighting-rules syntax symbol) + (make-drawing-options :function (object-drawer))))) + ((and (> (start-offset symbol) offset) + (not (drawing-options-equal (or symbol-drawing-options + +default-drawing-options+) + (cdr (first drawing-options)))) + (if (null symbol-drawing-options) + (>= (start-offset symbol) (car (first drawing-options))) + t)) + (finish (start-offset symbol) symbol symbol-drawing-options)) + ((and (= (start-offset symbol) offset) + symbol-drawing-options + (not (drawing-options-equal symbol-drawing-options + (cdr (first drawing-options))))) + (finish (start-offset symbol) symbol symbol-drawing-options))))) + ;; If there are no more parse symbols, we just go + ;; line-by-line from here. This should mean that all + ;; remaining lines are blank. + (finish (line-end-offset line) nil)))))))) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax lr-syntax-mixin) stroke

1 0

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

03 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7326/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Invalidate strokes when changing syntax, clear up to line-vertical-spacing. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/03 17:52:31 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/03 18:09:27 1.19 @@ -424,7 +424,8 @@ (values (- x2 x1) (- y2 y1) nil nil center)) (declare (ignore ignore1 ignore2 ignore3)) (clear-rectangle* stream cursor-x cursor-y - (+ cursor-x width) (+ cursor-y text-style-height)) + (+ cursor-x width) (+ cursor-y text-style-height + (stream-vertical-spacing stream))) (draw-text* stream stroke-string cursor-x (+ cursor-y (- text-style-ascent baseline)) @@ -482,7 +483,8 @@ (when (> line-height (dimensions-height stroke-dimensions)) (clear-rectangle* stream stroke-x1 stroke-y2 stroke-x2 (+ stroke-y2 (- line-height - (dimensions-height stroke-dimensions)))))))) + (dimensions-height stroke-dimensions)) + (stream-vertical-spacing stream))))))) ;; Reset the dimensions of undisplayed lines. (do-undisplayed-line-strokes (stroke line) (let ((stroke-dimensions (stroke-dimensions stroke))) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/03 16:21:20 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/03 18:09:27 1.12 @@ -548,6 +548,9 @@ (defmethod (setf buffer) :after (new-value (view drei-buffer-view)) (invalidate-all-strokes view)) +(defmethod (setf syntax) :after (new-value (view drei-buffer-view)) + (invalidate-all-strokes view :modified t)) + (defmethod cache-string :around ((view drei-buffer-view)) (let ((string (call-next-method))) (setf (fill-pointer string) 0)

1 0

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

03 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1996/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed Drei's usage of non-Freetype fonts. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/02 14:43:40 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/03 17:52:31 1.18 @@ -139,11 +139,15 @@ (defstruct (dimensions :conc-name) "A simple mutable rectangle structure. The coordinates should -be absolute coordinates in the coordinate system of a sheet." +be absolute coordinates in the coordinate system of a sheet. A +special `center' slot is also provided to enable the recording of +what might be considered a *logical* centre of the dimensions on +the vertical axis." (x1 0) (y1 0) (x2 0) - (y2 0)) + (y2 0) + (center 0)) (defun dimensions-height (dimensions) "Return the width of the provided `dimensions' object." @@ -377,7 +381,8 @@ (incf (line-stroke-count line)) (setf (line-end-offset line) (stroke-end-offset stroke))))) -(defun record-stroke (stroke x1 y1 x2 y2) +(defun record-stroke (stroke x1 y1 x2 y2 + &optional (center (/ (- y2 y1) 2))) "Record the fact that `stroke' has been drawn, and that it covers the specified area on screen. Updates the dirty- and modified-bits of `stroke' as well as the dimensions." @@ -387,7 +392,8 @@ (x1 dimensions) x1 (y1 dimensions) y1 (x2 dimensions) x2 - (y2 dimensions) y2))) + (y2 dimensions) y2 + (center dimensions) center))) (defun stroke-drawing-fn (stream view stroke cursor-x cursor-y) "Draw `stroke' to `stream' at the position (`cursor-x', @@ -403,26 +409,31 @@ (drawing-options stroke-drawing-options)) stroke (let* ((stroke-string (in-place-buffer-substring (buffer view) (cache-string view) - start-offset end-offset))) - (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2)) dimensions - (multiple-value-bind (width height) (if (stroke-modified stroke) - (text-size stream stroke-string - :text-style (merge-text-styles - (face-style (drawing-options-face drawing-options)) - (medium-merged-text-style (sheet-medium stream)))) - (values (- x2 x1) (- y2 y1))) + start-offset end-offset)) + (merged-text-style (merge-text-styles + (face-style (drawing-options-face drawing-options)) + (medium-merged-text-style (sheet-medium stream)))) + (text-style-ascent (text-style-ascent merged-text-style (sheet-medium stream))) + (text-style-descent (text-style-descent merged-text-style (sheet-medium stream))) + (text-style-height (+ text-style-ascent text-style-descent))) + (with-accessors ((x1 x1) (y1 y1) (x2 x2) (y2 y2) (center center)) dimensions + (multiple-value-bind (width ignore1 ignore2 ignore3 baseline) + (if (stroke-modified stroke) + (text-size stream stroke-string + :text-style merged-text-style) + (values (- x2 x1) (- y2 y1) nil nil center)) + (declare (ignore ignore1 ignore2 ignore3)) (clear-rectangle* stream cursor-x cursor-y - (+ cursor-x width) (+ cursor-y height - (stream-vertical-spacing stream))) - (draw-text* stream stroke-string cursor-x cursor-y - :text-style (face-style (drawing-options-face drawing-options)) + (+ cursor-x width) (+ cursor-y text-style-height)) + (draw-text* stream stroke-string cursor-x (+ cursor-y + (- text-style-ascent + baseline)) + :text-style merged-text-style :ink (face-ink (drawing-options-face drawing-options)) :align-y :top) - (record-stroke stroke cursor-x cursor-y (+ width cursor-x) - (+ (if (zerop height) - (text-style-height (medium-text-style stream) stream) - height) - cursor-y))))))) + (record-stroke stroke cursor-x cursor-y + (+ width cursor-x) (+ text-style-height cursor-y) + baseline)))))) (defun draw-stroke (stream view stroke cursor-x cursor-y line-height) "Draw `stroke' on `stream' at (`cursor-x', `cursor-y'). Nothing @@ -618,7 +629,7 @@ (draw-line-strokes pane view pump-state start-offset cursor-x cursor-y) (setf pump-state new-pump-state start-offset (1+ (line-end-offset line))) - (incf cursor-y line-height)) + (incf cursor-y (+ line-height (stream-vertical-spacing pane)))) when (or (>= (y2 (line-dimensions line)) pane-height) (= (line-end-offset line) (size (buffer view)))) return (progn

1 0

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

03 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11398/Drei Modified Files: fundamental-syntax.lisp Log Message: Fixed reparsing bug in Fundamental syntax. Because chunk offsets were absolute, and not relative to the line start mark, line information became out of date when changes were made to previous lines. --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 12:32:08 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 16:25:16 1.10 @@ -59,37 +59,50 @@ (%chunks :accessor chunks :initform (make-array 5 :adjustable t - :fill-pointer 0)))) + :fill-pointer 0) + :documentation "A list of cons-cells, with the car +being a buffer offset relative to the `start-mark' of the line, +and the cdr being T if the chunk covers a non-character, and NIL +if it covers a character sequence."))) (defun line-end-offset (line) "Return the end buffer offset of `line'." (+ (offset (start-mark line)) (line-length line))) -(defun get-chunk (buffer chunk-start-offset line-end-offset) +(defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) + "Return a chunk in the form of a cons cell. The chunk will +start at `chunk-start-offset' and extend no further than +`line-end-offset'." (let* ((chunk-end-offset (buffer-find-nonchar buffer chunk-start-offset (min (+ *maximum-chunk-size* chunk-start-offset) line-end-offset)))) (cond ((= chunk-start-offset line-end-offset) - (cons chunk-end-offset nil)) + (cons (- chunk-end-offset + line-start-offset) nil)) ((or (not (= chunk-end-offset chunk-start-offset)) (and (offset-beginning-of-line-p buffer chunk-start-offset) (offset-end-of-line-p buffer chunk-end-offset))) - (cons chunk-end-offset nil)) + (cons (- chunk-end-offset + line-start-offset) nil)) ((not (characterp (buffer-object buffer chunk-end-offset))) - (cons (1+ chunk-end-offset) t))))) + (cons (- (1+ chunk-end-offset) + line-start-offset) t))))) (defmethod initialize-instance :after ((line line-object) &rest initargs) (declare (ignore initargs)) (loop with buffer = (buffer (start-mark line)) - with chunk-start-offset = (offset (start-mark line)) - with line-end-offset = (end-of-line-offset buffer (offset (start-mark line))) - for chunk-info = (get-chunk (buffer (start-mark line)) + with line-start-offset = (offset (start-mark line)) + with line-end-offset = (+ line-start-offset (line-length line)) + with chunk-start-offset = line-start-offset + for chunk-info = (get-chunk buffer + line-start-offset chunk-start-offset line-end-offset) do (vector-push-extend chunk-info (chunks line)) - (setf chunk-start-offset (car chunk-info)) + (setf chunk-start-offset (+ (car chunk-info) + line-start-offset)) when (= chunk-start-offset line-end-offset) do (loop-finish))) @@ -168,11 +181,13 @@ (defun fetch-chunk (line chunk-index) "Retrieve the `chunk-index'th chunk from `line'. The return value is either an integer, in which case it specifies the -end-offset of a string chunk, or a function, in which case it is -the drawing function for a single-object non-character chunk." - (destructuring-bind (chunk-end-offset . objectp) +end-offset of a string chunk relative to the start of the line, +or a function, in which case it is the drawing function for a +single-object non-character chunk." + (destructuring-bind (relative-chunk-end-offset . objectp) (aref (chunks line) chunk-index) - (if objectp (object-drawer) chunk-end-offset))) + (if objectp (object-drawer) (+ relative-chunk-end-offset + (offset (start-mark line)))))) (defmethod stroke-pump-with-syntax ((view textual-drei-syntax-view) (syntax fundamental-syntax) stroke

1 0

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

03 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10630/Drei Modified Files: views.lisp Log Message: Buffer-views no longer responsible for updating syntax-view data. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/02 14:43:40 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/03 16:21:20 1.11 @@ -555,16 +555,10 @@ (defmethod observer-notified ((view drei-buffer-view) (buffer drei-buffer) changed-region) - (with-accessors ((prefix-size prefix-size) - (suffix-size suffix-size)) view - (setf prefix-size (min (car changed-region) prefix-size) - suffix-size (min (- (size buffer) (cdr changed-region)) - suffix-size) - (modified-p view) t) - (dotimes (i (displayed-lines-count view)) - (let ((line (line-information view i))) - (when (<= (car changed-region) (line-end-offset line)) - (invalidate-line-strokes line :modified t)))))) + (dotimes (i (displayed-lines-count view)) + (let ((line (line-information view i))) + (when (<= (car changed-region) (line-end-offset line)) + (invalidate-line-strokes line :modified t))))) (defclass drei-syntax-view (drei-buffer-view) ((%syntax :accessor syntax) @@ -651,6 +645,16 @@ (disable-mode (syntax modual) mode-name) (call-next-method))) +(defmethod observer-notified ((view drei-syntax-view) (buffer drei-buffer) + changed-region) + (with-accessors ((prefix-size prefix-size) + (suffix-size suffix-size)) view + (setf prefix-size (min (car changed-region) prefix-size) + suffix-size (min (- (size buffer) (cdr changed-region)) + suffix-size) + (modified-p view) t)) + (call-next-method)) + (defmethod synchronize-view :around ((view drei-syntax-view) &key force-p) ;; If nothing changed, then don't call the other methods. @@ -672,8 +676,7 @@ (setf (prefix-size view) (size (buffer view)) (suffix-size view) (size (buffer view)) (buffer-size view) (size (buffer view))) - (update-syntax (syntax view) prefix-size suffix-size - begin end) + (update-syntax (syntax view) prefix-size suffix-size begin end) (call-next-method))) (defun make-syntax-for-view (view syntax-symbol &rest args)

1 0

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

03 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8313/Drei Modified Files: buffer.lisp Log Message: Added print-object method for buffers. --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2008/01/01 18:43:36 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2008/01/03 16:19:42 1.7 @@ -690,3 +690,11 @@ (defmethod (setf buffer-object) :after (object (buffer observable-buffer-mixin) offset) (notify-observers buffer (constantly (cons offset (1+ offset))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Print method for ease of debugging + +(defmethod print-object ((object buffer) stream) + (print-unreadable-object (object stream :type t :identity t) + (format stream "size:~A" (size object))))

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 January 2008