January 2008 - mcclim-cvs@common-lisp.net

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

10 Jan '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv23328 Modified Files: mcclim.asd Log Message: Fixed ASDF system for MCCLIM-IMAGES. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/07 22:55:11 1.73 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/01/10 09:38:07 1.74 @@ -554,7 +554,8 @@ :components ((:module "Extensions/Images" :pathname #.(make-pathname :directory '(:relative "Extensions" "Images")) :components ((:file "package") - (:file "images"))))) + (:file "images" :depends-on ("package")) + (:file "image-viewer" :depends-on ("images")))))) (defmacro support-format (format &rest depends-on) "Generate the ASDF `defsystem' form for a single-file system

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-serv11294/Drei Modified Files: lisp-syntax-swank.lisp Log Message: Use internal symbols for swank-require. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2008/01/09 22:12:59 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2008/01/09 22:15:49 1.11 @@ -33,8 +33,8 @@ ;; Oh my! This is so we "gracefully" handle older Swanks that do not ;; have `swank-require'. We just hope they have the symbols we need ;; anyway. - (ignore-errors (swank:swank-require :swank-c-p-c) - (swank:swank-require :swank-arglists))) + (ignore-errors (swank::swank-require :swank-c-p-c) + (swank::swank-require :swank-arglists))) ;; If this file is loaded, make local Swank the default way of ;; interacting with the image.

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-serv10967/Drei Modified Files: lisp-syntax-swank.lisp Log Message: "Gracefully" handle older Swanks. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2007/12/19 01:19:26 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2008/01/09 22:12:59 1.10 @@ -30,8 +30,11 @@ ;; We need these modules loaded. (eval-when (:compile-toplevel :load-toplevel :execute) - (swank:swank-require :swank-c-p-c) - (swank:swank-require :swank-arglists)) + ;; Oh my! This is so we "gracefully" handle older Swanks that do not + ;; have `swank-require'. We just hope they have the symbols we need + ;; anyway. + (ignore-errors (swank:swank-require :swank-c-p-c) + (swank:swank-require :swank-arglists))) ;; If this file is loaded, make local Swank the default way of ;; interacting with the image.

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-serv8506/Extensions/Images Modified Files: package.lisp Added Files: image-viewer.lisp Log Message: Added image viewer gadget to MCCLIM-IMAGES. --- /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/09 19:27:39 1.2 @@ -24,4 +24,5 @@ (:use :clim-lisp :clim) (:export :export #:image-format-supported #:load-image #:load-image-of-format - #:unsupported-image-format #:image-format)) + #:unsupported-image-format #:image-format + #:image-viewer #:image-viewer-pane)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/09 19:27:39 NONE +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/09 19:27:39 1.1 ;;; -*- Mode: Lisp; Package: MCCLIM-IMAGES -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; A simple image viewer gadget. It would be nice if it could modify ;;; its space requirements to fit the image, but MCCLIM-IMAGES does ;;; not provide this functionality. (in-package :mcclim-images) (defclass image-viewer (value-gadget) () (:documentation "An abstract gadget for displaying images. The value of the gadget is the image being displayed.") (:default-initargs :value nil)) (defmethod (setf gadget-value) :after (new-value (gadget image-viewer) &key &allow-other-keys) (handle-repaint gadget (or (pane-viewport-region gadget) (sheet-region gadget)))) (defclass image-viewer-pane (image-viewer basic-gadget) () (:documentation "A concrete gadget for displaying images. The value of the gadget is the image being displayed.")) (defmethod handle-repaint ((pane image-viewer-pane) region) (declare (ignore region)) ;; Clear the old image. (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (draw-rectangle* (sheet-medium pane) x1 y1 x2 y2 :ink +background-ink+)) ;; Draw the new one, if there is one. (when (gadget-value pane) (draw-design pane (gadget-value pane))))

1 0

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

09 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv8355/Extensions Modified Files: rgb-image.lisp Log Message: Fixed some bugs in freeing rgb-images. --- /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/09 16:59:04 1.4 +++ /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/09 19:27:04 1.5 @@ -56,6 +56,9 @@ (defgeneric medium-free-image-design (medium design)) +(defmethod medium-free-image-design ((sheet sheet-with-medium-mixin) design) + (medium-free-image-design (sheet-medium sheet) design)) + (defun free-image-design (design) (medium-free-image-design (slot-value design 'medium) design)) @@ -129,8 +132,6 @@ (defmethod draw-design (medium (design rgb-image-design) &rest options - &key x y &allow-other-keys) - (unless (and x y) - (setf (values x y) (stream-cursor-position medium))) + &key (x 0) (y 0) &allow-other-keys) (with-medium-options (medium options) (medium-draw-image-design* medium design x y)))

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-serv8234/Drei Modified Files: views.lisp Log Message: Start out with a recoreded buffer size of -1 to force reparsing. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/08 21:05:50 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/09 19:26:14 1.16 @@ -574,7 +574,7 @@ :documentation "The number of unchanged objects at the end of the buffer.") (%recorded-buffer-size :accessor buffer-size - :initform 0 + :initform -1 :documentation "The size of the buffer the last time the view was synchronized.")) (:documentation "A buffer-view that maintains a parse tree of

1 0

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

09 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23439/Drei Modified Files: syntax.lisp Log Message: Minor documentation-style update: make the default for values-max-min method combination be :most-specific-first, and explicitly make update-syntax use the :most-specific-last method combination. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/07 22:01:58 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/09 18:21:44 1.11 @@ -82,7 +82,7 @@ delimited by `begin' and `end' has an up to date parse. Returns two values, offsets into the buffer of the syntax, denoting the buffer region thas has an up to date parse.") - (:method-combination values-max-min) + (:method-combination values-max-min :most-specific-last) (:method values-max-min ((syntax syntax) (unchanged-prefix integer) (unchanged-suffix integer) &optional (begin 0) (end (- (size (buffer syntax)) unchanged-suffix)))

1 0

[mcclim-cvs] CVS mcclim/ESA
by crhodes 09 Jan '08

09 Jan '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv23439/ESA Modified Files: utils.lisp Log Message: Minor documentation-style update: make the default for values-max-min method combination be :most-specific-first, and explicitly make update-syntax use the :most-specific-last method combination. --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/07 22:01:59 1.7 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/09 18:21:44 1.8 @@ -234,7 +234,7 @@ array) (define-method-combination values-max-min - (&optional (order ':most-specific-last)) + (&optional (order ':most-specific-first)) ((around (:around)) (before (:before)) (after (:after))

1 0

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

09 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv3396/Apps/Listener Modified Files: dev-commands.lisp Log Message: Added Display Image command to Listener. Note that, by default, it only loads the libraries for XPM reading. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2007/09/04 20:45:54 1.43 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/09 17:19:47 1.44 @@ -1417,6 +1417,18 @@ ((object 'pathname :prompt "pathname")) (show-file object)) +(define-command (com-display-image :name t :command-table filesystem-commands + :menu t) + ((image-pathname 'pathname + :default (user-homedir-pathname) :insert-default t)) + (if (probe-file image-pathname) + (handler-case + (with-room-for-graphics () + (draw-design *standard-output* (mcclim-images:load-image image-pathname))) + (mcclim-images:unsupported-image-format (c) + (format t "Image format ~A not recognized" (mcclim-images:image-format c)))) + (format t "No such file: ~A" image-pathname))) + (define-command (com-edit-definition :name "Edit Definition" :command-table lisp-commands :menu t

1 0

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

09 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Extensions In directory clnet:/tmp/cvs-serv28086/Extensions Modified Files: rgb-image.lisp Log Message: Added fixes for drawing of rgb-images so that they properly add output records. --- /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/06 16:05:46 1.3 +++ /project/mcclim/cvsroot/mcclim/Extensions/rgb-image.lisp 2008/01/09 16:59:04 1.4 @@ -44,7 +44,8 @@ (defclass rgb-image-design (design) ((medium :initform nil :initarg :medium) - (image :initarg :image) + (image :reader image + :initarg :image) (medium-data :initform nil))) (defun make-rgb-image-design (image) @@ -71,6 +72,39 @@ (setf medium current-medium) (setf medium-data nil)))) +(defmethod medium-draw-image-design* + ((medium sheet-with-medium-mixin) design x y) + (medium-draw-image-design* (sheet-medium medium) design x y)) + +;;; Output recording stuff, this was copied from the pattern code. + +(def-grecording draw-image-design (() image-design x y) () + (let ((width (image-width (image image-design))) + (height (image-height (image image-design))) + (transform (medium-transformation medium))) + (setf (values x y) (transform-position transform x y)) + (values x y (+ x width) (+ y height)))) + +(defmethod* (setf output-record-position) :around + (nx ny (record draw-image-design-output-record)) +(with-standard-rectangle* (:x1 x1 :y1 y1) + record + (with-slots (x y) + record + (let ((dx (- nx x1)) + (dy (- ny y1))) + (multiple-value-prog1 + (call-next-method) + (incf x dx) + (incf y dy)))))) + +(defrecord-predicate draw-image-design-output-record (x y image-design) + (and (if-supplied (x coordinate) + (coordinate= (slot-value record 'x) x)) + (if-supplied (y coordinate) + (coordinate= (slot-value record 'y) y)) + (if-supplied (image-design rgb-image-design) + (eq (slot-value record 'image-design) image-design)))) ;;; Fetching protocol @@ -93,15 +127,10 @@ (defgeneric sheet-rgb-data (port sheet &key x y width height)) -;;; Output recording - -(defun draw-image-design* - (medium design &rest options &key x y &allow-other-keys) - (unless (and x y) - (setf (values x y) (clim:stream-cursor-position medium))) - (climi::with-medium-options (medium options) - (medium-draw-image-design* (sheet-medium medium) design x y))) - (defmethod draw-design - (medium (design rgb-image-design) &rest options &key &allow-other-keys) - (apply #'draw-image-design* medium design options)) + (medium (design rgb-image-design) &rest options + &key x y &allow-other-keys) + (unless (and x y) + (setf (values x y) (stream-cursor-position medium))) + (with-medium-options (medium options) + (medium-draw-image-design* medium design x y)))

1 0

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

09 Jan '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27817 Modified Files: graphics.lisp Log Message: Added draw-design method for patterns. I'm not completely sure that it is correct, but it worked for my test cases. --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2007/07/19 06:52:51 1.58 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2008/01/09 16:57:54 1.59 @@ -992,6 +992,11 @@ ;;;; +(defmethod draw-design (medium (pattern pattern) &key clipping-region transformation + &allow-other-keys) + (draw-pattern* medium pattern 0 0 + :clipping-region clipping-region :transformation transformation)) + (defun draw-pattern* (medium pattern x y &key clipping-region transformation) ;; Note: I believe the sample implementation in the spec is incorrect. ;; --GB

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-serv19300/Drei Modified Files: drei-redisplay.lisp Log Message: Fixed typo, dispatcer -> dispatcher. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/08 14:52:18 1.23 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/09 12:47:31 1.24 @@ -99,7 +99,7 @@ (ink +foreground-ink+) (style nil)) -(defconstant +default-stroke-drawer-dispatcer+ +(defconstant +default-stroke-drawer-dispatcher+ #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn) (funcall default-drawing-fn stream view stroke cursor-x cursor-y)) "A simple function of six arguments that simply calls the first @@ -109,7 +109,7 @@ (defstruct drawing-options "A set of options for how to display a stroke." (face (make-face)) - (function +default-stroke-drawer-dispatcer+)) + (function +default-stroke-drawer-dispatcher+)) (defun drawing-options-equal (o1 o2) "Return true if `o1' and `o2' are equal, that is, they specify @@ -123,13 +123,13 @@ (and (equal (face-ink f1) (face-ink f2)) (equal (face-style f1) (face-style f2)) (or (not (eq (drawing-options-function o1) - +default-stroke-drawer-dispatcer+)) + +default-stroke-drawer-dispatcher+)) (eq (drawing-options-function o2) - +default-stroke-drawer-dispatcer+)) + +default-stroke-drawer-dispatcher+)) (or (not (eq (drawing-options-function o2) - +default-stroke-drawer-dispatcer+)) + +default-stroke-drawer-dispatcher+)) (eq (drawing-options-function o1) - +default-stroke-drawer-dispatcer+))))) + +default-stroke-drawer-dispatcher+))))) (defconstant +default-drawing-options+ (make-drawing-options) "The default set of drawing options used for strokes when

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-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 08 Jan '08

08 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

[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-serv18573/Drei Modified Files: lisp-syntax.lisp packages.lisp Added Files: drawing-options.lisp Log Message: Added some standard drawing options, including syntactical drawing options. This is meant to make it easier to switch colour schemes. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:05:22 1.55 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:37:17 1.56 @@ -1831,43 +1831,37 @@ (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+))) - (highlighted-parenthesis-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) - (define-syntax-highlighting-rules emacs-style-highlighting - (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))) - (literal-object-form (:options :function (object-drawer))) - (complete-token-form (:function #'(lambda (view form) - (cond ((symbol-form-is-keyword-p (syntax view) form) - keyword-drawing-options) - ((symbol-form-is-macrobound-p (syntax view) form) - macro-drawing-options) - ((symbol-form-is-boundp (syntax view) form) - bound-drawing-options) - (t +default-drawing-options+))))) - (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))) - highlighted-parenthesis-options - +default-drawing-options+)))))) - -(let ((macro-drawing-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) - (define-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+))))))) +(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))) + (literal-object-form (:options :function (object-drawer))) + (complete-token-form (:function #'(lambda (view form) + (cond ((symbol-form-is-keyword-p (syntax view) form) + *keyword-drawing-options*) + ((symbol-form-is-macrobound-p (syntax view) form) + *special-operator-drawing-options*) + ((symbol-form-is-boundp (syntax view) form) + *special-variable-drawing-options*) + (t +default-drawing-options+))))) + (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+))))) + +(define-syntax-highlighting-rules retro-highlighting + (error-symbol (:face :ink +red+)) + (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+)))))) (defparameter *syntax-highlighting-rules* 'emacs-style-highlighting "The syntax highlighting rules used for highlighting Lisp --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:05:22 1.35 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:37:17 1.36 @@ -246,12 +246,12 @@ #:minibuffer - ;; DREI interface stuff. #:drei #:drei-pane #:drei-gadget-pane #:drei-area #:handling-drei-conditions #:handle-drei-condition #:execute-drei-command - #:display-drei-view-contents #:display-drei-view-cursor + ;; Redisplay engine. + #:display-drei-view-contents #:display-drei-view-cursor #:face #:make-face #:face-ink #:face-style #:drawing-options #:make-drawing-options #:drawing-options-face #:drawing-options-function @@ -261,6 +261,17 @@ #:pump-state-for-offset #:stroke-pump #:object-drawer #:*maximum-chunk-size* + + #:+roman-face+ #:+roman-face-drawing-options+ + #:+italic-face+ #:+italic-face-drawing-options+ + #:+bold-face+ #:+bold-face-drawing-options+ + #:+bold-italic-face+ #:+bold-italic-drawing-options+ + + #:*keyword-drawing-options* + #:*special-operator-drawing-options* + #:*special-variable-drawing-options* + + ;; DREI program interface stuff. #:with-drei-options #:performing-drei-operations #:invoke-performing-drei-operations #:with-bound-drei-special-variables --- /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 22:37:17 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 22:37:17 1.1 ;;; -*- Mode: Lisp; Package: DREI -*- ;;; (c) copyright 2008 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; A bunch of predefined drawing options, styles and faces to make ;;; syntax highlighting rules more elegant. (in-package :drei) ;;; Some general styles. (defconstant +roman-face+ (make-face :style (make-text-style nil :roman nil)) "A face specifying a roman style, but with unspecified family and size.") (defconstant +italic-face+ (make-face :style (make-text-style nil :italic nil)) "A face specifying an italic style, but with unspecified family and size.") (defconstant +bold-face+ (make-face :style (make-text-style nil :bold nil)) "A face specifying a boldface style, but with unspecified family and size.") (defconstant +bold-italic-face+ (make-face :style (make-text-style nil :bold nil)) "A face specifying an italic boldface style, but with unspecified family and size.") ;;; ...and their drawing options. (defconstant +roman-face-drawing-options+ (make-drawing-options :face +roman-face+) "Options used for drawing with a roman face.") (defconstant +italic-face-drawing-options+ (make-drawing-options :face +italic-face+) "Options used for drawing with an italic face.") (defconstant +bold-face-drawing-options+ (make-drawing-options :face +bold-face+) "Options used for drawing with boldface.") (defconstant +bold-italic-face-drawing-options+ (make-drawing-options :face +bold-italic-face+) "Options used for drawing with italic boldface.") ;;; 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. (defvar *keyword-drawing-options* (make-drawing-options :face (make-face :ink +orchid+)) "The drawing options used for drawing the syntactical equivalent of keyword symbols. In Lisp, this is used for keyword symbols.") (defvar *special-operator-drawing-options* (make-drawing-options :face (make-face :ink +purple+)) "The drawing options used for drawing the syntactical equivalent of special operators. In Lisp, this is used for macros and special operators, in most other languages, it should probably be used for language keywords.") (defvar *special-variable-drawing-options* (make-drawing-options :face (make-face :ink +darkgoldenrod+)) "The drawing options used for drawing variables that are 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.")

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-serv13469/Drei Modified Files: lisp-syntax.lisp lr-syntax.lisp packages.lisp Log Message: make-syntax-highlighting-rules -> define-syntax-highlighting-rules, as the former sounds stupid. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 15:32:15 1.54 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/07 22:05:22 1.55 @@ -1835,7 +1835,7 @@ (macro-drawing-options (make-drawing-options :face (make-face :ink +purple+))) (bound-drawing-options (make-drawing-options :face (make-face :ink +darkgoldenrod+))) (highlighted-parenthesis-options (make-drawing-options :face (make-face :style (make-text-style nil :bold nil))))) - (make-syntax-highlighting-rules emacs-style-highlighting + (define-syntax-highlighting-rules emacs-style-highlighting (error-lexeme (:face :ink +red+)) (string-form (:face :ink +rosy-brown+ :style (make-text-style nil :italic nil))) @@ -1858,7 +1858,7 @@ +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 + (define-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) --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:01:58 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:05:22 1.12 @@ -412,7 +412,7 @@ ;;; XXXXX XXXXX ;;; XXX XXX -(defmacro make-syntax-highlighting-rules (name &body rules) +(defmacro define-syntax-highlighting-rules (name &body rules) "Define a set of rules for highlighting a syntax. `Name', which must be a symbol, is the name of this set of rules, and will be bound to a function implementing the rules. `Rules' is a list of @@ -456,7 +456,7 @@ (defmethod ,name (view (parser-symbol ,parser-symbol)) (funcall rule view parser-symbol))))))) -(make-syntax-highlighting-rules default-syntax-highlighting) +(define-syntax-highlighting-rules default-syntax-highlighting) (defgeneric syntax-highlighting-rules (syntax) (:documentation "Return the drawing options that should be used --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:01:58 1.34 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:05:22 1.35 @@ -507,7 +507,7 @@ #:action #:new-state #:done #:reduce-fixed-number #:reduce-until-type #:reduce-all #:error-state #:error-reduce-state - #:make-syntax-highlighting-rules + #:define-syntax-highlighting-rules #:syntax-highlighting-rules) (:documentation "Underlying LR parsing functionality."))

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-serv12937/Drei Modified Files: fundamental-syntax.lisp lr-syntax.lisp packages.lisp syntax.lisp views.lisp Log Message: Changed the update-syntax protocol to use a nonstandard method combination for added job security. --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/03 16:25:16 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2008/01/07 22:01:53 1.11 @@ -90,24 +90,8 @@ (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 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) - line-start-offset)) - when (= chunk-start-offset line-end-offset) - do (loop-finish))) - -(defmethod update-syntax ((syntax fundamental-syntax) prefix-size suffix-size - &optional begin end) +(defmethod update-syntax values-max-min ((syntax fundamental-syntax) prefix-size suffix-size + &optional begin end) (declare (ignore begin end)) (let ((low-mark (make-buffer-mark (buffer syntax) prefix-size :left)) (high-mark (make-buffer-mark @@ -144,7 +128,25 @@ (if (end-of-buffer-p scan) (loop-finish) ;; skip newline - (forward-object scan)))))))))) + (forward-object scan)))))))) + ;; Fundamental syntax always parses the entire buffer. + (values 0 (size (buffer syntax))))) + +(defmethod initialize-instance :after ((line line-object) + &rest initargs) + (declare (ignore initargs)) + (loop with buffer = (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) + line-start-offset)) + when (= chunk-start-offset line-end-offset) + do (loop-finish))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 15:32:15 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/lr-syntax.lisp 2008/01/07 22:01:58 1.11 @@ -356,10 +356,9 @@ ;;; ;;; update syntax -(defmethod update-syntax ((syntax lr-syntax-mixin) prefix-size suffix-size - &optional begin end) +(defmethod update-syntax values-max-min ((syntax lr-syntax-mixin) prefix-size suffix-size + &optional begin end) (declare (ignore begin end)) - (call-next-method) (let* ((low-mark-offset prefix-size) (high-mark-offset (- (size (buffer syntax)) suffix-size))) (when (<= low-mark-offset high-mark-offset) @@ -378,7 +377,8 @@ (new-state syntax (parser-state stack-top) stack-top))) - (loop do (parse-patch syntax))))))) + (loop do (parse-patch syntax)))))) + (values 0 (size (buffer syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/05 20:08:32 1.33 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/07 22:01:58 1.34 @@ -484,7 +484,7 @@ (defpackage :drei-fundamental-syntax (:use :clim-lisp :clim :drei-buffer :drei-base - :drei-syntax :flexichain :drei :drei-core) + :drei-syntax :flexichain :drei :drei-core :esa-utils) (:export #:fundamental-syntax #:scan #:start-mark #:line-length #:line-end-offset #:line-containing-offset #:offset-in-line-p) --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/12/28 10:08:34 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/07 22:01:58 1.10 @@ -78,7 +78,15 @@ that must have an up-to-date parse, defaulting to 0 and the size of the buffer respectively. It is perfectly valid for a syntax to ignore these hints and just make sure the entire syntax tree is -up to date.")) +up to date, but it *must* make sure at at least the region +delimited by `begin' and `end' has an up to date parse. Returns +two values, offsets into the buffer of the syntax, denoting the +buffer region thas has an up to date parse.") + (:method-combination values-max-min) + (:method values-max-min ((syntax syntax) (unchanged-prefix integer) + (unchanged-suffix integer) &optional (begin 0) + (end (- (size (buffer syntax)) unchanged-suffix))) + (values begin end))) (defgeneric eval-defun (mark syntax)) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/03 18:09:27 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/07 22:01:58 1.13 @@ -659,12 +659,14 @@ (call-next-method)) (defmethod synchronize-view :around ((view drei-syntax-view) &key - force-p) + force-p (begin 0) (end (size (buffer view)))) ;; If nothing changed, then don't call the other methods. - (unless (and (= (prefix-size view) (suffix-size view) - (size (buffer view)) (buffer-size view)) - (not force-p)) - (call-next-method))) + (let ((high-offset (- (size (buffer view)) (suffix-size view)))) + (when (or (and (>= begin (prefix-size view)) + (>= high-offset end)) + (/= (size (buffer view)) (buffer-size view)) + force-p) + (call-next-method)))) (defmethod synchronize-view ((view drei-syntax-view) &key (begin 0) (end (size (buffer view)))) @@ -674,12 +676,21 @@ size of the buffer respectively." (let ((prefix-size (prefix-size view)) (suffix-size (suffix-size view))) - ;; Reset here so if `update-syntax' calls `update-parse' itself, - ;; we won't end with infinite recursion. - (setf (prefix-size view) (size (buffer view)) - (suffix-size view) (size (buffer 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) (buffer-size view) (size (buffer view))) - (update-syntax (syntax view) prefix-size suffix-size begin end) + (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 + ;; suffix-size. + (setf (prefix-size view) parsed-end + (suffix-size view) (- (size (buffer view)) parsed-start))) (call-next-method))) (defun make-syntax-for-view (view syntax-symbol &rest args)

1 0

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