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

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

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv8307/ESA Modified Files: esa-io.lisp packages.lisp Log Message: Added facility for ESA for controlling whether or not a buffer is "saveable". Could be used for more than it currently is (such as integrating the user-confirmation stuff when the file already exists). --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2007/12/27 16:34:59 1.5 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/13 22:22:06 1.6 @@ -2,7 +2,7 @@ ;;; (c) copyright 2006 by ;;; Robert Strandh (strandh(a)labri.fr) -;;; (c) copyright 2007 by +;;; (c) copyright 2007-2008 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -29,9 +29,45 @@ buffer having the associated file name.")) (defgeneric frame-find-file-read-only (application-frame file-path)) (defgeneric frame-set-visited-file-name (application-frame filepath buffer)) +(defgeneric check-buffer-writability (application-frame filepath buffer) + (:documentation "Check that `buffer' can be written to +`filepath', which can be an arbitrary pathname. If there is a +problem, an error that is a subclass of +`buffer-writing-error'should be signalled.")) (defgeneric frame-save-buffer (application-frame buffer)) (defgeneric frame-write-buffer (application-frame filepath buffer)) +(define-condition buffer-writing-error (error) + ((%buffer :reader buffer + :initarg :buffer + :initform (error "A buffer must be provided") + :documentation "The buffer that was attempted written when this error occured.") + (%filepath :reader filepath + :initarg :filepath + :initform (error "A filepath must be provided") + :documentation "The filepath that the buffer was attempted to be saved to when this error occured")) + (:report (lambda (condition stream) + (format stream "~A could not be saved to ~A" + (name (buffer condition)) (filepath condition)))) + (:documentation "An error that is a subclass of +`buffer-writing-error' will be signalled when a buffer is +attempted saved to a file, but something goes wrong. Not all +error cases will result in the signalling of a +`buffer-writing-error', but some defined cases will.")) + +(define-condition filepath-is-directory (buffer-writing-error) + () + (:report (lambda (condition stream) + (format stream "Cannot save buffer ~A to just a directory" + (name (buffer condition))))) + (:documentation "This error is signalled when a buffer is +attempted saved to a directory.")) + +(defun filepath-is-directory (buffer filepath) + "Signal an error of type `filepath-is-directory' with the +buffer `buffer' and the filepath `filepath'." + (error 'filepath-is-directory :buffer buffer :filepath filepath)) + (defun find-file (file-path) (frame-find-file *application-frame* file-path)) (defun find-file-read-only (file-path) @@ -170,6 +206,12 @@ that filename." (set-visited-file-name filename (current-buffer))) +(defmethod check-buffer-writability (application-frame (filepath pathname) + (buffer esa-buffer-mixin)) + ;; Cannot write to a directory. + (when (directory-pathname-p filepath) + (filepath-is-directory buffer filepath))) + (defun extract-version-number (pathname) "Extracts the emacs-style version-number from a pathname." (let* ((type (pathname-type pathname)) @@ -208,27 +250,23 @@ (defmethod frame-save-buffer (application-frame buffer) (let ((filepath (or (filepath buffer) (accept 'pathname :prompt "Save Buffer to File")))) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory." filepath) - (beep)) - (t - (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from frame-save-buffer)) - (when (and (probe-file filepath) (not (file-saved-p buffer))) - (let ((backup-name (pathname-name filepath)) - (backup-type (format nil "~A~~~D~~" - (pathname-type filepath) - (1+ (version-number filepath))))) - (rename-file filepath (make-pathname :name backup-name - :type backup-type)))) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (save-buffer-to-stream buffer stream)) - (setf (filepath buffer) filepath - (file-write-time buffer) (file-write-date filepath) - (name buffer) (filepath-filename filepath)) - (display-message "Wrote: ~a" (filepath buffer)) - (setf (needs-saving buffer) nil))))) + (check-buffer-writability application-frame filepath buffer) + (unless (check-file-times buffer filepath "Overwrite" "written") + (return-from frame-save-buffer)) + (when (and (probe-file filepath) (not (file-saved-p buffer))) + (let ((backup-name (pathname-name filepath)) + (backup-type (format nil "~A~~~D~~" + (pathname-type filepath) + (1+ (version-number filepath))))) + (rename-file filepath (make-pathname :name backup-name + :type backup-type)))) + (with-open-file (stream filepath :direction :output :if-exists :supersede) + (save-buffer-to-stream buffer stream)) + (setf (filepath buffer) filepath + (file-write-time buffer) (file-write-date filepath) + (name buffer) (filepath-filename filepath)) + (display-message "Wrote: ~a" (filepath buffer)) + (setf (needs-saving buffer) nil))) (define-command (com-save-buffer :name t :command-table esa-io-table) () "Write the contents of the buffer to a file. @@ -237,22 +275,23 @@ (let ((buffer (current-buffer))) (if (or (null (filepath buffer)) (needs-saving buffer)) - (save-buffer buffer) + (handler-case (save-buffer buffer) + (buffer-writing-error (e) + (with-minibuffer-stream (minibuffer) + (let ((*print-escape* nil)) + (print-object e minibuffer))))) (display-message "No changes need to be saved from ~a" (name buffer))))) (set-key 'com-save-buffer 'esa-io-table '((#\x :control) (#\s :control))) (defmethod frame-write-buffer (application-frame filepath buffer) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory name." filepath)) - (t - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (save-buffer-to-stream buffer stream)) - (setf (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil) - (display-message "Wrote: ~a" (filepath buffer))))) + (check-buffer-writability application-frame filepath buffer) + (with-open-file (stream filepath :direction :output :if-exists :supersede) + (save-buffer-to-stream buffer stream)) + (setf (filepath buffer) filepath + (name buffer) (filepath-filename filepath) + (needs-saving buffer) nil) + (display-message "Wrote: ~a" (filepath buffer))) (define-command (com-write-buffer :name t :command-table esa-io-table) ((filepath 'pathname :prompt "Write Buffer to File: " :prompt-mode :raw @@ -261,7 +300,11 @@ "Prompt for a filename and write the current buffer to it. Changes the file visted by the buffer to the given file." (let ((buffer (current-buffer))) - (write-buffer filepath buffer))) + (handler-case (write-buffer filepath buffer) + (buffer-writing-error (e) + (with-minibuffer-stream (minibuffer) + (let ((*print-escape* nil)) + (print-object e minibuffer))))))) (set-key `(com-write-buffer ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\w :control))) --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/11 02:44:14 1.11 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/13 22:22:06 1.12 @@ -2,7 +2,7 @@ ;;; (c) copyright 2004-2006 by ;;; Robert Strandh (strandh(a)labri.fr) -;;; (c) copyright 2006 by +;;; (c) copyright 2006-2008 by ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or @@ -106,8 +106,11 @@ (:export #:frame-find-file #:find-file #:frame-find-file-read-only #:find-file-read-only #:frame-set-visited-file-name #:set-visited-filename + #:check-buffer-writability #:frame-save-buffer #:save-buffer #:frame-write-buffer #:write-buffer + #:buffer-writing-error #:buffer #:filepath + #:filepath-is-directory #:esa-io-table)) #-(or mcclim building-mcclim)

1 0

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

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8307/Drei Modified Files: packages.lisp Log Message: Added facility for ESA for controlling whether or not a buffer is "saveable". Could be used for more than it currently is (such as integrating the user-confirmation stuff when the file already exists). --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 10:33:09 1.40 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 22:22:05 1.41 @@ -28,6 +28,8 @@ (defpackage :drei-buffer (:use :clim-lisp :flexichain :binseq :esa-utils) + ;; Kludge to remove symbol conflicts. + (:import-from :esa-io :buffer) (:export #:buffer #:standard-buffer #:mark #:left-sticky-mark #:right-sticky-mark #:standard-left-sticky-mark #:standard-right-sticky-mark

1 0

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

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2728/Drei Modified Files: drei-redisplay.lisp Log Message: Initial support for non-graphic characters, including #\Tabs. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/09 12:47:31 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/01/13 22:01:31 1.25 @@ -176,13 +176,18 @@ area taken up by the stroke. If `modified' is true, this stroke object might output something different than the last time it was redisplayed, and should thus update any caches or similar. When -`modified' is set, `dirty' probably also should be set." +`modified' is set, `dirty' probably also should be set. +`widths' is an array of cumulative screen-resolution widths of +the `parts', being a run of characters or a non-graphic character: +see ANALYSE-STROKE-STRING." (start-offset) (end-offset) (drawing-options +default-drawing-options+) (dirty t) (modified t) - (dimensions (make-dimensions))) + (dimensions (make-dimensions)) + (widths) + (parts)) (defstruct (displayed-line (:conc-name line-)) "A line on display. A line delimits a buffer region (always @@ -377,15 +382,18 @@ (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 parts widths x1 y1 x2 y2 &optional (center (/ (- y2 y1) 2))) - "Record the fact that `stroke' has been drawn, and that it + "Record the fact that `stroke' has been drawn, that it consists +of parts `parts' with the widths `widths', and that it covers the specified area on screen. Updates the dirty- and modified-bits of `stroke' as well as the dimensions." (let ((dimensions (stroke-dimensions stroke))) (setf (stroke-dirty stroke) nil (stroke-modified stroke) nil - (x1 dimensions) x1 + (stroke-parts stroke) parts + (stroke-widths stroke) widths + (x1 dimensions) x1 (y1 dimensions) y1 (x2 dimensions) x2 (y2 dimensions) y2 @@ -395,6 +403,39 @@ "A text style specifying a roman face, but with unspecified family and size.") +(defun analyse-stroke-string (string) + "Return a list of parts of `string', where each part is a continuous +run of graphic characters or a single non-graphic character. Each element +in the list is of the form START, END, and one of NIL (meaning a run +of graphic characters) or an object representing the non-graphic char." + (loop with len = (length string) + for left = 0 then (+ right 1) + for right = (or (position-if-not #'graphic-char-p string :start left) + len) + unless (= left right) + collect (list left right) + into parts + until (>= right len) + collect (list right + (+ right 1) + (non-graphic-char-rep (aref string right))) + into parts + finally (return parts))) + +(defun non-graphic-char-rep (object) + "Return the appropriate representation of `object', a non-graphic char. +This will be a string of the format \"^[letter]\" for non-graphic chars +with a char-code of less than #o200, \"\\[octal code]\" for those above +#o200, and the #\\Tab character in the case of a #\\Tab. +NOTE: Assumes an ASCII/Unicode character encoding." + (let ((code (char-code object))) + (cond ((eql object #\Tab) + object) + ((< code #o200) + (format nil "^~C" (code-char (+ code (char-code #\@))))) + (t + (format nil "\\~O" code))))) + (defun stroke-drawing-fn (stream view stroke cursor-x cursor-y) "Draw `stroke' to `stream' at the position (`cursor-x', `cursor-y'). `View' is the view object that `stroke' belongs @@ -406,7 +447,9 @@ (with-accessors ((start-offset stroke-start-offset) (end-offset stroke-end-offset) (dimensions stroke-dimensions) - (drawing-options stroke-drawing-options)) stroke + (drawing-options stroke-drawing-options) + (widths stroke-widths) + (parts stroke-parts)) stroke (let* ((stroke-string (in-place-buffer-substring (buffer view) (cache-string view) start-offset end-offset)) @@ -421,25 +464,66 @@ (text-style-ascent (text-style-ascent roman-text-style (sheet-medium stream))) (text-style-descent (text-style-descent roman-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 text-style-height - (stream-vertical-spacing stream))) - (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) (+ text-style-height cursor-y) - baseline)))))) + (with-accessors ((x1 x1) (x2 x2) (center center)) dimensions + (multiple-value-bind (stroke-parts width baseline part-widths) + (if (stroke-modified stroke) + (loop with parts = (analyse-stroke-string stroke-string) + with width = 0 + with baseline = 0 + with widths = (make-array 1 :adjustable t :fill-pointer t) + with tab-width + for (start end object) in parts + do (cond ((and object (eql object #\Tab)) + (incf width + (- (or tab-width (setf tab-width (tab-width stream view))) + (mod (+ width cursor-x) tab-width))) + (vector-push-extend width widths)) + (object + (multiple-value-bind (w ignore1 ignore2 ignore3 b) + (text-size stream object + :text-style merged-text-style) + (declare (ignore ignore1 ignore2 ignore3)) + (incf width w) + (setf baseline (max baseline b)) + (vector-push-extend width widths))) + (t + (multiple-value-bind (w ignore1 ignore2 ignore3 b) + (text-size stream stroke-string + :start start :end end + :text-style merged-text-style) + (declare (ignore ignore1 ignore2 ignore3)) + (incf width w) + (setf baseline (max baseline b)) + (vector-push-extend width widths)))) + finally (return (values parts width baseline widths))) + (values parts (- x2 x1) center widths)) + (clear-rectangle* stream cursor-x cursor-y + (+ cursor-x width) (+ cursor-y text-style-height + (stream-vertical-spacing stream))) + (loop for (start end object) in stroke-parts + for width across part-widths + do (cond ((and object (eq object #\Tab)) + nil) + (object + (draw-text* stream object (+ cursor-x width) + (+ cursor-y + (- text-style-ascent + baseline)) + :text-style merged-text-style + :ink +darkblue+ + :align-y :top)) + (t + (draw-text* stream stroke-string (+ cursor-x width) + (+ cursor-y + (- text-style-ascent + baseline)) + :start start :end end + :text-style merged-text-style + :ink (face-ink (drawing-options-face drawing-options)) + :align-y :top)))) + (record-stroke stroke stroke-parts part-widths cursor-x cursor-y + (+ width cursor-x) (+ text-style-height cursor-y) + baseline)))))) (defun draw-stroke (stream view stroke cursor-x cursor-y) "Draw `stroke' on `stream' at (`cursor-x', `cursor-y'). Nothing @@ -551,7 +635,9 @@ expects its stroke to cover a single-object non-character buffer region, which will be presented with its appropriate presentation type (found via `presentation-type-of') to generate output." - (let (output-record) + (let (output-record + (widths (make-array 2 :initial-contents (list 0 0))) + (parts (list 0 1))) #'(lambda (stream view stroke cursor-x cursor-y default-drawing-fn) (declare (ignore default-drawing-fn)) @@ -573,7 +659,9 @@ (+ cursor-x width) (+ cursor-y height (stream-vertical-spacing stream))) (replay output-record stream) - (record-stroke stroke cursor-x cursor-y (+ width cursor-x) + (setf (aref widths 1) width) + (record-stroke stroke parts widths + cursor-x cursor-y (+ width cursor-x) (+ (if (zerop height) (text-style-height (medium-text-style stream) stream) height) @@ -644,15 +732,25 @@ "Calculate the position in device units of `offset' in `stroke', relative to the starting position of `stroke'. `Offset' is an absolute offset into the buffer of `view'," - (text-size stream (in-place-buffer-substring - (buffer view) (cache-string view) - (stroke-start-offset stroke) offset) - :end (- offset (stroke-start-offset stroke)) - :text-style (merge-text-styles - (face-style - (drawing-options-face - (stroke-drawing-options stroke))) - (medium-merged-text-style (sheet-medium stream))))) + (let ((string (in-place-buffer-substring + (buffer view) (cache-string view) + (stroke-start-offset stroke) offset))) + (loop with pos = (- offset (stroke-start-offset stroke)) + for width across (stroke-widths stroke) + for next upfrom 1 + for (start end object) in (stroke-parts stroke) + when (and object (= pos end)) + do (return (aref (stroke-widths stroke) next)) + when (<= start pos end) + do (return (+ width + (text-size stream string + :start start + :end pos + :text-style (merge-text-styles + (face-style + (drawing-options-face + (stroke-drawing-options stroke))) + (medium-merged-text-style (sheet-medium stream))))))))) (defgeneric offset-to-screen-position (pane view offset) (:documentation "Returns the position of offset as a screen

1 0

[mcclim-cvs] CVS mcclim/Experimental/freetype
by ahefner 13 Jan '08

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv8112 Modified Files: freetype-fonts.lisp Log Message: Attempt to improve handling of broken freetype paths. Error immediately when a TTF file cannot be found. If call-next-method here was a feature, I hope no one misses it. Added potentially helpful restart. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/06 01:37:06 1.15 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-fonts.lisp 2008/01/13 20:23:59 1.16 @@ -137,7 +137,7 @@ (or (pop (display-free-glyph-ids display)) (incf (display-free-glyph-id-counter display)))) -(defvar *font-hash* +(defparameter *font-hash* (make-hash-table :test #'equalp)) (defstruct (glyph-info (:constructor glyph-info (id width height left right top))) @@ -386,7 +386,6 @@ ;;; Here are alternate mappings for the DejaVu family of fonts, which ;;; are a derivative of Vera with improved unicode coverage. - #+NIL (defparameter *families/faces* '(((:FIX :ROMAN) . "DejaVuSansMono.ttf") @@ -436,6 +435,24 @@ (defparameter *free-type-face-hash* (make-hash-table :test #'equal)) +(define-condition missing-font (simple-error) + ((filename :reader missing-font-filename :initarg :filename)) + (:report (lambda (condition stream) + (format stream "Cannot access ~W~%Your *freetype-font-path* is currently ~W~%The following files should exist:~&~{ ~A~^~%~}" + (missing-font-filename condition) + *freetype-font-path* + (mapcar #'cdr *families/faces*))))) + +(defun invoke-with-freetype-path-restart (continuation) + (restart-case (funcall continuation) + (change-font-path (new-path) + :report (lambda (stream) (format stream "Retry with alternate freetype font path")) + :interactive (lambda () + (format t "Enter new value: ") + (list (read-line))) + (setf *freetype-font-path* new-path) + (invoke-with-freetype-path-restart continuation)))) + (let (lookaside) (defmethod clim-clx::text-style-to-X-font :around ((port clim-clx::clx-port) (text-style standard-text-style)) (flet ((f () @@ -453,14 +470,18 @@ (let* ((font-path-relative (cdr (assoc (list family face) *families/faces* :test #'equal))) (font-path (namestring (merge-pathnames font-path-relative *freetype-font-path*)))) + (unless (and font-path (probe-file font-path)) + (error 'missing-font :filename font-path)) + #+NIL (if (and font-path (probe-file font-path)) (make-free-type-face display font-path size) - (call-next-method))))))) + (call-next-method)) + (make-free-type-face display font-path size)))))) (t - (call-next-method))))))) + (call-next-method))))))) (cdr (if (eq (car lookaside) text-style) lookaside - (setf lookaside (cons text-style (f)))))))) + (setf lookaside (cons text-style (invoke-with-freetype-path-restart #'f)))))))) (defmethod clim-clx::text-style-to-X-font ((port clim-clx::clx-port) text-style) (error "You lost: ~S." text-style))

1 0

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

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27483/Drei Modified Files: lisp-syntax.lisp Log Message: Fixed the list-down movement commands for Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 11:37:21 1.66 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/13 17:10:24 1.67 @@ -1984,7 +1984,7 @@ (defun find-list-parent (form) "Find a list parent of `form' and return it. If a list parent -cannot be found, return nil" +cannot be found, return nil." (let ((parent (parent form))) (typecase parent (list-form parent) @@ -2000,23 +2000,23 @@ (when list-parent (funcall fn list-parent)))) -(defun find-list-child-offset (form fn &optional (min-offset 0)) - "Find a list child of `token' with a minimum start -offset of `min-offset' and return `fn' applied to this child token. -`Fn' should be a function that returns an offset when applied to a -token (eg. `start-offset' or `end-offset'). If a list child cannot -be found, return nil." - (labels ((has-list-child (form) - (some #'(lambda (child) - (if (and (form-list-p child) - (>= (start-offset child) - min-offset)) - child - (has-list-child child))) - (children form)))) - (let ((list-child (has-list-child form))) - (when (not (null list-child)) - (funcall fn list-child))))) +(defun find-list-child (form) + "Find the first list child of `form' and return it. If a list +child cannot be found, return nil." + (find-if #'(lambda (child) + (typecase child + (list-form child) + (form (find-list-child child)))) + (children form))) + +(defun find-list-child-offset (form fn) + "Find a list child of `form' and return `fn' applied to this child. +`Fn' should be a function that returns an offset when applied to +a form (eg. `start-offset' or `end-offset'). If a list child +cannot be found, return nil." + (let ((list-child (find-list-child form))) + (when list-child + (funcall fn list-child)))) (defmethod backward-one-expression (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) @@ -2137,12 +2137,16 @@ (defun down-list (mark syntax selector next-offset-fn target-offset-fn) (update-parse syntax 0 (offset mark)) - (labels ((find-offset (potential-form) + (labels ((next (continue-from) + (find-offset (funcall selector syntax + (funcall next-offset-fn continue-from)))) + (find-offset (potential-form) (typecase potential-form (list-form (funcall target-offset-fn potential-form)) + (form (or (find-list-child-offset potential-form target-offset-fn) + (next potential-form))) (null nil) - (t (find-offset (funcall selector syntax - (funcall next-offset-fn potential-form))))))) + (t (next potential-form))))) (let ((new-offset (find-offset (funcall selector syntax (offset mark))))) (when new-offset (setf (offset mark) new-offset)

1 0

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

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv27483/Drei/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Fixed the list-down movement commands for Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/12 11:37:20 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/13 17:10:24 1.14 @@ -838,6 +838,12 @@ (motion-fun-one-test (down lisp-syntax) (1 53 (15 16 13) "(defun list () (&rest elements) +(append elements nil))") + (2 54 (16 17 14) + "'(defun list () (&rest elements) +(append elements nil))") + (3 55 (17 18 15) + "#'(defun list () (&rest elements) (append elements nil))")) (motion-fun-one-test (up lisp-syntax)

1 0

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

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31563/Drei Modified Files: drei.lisp packages.lisp syntax.lisp views.lisp Log Message: Updated Drei documentation. Should now build, at least. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/11 02:44:13 1.25 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/13 10:33:09 1.26 @@ -345,7 +345,12 @@ ;; Main redisplay entry point. (defgeneric display-drei (drei) - (:documentation "Display the given Drei instance.")) + (:documentation "`Drei' must be an object of type `drei' and +`frame' must be a CLIM frame containing the editor pane of +`drei'. If you define a new subclass of `drei', you must define a +method for this generic function. In most cases, methods defined +on this function will merely be a trampoline to a function +specific to the given Drei variant.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/10 11:17:00 1.39 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/13 10:33:09 1.40 @@ -145,7 +145,7 @@ (defpackage :drei-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils) - (:export #:syntax #:syntax-command-tables #:update-parse #:syntaxp + (:export #:syntax #:syntax-command-tables #:updater-fns #:update-parse #:syntaxp #:define-syntax #:*default-syntax* #:syntax-command-table #:additional-command-tables #:define-syntax-command-table #:eval-option --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/13 10:32:11 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/13 10:33:10 1.14 @@ -29,7 +29,14 @@ :reader command-table) (%updater-fns :initarg :updater-fns :initform '() - :accessor updater-fns)) + :accessor updater-fns + :documentation "A list of functions that are +called whenever a syntax function needs up-to-date syntax +information. `Update-syntax' is never called directly by syntax +commands. Each function should take two arguments, integer +offsets into the buffer of the syntax delimiting the region that +must have an up-to-date parse. These arguments should be passed +on to a call to `update-syntax'.")) (:metaclass modual-class) (:documentation "The base class for all syntaxes.")) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/11 02:44:13 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/13 10:33:10 1.18 @@ -502,7 +502,9 @@ :initform (make-instance 'drei-buffer) :initarg :buffer :type drei-buffer - :accessor buffer) + :accessor buffer + :documentation "The buffer that is observed by this +buffer view.") (%top :accessor top :documentation "The top of the displayed buffer, that is, the mark indicating the first visible object in the buffer.") @@ -533,7 +535,9 @@ is, used for display right now.")) (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' -object.")) +object. The buffer is displayed on a simple line-by-line basis, +with top and bot marks delimiting the visible region. These marks +are automatically set if applicable.")) (defmethod initialize-instance :after ((view drei-buffer-view) &rest initargs) (declare (ignore initargs)) @@ -566,7 +570,9 @@ (invalidate-line-strokes line :modified t))))) (defclass drei-syntax-view (drei-buffer-view) - ((%syntax :accessor syntax) + ((%syntax :accessor syntax + :documentation "An instance of the syntax class used +for this syntax view.") (%prefix-size :accessor prefix-size :initform 0 :documentation "The number of unchanged objects @@ -763,7 +769,11 @@ (%dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) (%overwrite-mode :initform nil :accessor overwrite-mode)) (:metaclass modual-class) - (:default-initargs :use-editor-commands t)) + (:default-initargs :use-editor-commands t) + (:documentation "The \"default\" Drei view class. It displays a +textual representation of the buffer, possibly with syntax +highlighting, and maintains point and mark marks into the buffer, +in order to permit useful editing commands.")) (defmethod create-view-cursors nconc ((output-stream extended-output-stream) (view textual-drei-syntax-view))

1 0

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

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv31563/Doc Modified Files: drei.texi Log Message: Updated Drei documentation. Should now build, at least. --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/12/08 08:53:58 1.10 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2008/01/13 10:33:09 1.11 @@ -65,7 +65,8 @@ Every Drei instance is associated with an editor pane - this must be a CLIM stream pane that is used for redisplay (@pxref{Redisplay Protocol}). This is not necessarily the same object as the Drei instance -itself, but it can be. +itself, but it can be. (With a little work, the editor pane can be +@cl{NIL}, which is useful for resting.) For each Drei instance, Drei attempts to simulate an application top-level loop with something called a @i{pseudo command loop}, and @@ -163,6 +164,7 @@ * Buffer Modification Protocol:: * DREI-BASE Package:: * Syntax Protocol:: +* View Protocol:: * Unit Protocol:: * Redisplay Protocol:: * Undo Protocol:: @@ -478,9 +480,9 @@ @node Syntax Protocol @subsection Syntax Protocol -A buffer always has a syntax module associated with it. The syntax -module usually consists of an incremental parser that analyzes the -contents of the buffer and creates some kind of parse tree or other +A syntax module is an object that can be associated with a buffer. The +syntax module usually consists of an incremental parser that analyzes +the contents of the buffer and creates some kind of parse tree or other representation of the contents in order that it can be exploited by the redisplay module and by user commands. @@ -518,43 +520,46 @@ @item etc. @end itemize -The view that the syntax module has of the buffer is updated only when -needed, and then only for the parts of the buffer that are needed. -Most syntax modules (such as for programming languages) need to -compute their representations from the beginning of the buffer up to a -particular point beyond which the structure of the buffer does not -need to be known. +The ideal is that the view that the syntax module has of the buffer is +updated only when needed, and then only for the parts of the buffer that +are needed, though implementing this in practise is decidedly +nontrivial. Most syntax modules (such as for programming languages) +need to compute their representations from the beginning of the buffer +up to a particular point beyond which the structure of the buffer does +not need to be known. -There are three situations where updating might be needed: +There are two primary situations where updating might be needed: @itemize @bullet -@item once, before any panes are displayed to inform the syntax module -that some part of the buffer has been altered, -@item once for each pane on display, before redisplay is about to show -the contents of part of the buffer in a pane to inform the syntax +@item Before redisplay is about to show +the contents of part of the buffer in a pane, to inform the syntax module that its syntax must be valid in the particular region on display, @item as a result of a command that exploits the syntactic entities of the buffer contents. @end itemize -The first case is handled by the redisplay invoking the following -generic function: +These two cases do boil down to ``whenever there is need for the syntax +information to be correct'', however. -@include fun-drei-syntax-update-syntax.texi - -The second case is handled by the following generic function: +The first case is handled by the invocation of a single generic function: -@include fun-drei-syntax-update-syntax-for-display.texi - -The third case is handled by the syntax module itself when needed in -order to correctly compute the effects of a command. +@include fun-drei-syntax-update-syntax.texi It is important to realize that the syntax module is not directly involved in displaying buffer contents in a pane. In fact, the syntax -module should work even if there is no graphic user interface -present, and it should be exploitable by several, potentially totally -different, display units. +module should work even if there is no graphic user interface present, +and it should be exploitable by several, potentially totally different, +display units. + +The second case is slightly trickier, as any views of the syntax should +be informed that it has reparsed some part of the buffer. Since +@cl{update-syntax} is only called by views, the view can easily record +the fact that some part of the buffer has an up-to-date parse. Thus, +functions accessing syntax information must go to some length to make +sure that the view of the syntax is notified of any reparses. + +@include fun-drei-syntax-update-parse.texi @node Incremental Parsing Framework @subsubsection Incremental Parsing Framework @@ -684,6 +689,40 @@ a symbol. These forms typically contain initargs, and will be passed as additional arguments to @code{(make-instance '@var{symbol})}. +@node View Protocol +@subsection View Protocol +@cindex view protocol +@cindex views + +Drei extends CLIMs concept of ``views'' to be more than just a manner +for determining the user interface for accepting values from the +user. Instead, the view is what controls the user interface of the Drei +instance the user is interacting with. To simplify the discussion, this +section assumes that the view is always associated with a single +buffer. A buffer does not have to be associated with a view, and may be +associated with many views, though each view may only have a single +buffer. The view controls how the buffer is displayed to the user, and +which commands are available to the user for modifying the buffer. A +view may use a syntax module to maintain syntactical information about +the buffer contents, and use the resulting information to highlight +parts of the buffer based on its syntactical value (``syntax +highlighting''). + +@include class-drei-drei-view.texi + +@include class-drei-drei-buffer-view.texi + +@include method-drei-buffer-buffer-nil-drei-buffer-view.texi + +@include class-drei-drei-syntax-view.texi + +@include class-drei-point-mark-view.texi + +The @cl{synchronize-view} generic function is the heart of all view +functionality. + +@include fun-drei-synchronize-view.texi + @node Unit Protocol @subsection Unit Protocol @cindex Drei unit protocol @@ -821,31 +860,23 @@ A buffer can be on display in several panes, possibly by being located in several Drei instances. Thus, the buffer does not concern itself with -redisplay, but assumes that its host Drei instance will redisplay when +redisplay, but assumes that whatever is using it will redisplay when appropriate. There is no predictable definitive rule for when a Drei -will be redisplayed, but when it is, it will be done by calling the -following generic function. +instance will be redisplayed, but when it is, it will be done by calling +the following generic function. -@deffn {Generic Function} {display-drei} frame drei -@findex display-drei +@include fun-drei-display-drei.texi -@var{Drei} must be an object of type @class{drei} and @var{frame} must -be a CLIM frame containing the editor pane of @var{drei}. If you define -a new subclass of @var{drei}, you must define a method for this generic -function. In most cases, methods defined on this function will merely be -a trampoline to a function specific to the given Drei. -@end deffn - -The redisplay engine supports syntax-specific customization of the -display in order to facilitate such functionality as syntax -highlighting. This is done through the following two generic functions, -both of which have sensible default methods defined by the Fundamental -syntax, so if your syntax is a subclass of @class{fundamental-syntax}, -you do not need to define them. +The redisplay engine supports view-specific customization of the display +in order to facilitate such functionality as syntax highlighting. This +is done through the following two generic functions, both of which have +sensible default methods defined by @class{drei-buffer-view} and +@class{drei-syntax-view}, so if your view is a subclass of either of +these, you do not need to define them yourself. -@include fun-drei-display-drei-contents.texi +@include fun-drei-display-drei-view-contents.texi -@include fun-drei-display-drei-cursor.texi +@include fun-drei-display-drei-view-cursor.texi @node Undo Protocol @subsection Undo Protocol @@ -1230,8 +1261,6 @@ @include class-drei-syntax-syntax-command-table.texi -@include fun-drei-syntax-use-editor-commands-p.texi - @include fun-drei-syntax-additional-command-tables.texi @include macro-drei-syntax-define-syntax-command-table.texi

1 0

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

13 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31443/Drei Modified Files: syntax.lisp Log Message: Made drei-syntax:update-parse work even without updater-functions. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/11 02:44:13 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/13 10:32:11 1.13 @@ -50,9 +50,13 @@ "Make sure the parse for `syntax' from offset `begin' to `end' is up to date. `Begin' and `end' default to 0 and the size of the buffer of `syntax', respectively." - (map nil #'(lambda (updater) - (funcall updater begin end)) - (updater-fns syntax))) + (if (null (updater-fns syntax)) + ;; Just call `update-syntax' manually. We assume the entire + ;; buffer has changed. + (update-syntax syntax 0 0 begin end) + (map nil #'(lambda (updater) + (funcall updater begin end)) + (updater-fns syntax)))) (define-condition no-such-operation (simple-error) ()

1 0

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

12 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8770/Drei Modified Files: drawing-options.lisp Log Message: Change to some prettier (IMO) syntax highlighting colours than default Emacs. --- /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/07 23:00:51 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/drawing-options.lisp 2008/01/12 11:44:56 1.4 @@ -61,33 +61,37 @@ ;;; 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+)) +(defvar *keyword-drawing-options* + (make-drawing-options :face (make-face :ink +red3+)) "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+)) +(defvar *special-operator-drawing-options* + (make-drawing-options :face (make-face :ink +steel-blue+ + :style (make-text-style nil :bold nil))) "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+)) +(defparameter *special-variable-drawing-options* + (make-drawing-options :face (make-face :ink +darkgoldenrod4+)) "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.") -(defvar *string-drawing-options* (make-drawing-options - :face (make-face :ink +rosy-brown+ - :style (make-text-style nil :italic nil))) +(defvar *string-drawing-options* + (make-drawing-options :face (make-face :ink +green4+)) "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))) +(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+)) +(defvar *error-drawing-options* + (make-drawing-options :face (make-face :ink +red+)) "The drawing options used for drawing syntax errors.")

1 0

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

12 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6351/Drei Modified Files: lisp-syntax.lisp Log Message: Changed the semantics for expression movement (now not identical to Emacs). --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 10:52:24 1.65 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 11:37:21 1.66 @@ -2038,9 +2038,8 @@ (not (= (offset mark) (end-offset potential-form)))) (typecase potential-form (reader-conditional-form - (setf (offset mark) (end-offset - (or (first-form (children potential-form)) - potential-form)))) + (setf (offset mark) (or (start-offset (first-form (children potential-form))) + (end-offset potential-form)))) (t (setf (offset mark) (end-offset potential-form))))))) (defmethod forward-delete-expression (mark (syntax lisp-syntax) &optional (count 1)

1 0

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

12 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv6351/Drei/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Changed the semantics for expression movement (now not identical to Emacs). --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/10 11:03:39 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/12 11:37:20 1.13 @@ -825,9 +825,9 @@ (51 0 (11 28 7) "(defun list (&rest elements) (append elements nil))") - (nil nil (5 18 9) + (nil nil (5 18 2) "#+nil (list 1 2 3)") - (nil nil (0 5 nil) + (nil nil (0 2 nil) "#+nil (list 1 2 3)")) (motion-fun-one-test (list lisp-syntax)

1 0

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

12 Jan '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv334 Modified Files: package.lisp views.lisp Log Message: Added stub classes and constants for gadget views. Programs using these will at least compile now, though they may not work. Hopefully, this batch of stub views will be like a sad puppy in the corner, sooner or later guilting someone into finishing the implementation. --- /project/mcclim/cvsroot/mcclim/package.lisp 2007/11/19 20:28:44 1.63 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/01/12 11:04:05 1.64 @@ -873,6 +873,8 @@ #:line-style-unit ;generic function #:linep ;predicate #:list-pane ;class + #:list-pane-view ;class + #:+list-pane-view+ ;constant #:lookup-keystroke-command-item ;function #:lookup-keystroke-item ;function #:make-3-point-transformation ;function @@ -1039,6 +1041,8 @@ #:open-stream-p ;generic function #:open-window-stream ;function #:option-pane ;class + #:option-pane-view ;class + #:+option-pane-view+ ;constant #:or ;presentation type #:oriented-gadget-mixin ;class #:outlined-pane ;pane @@ -1167,6 +1171,8 @@ #:propagate-output-record-changes-p ;generic function #:push-button ;class #:push-button-pane ;class + #:push-button-view ;class + #:+push-button-view+ ;constant #:push-button-show-as-default ;generic function #:queue-event ;generic function #:queue-repaint ;generic function @@ -1175,6 +1181,8 @@ #:radio-box-current-selection ;generic function #:radio-box-pane ;class #:radio-box-selections ;generic function + #:radio-box-view ;class + #:+radio-box-view+ ;class #:raise-frame ;generic function #:raise-mirror ;generic function #:raise-sheet ;generic function @@ -1313,6 +1321,8 @@ #:slider ;class #:slider-drag-callback ;generic function #:slider-pane ;class + #:slider-view ;slider-view + #:+slider-view+ ;constant #:space-requirement ;class #:space-requirement+ ;function #:space-requirement+* ;function @@ -1464,6 +1474,8 @@ #:text-displayed-output-record-string ;generic function #:text-editor ;class #:text-editor-pane ;class + #:text-editor-view ;class + #:+text-editor-view+ ;constant #:text-field ;class #:text-field-pane ;class #:text-field-view ;class (Franz User's Guide) @@ -1489,6 +1501,8 @@ #:toggle-button ;class #:toggle-button-indicator-type ;generic function #:toggle-button-pane ;class + #:toggle-button-view ;class + #:+toggle-button-view+ ;constant #:token-or-type ;presentation type abbrev #:tracking-pointer ;macro #:transform-distance ;generic function --- /project/mcclim/cvsroot/mcclim/views.lisp 2006/03/10 21:58:13 1.7 +++ /project/mcclim/cvsroot/mcclim/views.lisp 2008/01/12 11:04:05 1.8 @@ -42,11 +42,35 @@ (defclass pointer-documentation-view (textual-view) ()) -;;; Views described in the Franz User manual... +;;; Views described in the Franz User manual (CLIM 2.2)... + +(defclass toggle-button-view (gadget-view) + ()) + +(defclass push-button-view (gadget-view) + ()) + +(defclass radio-box-view (gadget-view) + ()) + +(defclass check-box-view (gadget-view) + ()) + +(defclass slider-view (gadget-view) + ()) (defclass text-field-view (gadget-dialog-view) ((width :accessor width :initarg :width :initform nil))) +(defclass text-editor-view (gadget-view) + ()) + +(defclass list-pane-view (gadget-view) + ()) + +(defclass option-pane-view (gadget-view) + ()) + (defparameter +textual-view+ (make-instance 'textual-view)) (defparameter +textual-menu-view+ (make-instance 'textual-menu-view)) @@ -59,11 +83,24 @@ (defparameter +gadget-dialog-view+ (make-instance 'gadget-dialog-view)) -(defparameter +pointer-documentation-view+ - (make-instance 'pointer-documentation-view)) +(defparameter +pointer-documentation-view+ (make-instance 'pointer-documentation-view)) + +(defparameter +toggle-button-view+ (make-instance 'toggle-button-view)) + +(defparameter +push-button-view+ (make-instance 'push-button-view)) + +(defparameter +radio-box-view+ (make-instance 'radio-box-view)) + +(defparameter +slider-view+ (make-instance 'slider-view)) (defparameter +text-field-view+ (make-instance 'text-field-view)) +(defparameter +text-editor-view+ (make-instance 'text-editor-view)) + +(defparameter +list-pane-view+ (make-instance 'list-pane-view)) + +(defparameter +option-pane-view+ (make-instance 'option-pane-view)) + (defmethod stream-default-view (stream) (declare (ignore stream)) +textual-view+)

1 0

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

12 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29151/Drei Modified Files: lisp-syntax.lisp Log Message: Make Drei forward-expression handle #+foo whatever properly through the magic of special cases. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/11 07:52:03 1.64 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/12 10:52:24 1.65 @@ -2036,7 +2036,12 @@ (form-around syntax (offset mark))))) (when (and (not (null potential-form)) (not (= (offset mark) (end-offset potential-form)))) - (setf (offset mark) (end-offset potential-form))))) + (typecase potential-form + (reader-conditional-form + (setf (offset mark) (end-offset + (or (first-form (children potential-form)) + potential-form)))) + (t (setf (offset mark) (end-offset potential-form))))))) (defmethod forward-delete-expression (mark (syntax lisp-syntax) &optional (count 1) (limit-action #'error-limit-action))

1 0

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

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22161/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax.lisp Log Message: Never, ever, try to do lazy parsing in Lisp syntax, the potential for disaster is just too great. Changed all calls to update-parse to make sure the entire parse tree is up to date. Later specializations can be considered optimisation. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/10 11:17:00 1.13 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/11 07:52:03 1.14 @@ -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/10 11:17:00 1.63 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/11 07:52:03 1.64 @@ -1161,7 +1161,7 @@ package can be found at all, or the otherwise found packages are invalid, return the value of `*package*'." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let* ((designator (rest (find offset (package-list syntax) :key #'first :test #'>=)))) @@ -1183,7 +1183,7 @@ form can be found, return the package specified in the attribute list. If no such package is specified, return \"CLIM-USER\"." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (flet ((normalise (designator) (typecase designator (symbol @@ -1421,7 +1421,7 @@ "Return the list form that `mark-or-offset' is inside, or NIL if no such form exists." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (if (and (form-list-p form-around) @@ -1559,7 +1559,7 @@ (defun in-type-p (syntax mark-or-offset type) (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (with-slots (stack-top) syntax (if (or (null (start-offset stack-top)) (> offset (end-offset stack-top)) @@ -1626,7 +1626,7 @@ (:method ((syntax lisp-syntax) (form form) (offset integer)) nil) (:method :before ((syntax lisp-syntax) (form form) (offset integer)) - (update-parse syntax 0 offset))) + (update-parse syntax))) (defgeneric at-end-of-form-p (syntax form offset) (:documentation "Return true if `offset' is at the end of the @@ -1634,7 +1634,7 @@ (:method ((syntax lisp-syntax) (form form) (offset integer)) nil) (:method :before ((syntax lisp-syntax) (form form) (offset integer)) - (update-parse syntax 0 offset))) + (update-parse syntax))) (defmethod at-beginning-of-form-p ((syntax lisp-syntax) (form list-form) (offset integer)) @@ -1666,7 +1666,7 @@ is defined by what type of form is at `mark-or-offset', but for a list form, it would be right after the opening parenthesis." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (labels ((recurse (form) @@ -1681,7 +1681,7 @@ is defined by what type of form is at `mark-or-offset', but for a list form, it would be right before the closing parenthesis." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around (labels ((recurse (form) @@ -1696,7 +1696,7 @@ defined as the earliest point the contents could be entered, for example right after the opening parenthesis for a list." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-list-p form-around) (at-beginning-of-form-p syntax form-around offset))))) @@ -1707,7 +1707,7 @@ latest point the contents could be entered, for example right before the closing parenthesis for a list." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-list-p form-around) (at-end-of-form-p syntax (form-around syntax offset) offset))))) @@ -1717,7 +1717,7 @@ beginning of a string form, false otherwise. \"Beginning\" is right after the opening double-quote." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-string-p form-around) (at-beginning-of-form-p syntax form-around offset))))) @@ -1727,7 +1727,7 @@ a list-like form, false otherwise. \"End\" is right before the ending double-quote." (as-offsets ((offset mark-or-offset)) - (update-parse syntax 0 offset) + (update-parse syntax) (let ((form-around (form-around syntax offset))) (when (form-string-p form-around) (at-end-of-form-p syntax form-around offset))))) @@ -1882,7 +1882,7 @@ ;;; exploit the parse (defun form-before-in-children (syntax children offset) - (update-parse syntax 0 offset) + (update-parse syntax) (loop for (first . rest) on children if (formp first) do @@ -1910,7 +1910,7 @@ "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") - (update-parse syntax 0 offset) + (update-parse syntax) (or (gethash offset (form-before-cache syntax)) (setf (gethash offset (form-before-cache syntax)) (with-slots (stack-top) syntax @@ -1920,7 +1920,7 @@ (form-before-in-children syntax (children stack-top) offset)))))) (defun form-after-in-children (syntax children offset) - (update-parse syntax 0 offset) + (update-parse syntax) (loop for child in children if (formp child) do (cond ((< (start-offset child) offset (end-offset child)) @@ -1943,7 +1943,7 @@ "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") - (update-parse syntax 0 offset) + (update-parse syntax) (or (gethash offset (form-after-cache syntax)) (setf (gethash offset (form-after-cache syntax)) (with-slots (stack-top) syntax @@ -1953,7 +1953,7 @@ (form-after-in-children syntax (children stack-top) offset)))))) (defun form-around-in-children (syntax children offset) - (update-parse syntax 0 offset) + (update-parse syntax) (loop for child in children if (formp child) do (cond ((or (<= (start-offset child) offset (end-offset child)) @@ -1972,7 +1972,7 @@ "Offset past buffer end") (assert (>= offset 0) nil "Offset before buffer start") - (update-parse syntax 0 offset) + (update-parse syntax) (or (gethash offset (form-around-cache syntax)) (setf (gethash offset (form-around-cache syntax)) (with-slots (stack-top) syntax

1 0

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

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4196 Modified Files: NEWS Log Message: Added mention of MCCLIM-IMAGES to NEWS. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/11/21 22:33:50 1.27 +++ /project/mcclim/cvsroot/mcclim/NEWS 2008/01/11 06:01:38 1.28 @@ -4,6 +4,8 @@ ** Bug fix: Some missing methods and functions have been implemented for the Null backend, allowing headless operation for many applications. +** New extension: MCCLIM-IMAGES. This extension makes it easy to use + McCLIM for loading and displaying images of various formats. * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples,

1 0

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

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Extensions/Images In directory clnet:/tmp/cvs-serv2033/Extensions/Images Modified Files: gif.lisp image-viewer.lisp images.lisp jpeg.lisp package.lisp xpm.lisp Log Message: Changed MCCLIM-IMAGES:LOAD-IMAGE to create an instance of an image class containing size information. Fixex JPEG reading. --- /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/09 10:20:23 1.3 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/gif.lisp 2008/01/11 06:00:06 1.4 @@ -23,10 +23,11 @@ (define-image-reader "gif" (image-pathname &key) (let* ((data-stream (skippy:load-data-stream image-pathname)) (first-image (aref (skippy:images data-stream) 0)) - (pattern-array (make-array (list (skippy:height first-image) - (skippy:width first-image)))) + (image-height (skippy:height first-image)) + (image-width (skippy:width first-image)) + (pattern-array (make-array (list image-height image-width))) (designs (coerce (loop with color-table = (skippy:color-table data-stream) - with transparency-index = (skippy:transparency-index first-image) + with transparency-index = (skippy:transparency-index first-image) for i below (skippy:color-table-size color-table) when (and transparency-index (= i transparency-index)) collect +transparent-ink+ @@ -35,7 +36,8 @@ (skippy:color-rgb (skippy:color-table-entry color-table i)) (make-rgb-color (/ r 255) (/ g 255) (/ b 255)))) 'vector))) - (dotimes (y (array-dimension pattern-array 0)) - (dotimes (x (array-dimension pattern-array 1)) + (dotimes (y image-height) + (dotimes (x image-width) (setf (aref pattern-array y x) (skippy:pixel-ref first-image x y)))) - (make-pattern pattern-array designs))) + (make-image (make-pattern pattern-array designs) + image-height image-width))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/09 19:27:39 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/image-viewer.lisp 2008/01/11 06:00:06 1.2 @@ -45,6 +45,10 @@ ;; 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)))) + ;; Try to ensure there is room for the new image. + (change-space-requirements pane + :height (image-height (gadget-value pane)) + :width (image-width (gadget-value pane))) + ;; Draw the new one, if there is one. + (draw-image pane (gadget-value pane)))) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/images.lisp 2008/01/11 06:00:06 1.2 @@ -27,7 +27,7 @@ file to be read, and any keyword arguments provided by the user.") -(defun image-format-supported (format) +(defun image-format-supported-p (format) "Return true if `format' is supported by `load-image'." (not (null (gethash format *image-readers*)))) @@ -49,18 +49,42 @@ image format `format'." (error 'unsupported-image-format :image-format format)) +(defclass image () + ((%image-design :reader image-design + :initarg :image-design + :initform (error "A design must be provided for the image")) + (%width :reader image-width + :initarg :image-width + :initform (error "A width must be provided for the image")) + (%height :reader image-height + :initarg :image-height + :initform (error "A width must be provided for the image")))) + +(defun make-image (design height width) + "Make and return an instance of `image' with the specified +`design', `width' and `height'." + (make-instance 'image :image-design design + :image-height height + :image-width width)) + +(defun draw-image (stream image) + "Draw `image' to `stream'. `Stream' must be a sufficiently +powerful output stream (probably an `extended-output-stream')." + (draw-design stream (image-design image))) + (defun load-image (image-pathname &rest args &key) "Load an image from `image-pathname', with the format of the -image being the pathname-type of `image-pathname'. `Args' can be -any keyword-arguments, they will be passed on to the image reader -function for the relevant image format. If the image format is -not recognised, an error of type `unsupprted-image-format' will -be signalled." +image being the pathname-type of `image-pathname'. Returns an +instance of class `image'. `Args' can be any keyword-arguments, +they will be passed on to the image reader function for the +relevant image format. If the image format is not recognised, an +error of type `unsupprted-image-format' will be signalled." (apply #'load-image-of-format (pathname-type image-pathname) image-pathname args)) (defun load-image-of-format (format image-pathname &rest args &key) - "Load an image of format `format' from `image-pathname'. `Args' + "Load an image of format `format' from +`image-pathname'. Returns an instance of class `image'. `Args' can be any keyword-arguments, they will be passed on to the image reader function for `format'. If the image format is not recognised, an error of type `unsupprted-image-format' will be --- /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/07 12:54:02 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/jpeg.lisp 2008/01/11 06:00:06 1.3 @@ -31,15 +31,18 @@ (rgb-image (make-instance 'clim-internals::rgb-image :width width :height height :alphap nil :data rgb-image-data))) - (loop for y from (1- height) downto 0 do - (loop for x from (1- width) downto 0 do - (let ((grey (svref rgb (+ x (* y width))))) - (setf (aref rgb-image-data y x) - (dpb grey (byte 8 0) - (dpb grey (byte 8 8) - (dpb grey (byte 8 16) - (dpb (- 255 0) (byte 8 24) 0)))))))) - (clim-internals::make-rgb-image-design rgb-image))))) + (dotimes (x width) + (dotimes (y height) + (let ((blue (aref rgb (+ (* x 3) (* y width 3)))) + (green (aref rgb (+ (* x 3) (* y width 3) 1))) + (red (aref rgb (+ (* x 3) (* y width 3) 2)))) + (setf (aref rgb-image-data y x) + (dpb red (byte 8 0) + (dpb green (byte 8 8) + (dpb blue (byte 8 16) + (dpb (- 255 0) (byte 8 24) 0)))))))) + (make-image (clim-internals::make-rgb-image-design rgb-image) + height width))))) (define-image-reader "jpg" (pathname) (load-image-of-format "jpeg" pathname)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/09 19:27:39 1.2 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/package.lisp 2008/01/11 06:00:06 1.3 @@ -22,7 +22,9 @@ (defpackage :mcclim-images (:use :clim-lisp :clim) - (:export :export #:image-format-supported + (:export #:image-format-supported-p + #:image #:image-width #:image-height + #:draw-image #:load-image #:load-image-of-format #:unsupported-image-format #:image-format #:image-viewer #:image-viewer-pane)) --- /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/06 08:36:57 1.1 +++ /project/mcclim/cvsroot/mcclim/Extensions/Images/xpm.lisp 2008/01/11 06:00:06 1.2 @@ -442,7 +442,10 @@ (define-image-reader "xpm" (pathname &key) (with-open-file (input pathname :element-type '(unsigned-byte 8)) - (xpm-parse-stream input))) + (let ((pattern (xpm-parse-stream input))) + (make-image pattern + (pattern-height pattern) + (pattern-width pattern))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

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

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv2033/Apps/Listener Modified Files: dev-commands.lisp Log Message: Changed MCCLIM-IMAGES:LOAD-IMAGE to create an instance of an image class containing size information. Fixex JPEG reading. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/09 17:19:47 1.44 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/01/11 06:00:04 1.45 @@ -1424,7 +1424,7 @@ (if (probe-file image-pathname) (handler-case (with-room-for-graphics () - (draw-design *standard-output* (mcclim-images:load-image image-pathname))) + (mcclim-images:draw-image *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)))

1 0

[mcclim-cvs] CVS mcclim/Backends/CLX
by thenriksen 11 Jan '08

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv871/Backends/CLX Modified Files: medium.lisp Log Message: Draw images from the upper-left corner in the CLX backend. Strange sense of deja-vu. Didn't I fix this already? --- /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/06 01:37:06 1.83 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/medium.lisp 2008/01/11 05:55:52 1.84 @@ -1200,10 +1200,10 @@ :clip-x x :clip-y (- y height)) (xlib:copy-area pixmap gcontext 0 0 width height - da x (- y height)))) + da x y))) (t (xlib:copy-area pixmap gcontext 0 0 width height - da x (- y height))))))))) + da x y)))))))) (defmethod climi::medium-free-image-design ((medium clx-medium) (design climi::rgb-image-design))

1 0

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

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv24404/ESA Modified Files: packages.lisp utils.lisp Log Message: Changed the Drei/ESA modes-idea to work through metaclasses, enabling default modes. --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/07 22:01:59 1.10 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/01/11 02:44:14 1.11 @@ -23,7 +23,7 @@ ;;; Package definitions for ESA. (defpackage :esa-utils - (:use :clim-lisp) + (:use :clim-lisp :clim-mop) (:export #:with-gensyms #:once-only #:unlisted @@ -50,7 +50,7 @@ #:observer-notified #:notify-observers #:name-mixin #:name #:subscriptable-name-mixin #:subscripted-name #:subscript #:subscript-generator - #:mode #:modual-mixin + #:mode #:modual-class #:available-modes #:mode-directly-applicable-p #:mode-applicable-p #:mode-enabled-p @@ -58,7 +58,8 @@ #:nonapplicable-mode #:change-class-for-enabled-mode #:change-class-for-disabled-mode - #:enable-mode #:disable-mode)) + #:enable-mode #:disable-mode + #:add-default-modes #:remove-default-modes)) (defpackage :esa (:use :clim-lisp :clim :esa-utils) --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/09 18:21:44 1.8 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2008/01/11 02:44:14 1.9 @@ -364,23 +364,61 @@ () (:documentation "A superclass for all modes.")) -(defclass modual-mixin () - ((%original-class-name :accessor original-class-name - :documentation "The original name of the -class the `modual-mixin' is part of, the actual name will change -as modes are added and removed.")) - (:documentation "A mixin for objects supporting modes.")) +(defconstant +default-modes-plist-symbol+ 'modual-class-default-modes + "The symbol that is pushed onto the property list of the name +of a class to contain the list of default modes for the class.") + +(defun default-modes (modual-class) + "Return the list of default modes for `modual-class', which +must be a symbol and the name of a modual class. The modes are +returned as a list of conses, with the car of each cons being the +name of the mode as a symbol, and the cdr of each cons being a +list of initargs" + (getf (symbol-plist modual-class) +default-modes-plist-symbol+)) + +(defun (setf default-modes) (new-default-modes modual-class) + "Set the list of default modes for `modual-class', which must +be a symbol and the name of a modual class. The modes should be +given as a list of conses, with the car of each cons being the +name of the mode as a symbol, and the cdr of each cons being a +list of initargs" + (setf (getf (symbol-plist modual-class) +default-modes-plist-symbol+) + new-default-modes)) -(defmethod initialize-instance :after ((object modual-mixin) &rest initargs) +(defclass modual-class (standard-class) + () + (:documentation "A metaclass for defining classes supporting +changing of modes.")) + +(defmethod validate-superclass ((c1 modual-class) (c2 standard-class)) + t) + +(defmethod compute-slots ((c modual-class)) + (append (call-next-method) + (list (make-instance 'standard-effective-slot-definition + :name '%original-class-name + :allocation :instance + :documentation "The original name of the class +the `modual-mixin' is part of, the actual name will change as +modes are added and removed.")))) + +(defmethod make-instance ((class modual-class) &rest initargs) (declare (ignore initargs)) - (setf (original-class-name object) (class-name (class-of object)))) + (let ((instance (call-next-method))) + (setf (slot-value instance '%original-class-name) + (class-name class)) + (dolist (class (reverse (class-precedence-list class)) instance) + (when (symbolp (class-name class)) + (dolist (mode-and-initargs (default-modes (class-name class))) + (apply #'enable-mode instance (first mode-and-initargs) + (rest mode-and-initargs))))))) (defgeneric available-modes (modual) (:documentation "Return all available modes for `modual'. Not all of the modes may be applicable, use the `applicable-modes' function if you're only interested in these.") (:method-combination append) - (:method append ((modual modual-mixin)) + (:method append ((modual t)) '())) (defgeneric mode-directly-applicable-p (modual mode-name) @@ -391,7 +429,7 @@ \"opt-out\" where a mode can forcefully prevent another specific mode from being enabled. ") (:method-combination or) - (:method or ((modual modual-mixin) mode-name) + (:method or ((modual t) mode-name) nil)) (defgeneric mode-applicable-p (modual mode-name) @@ -402,21 +440,21 @@ a sort of \"opt-out\" where a mode can forcefully prevent another specific mode from being enabled. ") (:method-combination or) - (:method or ((modual modual-mixin) mode-name) + (:method or ((modual t) mode-name) (mode-directly-applicable-p modual mode-name))) (defgeneric enabled-modes (modual) (:documentation "Return a list of the names of the modes directly enabled for `modual'.") (:method-combination append) - (:method append ((modual modual-mixin)) + (:method append ((modual t)) '())) (defgeneric mode-enabled-p (modual mode-name) (:documentation "Return true if `mode-name' is enabled for `modual' or any modual \"sub-objects\"." ) (:method-combination or) - (:method or ((modual modual-mixin) mode-name) + (:method or ((modual t) mode-name) (member mode-name (enabled-modes modual) :test #'equal))) (define-condition nonapplicable-mode (error) @@ -445,7 +483,7 @@ `modual', using `initargs' as options for the mode. If the mode is already enabled, do nothing. If the mode is not applicable to `modual', signal an `nonapplicable-mode' error.") - (:method :around ((modual modual-mixin) mode-name &rest initargs) + (:method :around ((modual t) mode-name &rest initargs) (declare (ignore initargs)) (unless (mode-enabled-p modual mode-name) (call-next-method)))) @@ -454,7 +492,7 @@ (:documentation "Disable the mode of the name `mode-name' for `modual'. If a mode of the provided name is not enabled, do nothing.") - (:method :around ((modual modual-mixin) mode-name) + (:method :around ((modual t) mode-name) (when (mode-enabled-p modual mode-name) (call-next-method)))) @@ -478,7 +516,8 @@ ;; Avert thine eyes, thy of gentle spirit. (if (null modes) (find-class modual) - (eval `(defclass ,(gensym) (,modual ,@modes) ())))) + (eval `(defclass ,(gensym) (,modual ,@modes) () + (:metaclass modual-class))))) (defun find-class-implementing-modes (modual modes) "Find, possibly create, the class implementing `modual' (a @@ -498,7 +537,7 @@ "Change the class of `modual' so that it has a mode of name `mode-name', created with the provided `initargs'." (apply #'change-class modual (find-class-implementing-modes - (original-class-name modual) + (slot-value modual '%original-class-name) (cons mode-name (enabled-modes modual))) initargs)) @@ -506,15 +545,44 @@ "Change the class of `modual' so that it does not have a mode of name `mode-name'." (change-class modual (find-class-implementing-modes - (original-class-name modual) + (slot-value modual '%original-class-name) (remove mode-name (enabled-modes modual) :test #'equal)))) -(defmethod enable-mode ((modual modual-mixin) mode-name &rest initargs) +(defmethod enable-mode ((modual t) mode-name &rest initargs) (if (mode-directly-applicable-p modual mode-name) (apply #'change-class-for-enabled-mode modual mode-name initargs) (nonapplicable-mode modual mode-name))) -(defmethod disable-mode ((modual modual-mixin) mode-name) +(defmethod disable-mode ((modual t) mode-name) (when (mode-directly-applicable-p modual mode-name) (change-class-for-disabled-mode modual mode-name))) + +(defmacro add-default-modes (modual-class &body modes) + "Add `modes' to the list of default modes for +`modual-class'. Will not replace any already existing modes. The +elements in `modes' can either be a single symbol, the name of a +mode, or a cons of the name of a mode and a list of initargs for +the mode. In the former case, no initargs will be given. Please +do not use default modes as a programming tool, they should be +reserved for user-oriented functionality." + (dolist (mode modes) + (let ((mode-name (unlisted mode))) + (check-type mode-name symbol) + ;; Take care not to add the same mode twice, this is risky enough + ;; as it is. + (setf (default-modes modual-class) + (cons (listed mode) + (delete mode-name (default-modes modual-class) :key #'first)))))) + +(defmacro remove-default-modes (modual-class &body modes) + "Remove `modes' from the list of default modes for +`modual-class'. `Modes' must be a list of names of modes in the +form of symbols. If a provided mode is not set as a default mode, +nothing will be done." + (dolist (mode modes) + (check-type mode symbol) + ;; Take care not to add the same mode twice, this is risky enough + ;; as it is. + (setf (default-modes modual-class) + (delete mode (default-modes modual-class) :key #'first))))

1 0

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

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24404 Modified Files: text-editor-gadget.lisp Log Message: Changed the Drei/ESA modes-idea to work through metaclasses, enabling default modes. --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2007/10/26 17:01:15 1.10 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2008/01/11 02:44:14 1.11 @@ -90,6 +90,7 @@ (defclass drei-editor-substrate (drei:drei-gadget-pane editor-substrate-mixin) () + (:metaclass esa-utils:modual-class) (:documentation "A class for Drei-based editor substrates.")) (defmethod (setf gadget-value) :after (value (gadget drei-editor-substrate) @@ -101,6 +102,7 @@ (defclass drei-text-field-substrate (text-field-substrate-mixin drei-editor-substrate) () + (:metaclass esa-utils:modual-class) (:documentation "The class for Drei-based text field substrates.")) (defmethod drei:handle-gesture ((drei drei-text-field-substrate) gesture) @@ -123,6 +125,7 @@ (defclass drei-text-editor-substrate (text-editor-substrate-mixin drei-editor-substrate) () + (:metaclass esa-utils:modual-class) (:documentation "The class for Drei-based text editor substrates.")) (defmethod compose-space ((pane drei-text-editor-substrate) &key width height)

1 0

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

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24404/Drei Modified Files: drei-clim.lisp drei.lisp syntax.lisp views.lisp Log Message: Changed the Drei/ESA modes-idea to work through metaclasses, enabling default modes. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/02 09:20:26 1.27 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/01/11 02:44:13 1.28 @@ -158,6 +158,7 @@ :display-function 'display-drei-pane :width 900 :active nil) + (:metaclass modual-class) (:documentation "An actual, instantiable Drei pane that permits (and requires) the host application to control the command loop completely.")) @@ -209,6 +210,7 @@ (%previous-focus :accessor previous-focus :initform nil :documentation "The pane that previously had keyboard focus")) + (:metaclass modual-class) (:default-initargs :command-executor 'execute-drei-command) (:documentation "An actual, instantiable Drei gadget with event-based command processing.")) @@ -336,6 +338,7 @@ editing area in the coordinate system of the encapsulated stream. An (X,Y) list, not necessarily the same as the position of the associated output record.")) + (:metaclass modual-class) (:default-initargs :command-executor 'execute-drei-command) (:documentation "A Drei editable area implemented as an output record.")) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/12/28 10:08:28 1.24 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2008/01/11 02:44:13 1.25 @@ -219,7 +219,7 @@ ;;; ;;; The basic Drei class. -(defclass drei (modual-mixin) +(defclass drei () ((%view :initform (make-instance 'textual-drei-syntax-view) :initarg :view :accessor view @@ -274,6 +274,7 @@ (%isearch-previous-string :initform nil :accessor isearch-previous-string) (%query-replace-mode :initform nil :accessor query-replace-mode) (%query-replace-state :initform nil :accessor query-replace-state)) + (:metaclass modual-class) (:default-initargs :active t :editable-p t) (:documentation "The abstract Drei class that maintains standard Drei editor state. It should not be directly --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/09 18:21:44 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2008/01/11 02:44:13 1.12 @@ -22,7 +22,7 @@ (in-package :drei-syntax) -(defclass syntax (name-mixin modual-mixin) +(defclass syntax (name-mixin) ((%buffer :initarg :buffer :reader buffer) (%command-table :initarg :command-table :initform (error "A command table has not been provided for this syntax") @@ -30,6 +30,7 @@ (%updater-fns :initarg :updater-fns :initform '() :accessor updater-fns)) + (:metaclass modual-class) (:documentation "The base class for all syntaxes.")) (defgeneric syntax-command-tables (syntax) @@ -287,6 +288,7 @@ ;; It must be just a command table. (find-command-table ,command-table)))))) default-initargs) + (:metaclass modual-class) ,@defclass-options)))) (defgeneric eval-option (syntax name value) --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/09 19:26:14 1.16 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/01/11 02:44:13 1.17 @@ -403,7 +403,7 @@ ;;; ;;; View classes. -(defclass drei-view (tabify-mixin subscriptable-name-mixin modual-mixin) +(defclass drei-view (tabify-mixin subscriptable-name-mixin) ((%active :accessor active :initform t :initarg :active @@ -436,6 +436,7 @@ `editor-table' - the command tables containing the editor commands will be added automatically, as long as this value is true.")) + (:metaclass modual-class) (:documentation "The base class for all Drei views. A view observes some other object and provides a visual representation for Drei.") @@ -530,6 +531,7 @@ :documentation "The number of lines in the views `displayed-lines' array that are actually live, that is, used for display right now.")) + (:metaclass modual-class) (:documentation "A view that contains a `drei-buffer' object.")) @@ -577,6 +579,7 @@ :initform -1 :documentation "The size of the buffer the last time the view was synchronized.")) + (:metaclass modual-class) (:documentation "A buffer-view that maintains a parse tree of the buffer, or otherwise pays attention to the syntax of the buffer.")) @@ -725,6 +728,7 @@ (defclass point-mark-view (drei-buffer-view) ((%point :initform nil :initarg :point :accessor point-of) (%mark :initform nil :initarg :mark :accessor mark-of)) + (:metaclass modual-class) (:documentation "A view class containing a point and a mark into its buffer.")) @@ -758,6 +762,7 @@ (%prefix-start-offset :initform nil :accessor prefix-start-offset) (%dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) (%overwrite-mode :initform nil :accessor overwrite-mode)) + (:metaclass modual-class) (:default-initargs :use-editor-commands t)) (defmethod create-view-cursors nconc ((output-stream extended-output-stream)

1 0

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

11 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv24404/Drei/Tests Modified Files: testing.lisp Log Message: Changed the Drei/ESA modes-idea to work through metaclasses, enabling default modes. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/12/08 08:53:48 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2008/01/11 02:44:12 1.8 @@ -88,6 +88,7 @@ () (:documentation "An instantiable Drei variant with no display. Used for testing.") + (:metaclass modual-class) (:default-initargs :no-cursors t)) (defmacro with-drei-environment ((&key (initial-contents "")

1 0

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

10 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16670/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax.lisp packages.lisp Log Message: Cleaned up form-operator, form-operands, added form-equal. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/09 11:14:08 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/01/10 11:17:00 1.13 @@ -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) + (update-parse syntax 0 offset) (let* ((form ;; Find a form with a valid (fboundp) operator. (let ((immediate-form @@ -584,12 +584,12 @@ ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. (operator (when (and form (form-list-p form)) - (form-to-object syntax (form-operator syntax form)))) + (form-to-object syntax (form-operator form)))) (operands (when (and form (form-list-p form)) (mapcar #'(lambda (operand) (when operand - (form-to-object syntax operand :no-error t))) - (form-operands syntax form)))) + (form-to-object syntax operand))) + (form-operands form)))) (current-operand-indices (when form (find-operand-info syntax offset form)))) (funcall continuation form operator current-operand-indices operands))) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/09 11:14:08 1.62 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/01/10 11:17:00 1.63 @@ -1212,28 +1212,28 @@ (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 @@ -1248,18 +1248,17 @@ (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) @@ -1351,26 +1350,26 @@ "Return the children of `form' that are themselves forms." (remove-if-not #'formp (children form))) -(defgeneric form-operator (syntax form) +(defgeneric form-operator (form) (:documentation "Return the operator of `form' as a - token. Returns nil if none can be found.") - (:method (form syntax) nil)) +token. Returns nil if none can be found.") + (:method (form) nil)) -(defmethod form-operator (syntax (form list-form)) +(defmethod form-operator ((form list-form)) (first-form (rest (children form)))) -(defmethod form-operator (syntax (form complete-quote-form)) +(defmethod form-operator ((form complete-quote-form)) (first-form (rest (children (second (children form)))))) -(defmethod form-operator (syntax (form complete-backquote-form)) +(defmethod form-operator ((form complete-backquote-form)) (first-form (rest (children (second (children form)))))) -(defgeneric form-operands (syntax form) +(defgeneric form-operands (form) (:documentation "Returns the operands of `form' as a list of tokens. Returns nil if none can be found.") - (:method (form syntax) nil)) + (:method (syntax) nil)) -(defmethod form-operands (syntax (form list-form)) +(defmethod form-operands ((form list-form)) (remove-if-not #'formp (rest-forms (children form)))) (defun form-toplevel (syntax form) @@ -2341,15 +2340,16 @@ a symbol and a package may be returned even if it was not found in a package, for example if you do `foo-pkg::bar', where `foo-pkg' is an existing package but `bar' isn't interned in -it. If the package cannot be found, NIL will be returned in its -place." +it. If the package cannot be found, its name as a string will be +returned in its place." (multiple-value-bind (symbol-name package-name) (parse-token string case) (let ((package (cond ((string= package-name "") +keyword-package+) - (package-name (find-package package-name)) + (package-name (or (find-package package-name) + package-name)) (t package)))) (multiple-value-bind (symbol status) - (when package + (when (packagep package) (find-symbol symbol-name package)) (if (or symbol status) (values symbol package status) @@ -2571,11 +2571,9 @@ (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))) - (end-mark (make-buffer-mark (buffer syntax) (end-offset form)))) + (let* ((start-mark (make-buffer-mark (buffer syntax) (start-offset form)))) (let* ((stream (make-buffer-stream :buffer (buffer syntax) - :start-mark start-mark - :end-mark end-mark)) + :start-mark start-mark)) (object (read-preserving-whitespace stream))) (signal 'reader-invoked :end-mark (point stream) :object object)))) @@ -2892,7 +2890,7 @@ (multiple-value-bind (symbol package status) (parse-symbol (form-string syntax form) :package *package* :case case) - (values (cond ((and read (null status)) + (values (cond ((and read (null status) (packagep package)) (intern (symbol-name symbol) package)) (t symbol))))) @@ -2922,10 +2920,7 @@ (defmethod form-to-object ((syntax lisp-syntax) (form complete-string-form) &key &allow-other-keys) - (if (notany #'literal-object-p (children form)) - (invoke-reader syntax form) - (form-conversion-error - syntax form "String form contains non-character element"))) + (invoke-reader syntax form)) (defmethod form-to-object ((syntax lisp-syntax) (form function-form) &rest args) (list 'cl:function (apply #'form-to-object syntax (second (children form)) args))) @@ -3027,6 +3022,51 @@ (make-array (dimensions rank array-contents) :initial-contents array-contents)))) +(defgeneric form-equal (syntax form1 form2) + (:documentation "Compare the objects that `form1' and `form2' +represent, which must be forms of `syntax', for equality under +the same rules as `equal'. This function does not have +side-effects. The semantics of this function are thus equivalent +to a side-effect-less version of (equal (form-to-object syntax +form1 :read t) (form-to-object syntax form2 :read t)). `Form1' +and `form2' may also be strings, in which case they are taken to +be a readable representation of some object.") + (:method ((syntax lisp-syntax) (form1 string) (form2 string)) + ;; Not strictly correct, but good enough for now. + (string= form1 form2)) + (:method ((syntax lisp-syntax) (form1 string) (form2 form)) + (form-equal syntax form2 form1)) + (:method ((syntax lisp-syntax) (form1 form) (form2 form)) + nil) + (:method ((syntax lisp-syntax) (form1 form) (form2 string)) + nil)) + +(defmethod form-equal ((syntax lisp-syntax) + (form1 complete-token-form) (form2 complete-token-form)) + (multiple-value-bind (symbol1 package1 status1) + (parse-symbol (form-string syntax form1) + :package (package-at-mark syntax (start-offset form1))) + (declare (ignore status1)) + (multiple-value-bind (symbol2 package2 status2) + (parse-symbol (form-string syntax form2) + :package (package-at-mark syntax (start-offset form2))) + (declare (ignore status2)) + (and (string= symbol1 symbol2) + (equal package1 package2))))) + +(defmethod form-equal ((syntax lisp-syntax) + (form1 complete-token-form) (form2 string)) + (multiple-value-bind (symbol1 package1 status1) + (parse-symbol (form-string syntax form1) + :package (package-at-mark syntax (start-offset form1))) + (declare (ignore status1)) + (multiple-value-bind (symbol2 package2 status2) + (parse-symbol form2 + :package (package-at-mark syntax (start-offset form1))) + (declare (ignore status2)) + (and (string= symbol1 symbol2) + (equal package1 package2))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Lambda-list handling. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/09 11:14:08 1.38 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/01/10 11:17:00 1.39 @@ -515,7 +515,7 @@ #:parser-symbol #:parent #:children #:start-offset #:end-offset #:parser-state #:preceding-parse-tree - #:literal-object-mixin #:literal-object-p + #:literal-object-mixin #:define-parser-state #:lexeme #:nonterminal #:action #:new-state #:done @@ -534,7 +534,7 @@ #:lisp-string #:edit-definition #:form - #:form-to-object + #:form-to-object #:form-equal ;; Selecting forms based on mark #:form-around #:form-before #:form-after

1 0

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

10 Jan '08

Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv14058/Drei/Tests Modified Files: lisp-syntax-tests.lisp Log Message: Made the Lisp syntax test suite explicitly call update-parse before munging around in internal data. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/05 21:07:16 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2008/01/10 11:03:39 1.12 @@ -53,6 +53,7 @@ (get-object (&rest args) (apply #'form-to-object (current-syntax) (get-form) args))) + (update-parse (current-syntax)) ,@body))))))) (defmacro swine-test (name &body body)

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