mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

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

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22760/Drei Modified Files: lisp-syntax.lisp Log Message: Handle non-character objects in the buffer even when the syntax is erroneous. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 09:13:56 1.49 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 11:55:18 1.50 @@ -274,6 +274,7 @@ (defclass error-lexeme (lisp-lexeme) ()) (defclass literal-object-lexeme (lisp-lexeme literal-object-mixin) ()) +(defclass literal-object-error-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) ()) @@ -619,9 +620,13 @@ (defmethod lex ((syntax lisp-syntax) (state lexer-error-state) scan) (macrolet ((fo () `(forward-object scan))) - (loop until (end-of-line-p scan) - do (fo)) - (make-instance 'error-lexeme))) + (cond ((not (or (end-of-buffer-p scan) + (characterp (object-after scan)))) + (fo) + (make-instance 'literal-object-error-lexeme)) + (t (loop until (end-of-line-p scan) + do (fo)) + (make-instance 'error-lexeme))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

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

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15426/Drei Modified Files: packages.lisp Log Message: I must have broken support for literal objects in buffers along the way, unbroke it now. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/04 21:11:39 1.31 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/05 09:17:37 1.32 @@ -500,6 +500,7 @@ #:parser-symbol #:parent #:children #:start-offset #:end-offset #:parser-state #:preceding-parse-tree + #:literal-object-mixin #:define-parser-state #:lexeme #:nonterminal #:action #:new-state #:done

1 0

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

05 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14671/Drei Modified Files: lisp-syntax.lisp Log Message: No longer store ink and face settings for Lisp lexemes. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/04 21:55:45 1.48 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/05 09:13:56 1.49 @@ -270,9 +270,7 @@ (defclass comment (lisp-nonterminal) ()) -(defclass lisp-lexeme (lexeme) - ((ink) - (face))) +(defclass lisp-lexeme (lexeme) ()) (defclass error-lexeme (lisp-lexeme) ()) (defclass literal-object-lexeme (lisp-lexeme literal-object-mixin) ())

1 0

[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

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