From thenriksen at common-lisp.net Mon Aug 6 13:19:04 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 6 Aug 2007 09:19:04 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070806131904.088D4111D1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13603/Drei Modified Files: drei-redisplay.lisp drei-clim.lisp Log Message: Fixed the "wandering Drei" input-editor redisplay bug by enforcing the original coordinates of the Drei instance. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/01/24 10:57:24 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/08/06 13:19:03 1.7 @@ -79,7 +79,7 @@ ;; very beginning of the output. (defmethod display-drei-contents :before ((stream extended-output-stream) (drei drei-area) syntax) (with-new-output-record (stream 'standard-sequence-output-record record) - (setf (output-record-position record) (stream-cursor-position stream)))) + (setf (output-record-position record) (values-list (input-editor-position drei))))) (defgeneric display-drei-cursor (stream drei cursor syntax) (:documentation "The purpose of this function is to display a @@ -289,7 +289,7 @@ (cursors drei)) (with-output-recording-options (stream :record t :draw nil) (letf (((stream-current-output-record stream) drei) - ((stream-cursor-position stream) (output-record-position drei))) + ((stream-cursor-position stream) (values-list (input-editor-position drei)))) (display-drei-contents stream drei (syntax (buffer drei))))))) (defmethod replay-output-record :after ((drei drei-area) (stream extended-output-stream) &optional @@ -315,9 +315,7 @@ "Adjust the returned offset with the position of the Drei area on display." (multiple-value-bind (x y height style-width) (call-next-method) - (multiple-value-bind (drei-x drei-y) (output-record-position drei) - (declare (ignore drei-y)) - (values (+ x drei-x) y height style-width)))) + (values (+ x (first (input-editor-position drei))) y height style-width))) (defun display-drei-area (drei) (with-accessors ((stream editor-pane)) drei --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/02/07 12:44:20 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/08/06 13:19:03 1.18 @@ -341,13 +341,21 @@ :documentation "The minimum width of the Drei editable area. Should be an integer >= 0 or T, meaning that it will extend to the end of the viewport, if the Drei area is in a -scrolling arrangement.")) +scrolling arrangement.") + (%drei-position :accessor input-editor-position + :initarg :input-editor-position + :documentation "The position of the Drei +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.")) (:default-initargs :command-executor 'execute-drei-command) (:documentation "A Drei editable area implemented as an output record.")) (defmethod initialize-instance :after ((area drei-area) &key) + (setf (input-editor-position area) + (multiple-value-list (stream-cursor-position (editor-pane area)))) (tree-recompute-extent area)) (defmethod display-drei ((drei drei-area)) From thenriksen at common-lisp.net Mon Aug 6 13:23:13 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 6 Aug 2007 09:23:13 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070806132313.6557013084@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv16214/Drei Modified Files: drei-clim.lisp Log Message: (Hopefully) restore the functionality of :x-position and :y-position initargs to Drei input-editor-streams. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/08/06 13:19:03 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/08/06 13:23:13 1.19 @@ -355,7 +355,7 @@ (defmethod initialize-instance :after ((area drei-area) &key) (setf (input-editor-position area) - (multiple-value-list (stream-cursor-position (editor-pane area)))) + (multiple-value-list (output-record-position (editor-pane area)))) (tree-recompute-extent area)) (defmethod display-drei ((drei drei-area)) From thenriksen at common-lisp.net Mon Aug 6 15:27:27 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 6 Aug 2007 11:27:27 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070806152727.940C356295@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv14105 Modified Files: drei-clim.lisp Log Message: Use the output record, not the pane, for finding the position of the output record... --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/08/06 13:23:13 1.19 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/08/06 15:27:27 1.20 @@ -355,7 +355,7 @@ (defmethod initialize-instance :after ((area drei-area) &key) (setf (input-editor-position area) - (multiple-value-list (output-record-position (editor-pane area)))) + (multiple-value-list (output-record-position area))) (tree-recompute-extent area)) (defmethod display-drei ((drei drei-area)) From thenriksen at common-lisp.net Mon Aug 13 21:56:04 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 13 Aug 2007 17:56:04 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20070813215604.84114431B7@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv19125/ESA Modified Files: utils.lisp packages.lisp Log Message: Add SUBTYPE-COMPATIBLE-P function to ESA. --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2006/12/09 21:28:05 1.2 +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2007/08/13 21:56:04 1.3 @@ -205,3 +205,10 @@ (if (and (eql a (car x)) (eql d (cdr x))) x (cons a d))))) + +(defun subtype-compatible-p (types) + "Return true if an element of `types' is a subtype of every +other type specifier in `types'. `Types' must be a list of type +specifiers." + (some (lambda (x) + (subtypep x `(and , at types))) types)) --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2006/12/09 21:28:05 1.2 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/08/13 21:56:04 1.3 @@ -40,7 +40,8 @@ #:with-keywords-removed #:invoke-with-dynamic-bindings-1 #:invoke-with-dynamic-bindings - #:maptree)) + #:maptree + #:subtype-compatible-p)) (defpackage :esa (:use :clim-lisp :clim :esa-utils) From thenriksen at common-lisp.net Mon Aug 13 21:58:44 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 13 Aug 2007 17:58:44 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20070813215844.0715849050@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv19592/Drei/Tests Modified Files: lisp-syntax-tests.lisp Added Files: lisp-syntax-swine-tests.lisp Log Message: Revised Lisp syntax module, making a bunch of improvements and added handling of even the craziest lambda lists. Now conses more! --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/02/17 17:54:06 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/08/13 21:58:43 1.5 @@ -53,6 +53,15 @@ (get-form) args))) , at body)))))) +(defmacro swine-test (name &body body) + `(test ,name + ,(when (stringp (first body)) + (first body)) + (if (eq (drei-lisp-syntax::default-image) t) + (skip "No useful image link found") + (progn + , at body)))) + (defmacro testing-symbol ((sym-sym &rest args) &body body) `(let ((,sym-sym (get-object , at args))) , at body @@ -60,7 +69,9 @@ (eq (symbol-package sym) (find-package :clim)) (eq (symbol-package sym) - (find-package :common-lisp))) + (find-package :common-lisp)) + (eq (symbol-package sym) + (find-package :keyword))) (unintern ,sym-sym (symbol-package sym))))) (defmacro testing-lisp-syntax-symbol ((buffer-contents sym-sym &rest args) @@ -582,7 +593,37 @@ ) ") (test-selector-null drei-lisp-syntax::form-before 0) (test-selector-null drei-lisp-syntax::form-before 4) - (test-selector drei-lisp-syntax::form-before 5 'list))) + (test-selector drei-lisp-syntax::form-before 5 'list)) + (testing-form-selectors ("'(list #|foo|# foo #|bar|# bar + baz ; baz indeed +) ") + (test-selector-null drei-lisp-syntax::form-before 0) + (test-selector-null drei-lisp-syntax::form-before 5) + (test-selector drei-lisp-syntax::form-before 6 'list)) + (testing-form-selectors ("#(list #|foo|# foo #|bar|# bar + baz ; baz indeed +) ") + (test-selector-null drei-lisp-syntax::form-before 0) + (test-selector-null drei-lisp-syntax::form-before 5) + (test-selector drei-lisp-syntax::form-before 6 'list)) + (testing-form-selectors ("(list #|foo|# list #|bar|# find + list ; baz indeed + ") + (test-selector drei-lisp-syntax::form-before 53 'list) + (test-selector drei-lisp-syntax::form-before 43 'list) + (test-selector drei-lisp-syntax::form-before 33 'find)) + (testing-form-selectors ("'(list #|foo|# list #|bar|# find + list ; baz indeed + ") + (test-selector drei-lisp-syntax::form-before 54 'list) + (test-selector drei-lisp-syntax::form-before 44 'list) + (test-selector drei-lisp-syntax::form-before 34 'find)) + (testing-form-selectors ("#(list #|foo|# list #|bar|# find + list ; baz indeed + ") + (test-selector drei-lisp-syntax::form-before 54 'list) + (test-selector drei-lisp-syntax::form-before 44 'list) + (test-selector drei-lisp-syntax::form-before 34 'find))) (test form-after "Test the `form-after' form selector of Lisp syntax." @@ -830,9 +871,9 @@ (is-true (drei-lisp-syntax::in-comment-p 60 *current-syntax*)) (is-false (drei-lisp-syntax::in-comment-p 69 *current-syntax*)))) -;; For the arglist fetching tests, we need some dummy functions and -;; macros whose arglists we can be sure of. We define those here. We -;; also hope we don't clobber anything important. +;; For some tests, we need various functions, classes and +;; macros. Define them here and pray we don't clobber anything +;; important. (defun lisp-syntax-f1 ()) (defun lisp-syntax-f2 (l) (declare (ignore l))) @@ -842,18 +883,519 @@ &body forms-decls) ; with-output-to-string (declare (ignore var string element-type forms-decls))) -(defmacro swine-test (name &body body) - `(test ,name - (if (eq (drei-lisp-syntax::default-image) t) - (skip "No useful image link found") - (progn - , at body)))) +(defmacro lisp-syntax-m2 (&key ((:a (a b c &key d)))) + (declare (ignore a b c d))) + +(defclass lisp-syntax-c1 () + ((foo :initarg :foo) + (bar :initarg bar))) + +(defclass lisp-syntax-c2 (lisp-syntax-c1) + ((baz :initarg :foo))) + +(test parse-lambda-list-1 + "Test that `parse-lambda-list' can correctly parse ordinary and +macro lambda lists with no parameters." + (let ((oll (parse-lambda-list '())) + (mll (parse-lambda-list '() 'macro-lambda-list))) + (is-true (typep oll 'ordinary-lambda-list)) + (is-true (null (required-parameters oll))) + (is-true (null (optional-parameters oll))) + (is-true (null (keyword-parameters oll))) + (is-true (null (rest-parameter oll))) + + (is-true (typep mll 'macro-lambda-list)) + (is-true (null (required-parameters mll))) + (is-true (null (optional-parameters mll))) + (is-true (null (keyword-parameters mll))) + (is-true (null (rest-parameter mll))) + (is-true (null (body-parameter mll))))) + +(test parse-lambda-list-2 + "Test that `parse-lambda-list' can correctly parse ordinary and +macro lambda lists with only required parameters." + (let ((oll1 (parse-lambda-list '(list))) + (oll2 (parse-lambda-list '(list find))) + (mll1 (parse-lambda-list '(list) 'macro-lambda-list)) + (mll2 (parse-lambda-list '(list find) 'macro-lambda-list))) + (is-true (typep oll1 'ordinary-lambda-list)) + (is (= 1 (length (required-parameters oll1)))) + (is (string= 'list (name (first (required-parameters oll1))))) + (is (= 0 (min-arg-index (first (required-parameters oll1))))) + (is-true (null (optional-parameters oll1))) + (is-true (null (keyword-parameters oll1))) + (is-true (null (rest-parameter oll1))) + + (is-true (typep oll2 'ordinary-lambda-list)) + (is (= 2 (length (required-parameters oll2)))) + (is (string= 'list (name (first (required-parameters oll2))))) + (is (= 0 (min-arg-index (first (required-parameters oll2))))) + (is (string= 'find (name (second (required-parameters oll2))))) + (is (= 1 (min-arg-index (second (required-parameters oll2))))) + (is-true (null (optional-parameters oll2))) + (is-true (null (keyword-parameters oll2))) + (is-true (null (rest-parameter oll2))) + + (is-true (typep mll1 'macro-lambda-list)) + (is (= 1 (length (required-parameters mll1)))) + (is (string= (name (first (required-parameters mll1))) 'list)) + (is (= 0 (min-arg-index (first (required-parameters mll1))))) + (is-true (null (optional-parameters mll1))) + (is-true (null (keyword-parameters mll1))) + (is-true (null (rest-parameter mll1))) + (is-true (null (body-parameter mll1))) + + (is-true (typep mll2 'macro-lambda-list)) + (is (= 2 (length (required-parameters mll2)))) + (is (string= (name (first (required-parameters mll2))) 'list)) + (is (= 0 (min-arg-index (first (required-parameters mll2))))) + (is (string= (name (second (required-parameters mll2))) 'find)) + (is (= 1 (min-arg-index (second (required-parameters mll2))))) + (is-true (null (optional-parameters mll2))) + (is-true (null (keyword-parameters mll2))) + (is-true (null (rest-parameter mll2))) + (is-true (null (body-parameter mll2))))) + +(test parse-lambda-list-2a + "Test that `parse-lambda-list' can correctly parse various +destructuring required parameters for macro lambda lists." + (let ((mll1 (parse-lambda-list '((list)))) + (mll2 (parse-lambda-list '((list find))))) + (is-true (typep mll1 'macro-lambda-list)) + (is (= (min-arg-index (first (required-parameters mll1))))) + (is (= 1 (length (required-parameters (inner-lambda-list (first (required-parameters mll1))))))) + (is (string= 'list (name (first (required-parameters (inner-lambda-list (first (required-parameters mll1)))))))) + + (let ((mll2-parameter (first (required-parameters mll2)))) + (is-true (typep (inner-lambda-list mll2-parameter) 'destructuring-lambda-list)) + (is (= 2 (length (required-parameters (inner-lambda-list mll2-parameter))))) + (is (string= 'list (name (first (required-parameters (inner-lambda-list mll2-parameter)))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list mll2-parameter)))))) + (is (string= 'find (name (second (required-parameters (inner-lambda-list mll2-parameter)))))) + (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list mll2-parameter)))))) + (is-true (null (optional-parameters (inner-lambda-list mll2-parameter)))) + (is-true (null (keyword-parameters (inner-lambda-list mll2-parameter)))) + (is-true (null (rest-parameter (inner-lambda-list mll2-parameter))))))) + +(test parse-lambda-list-3 + "Test that `parse-lambda-list' can correctly parse optional +parameters in ordinary and macro lambda lists." + (let ((oll1 (parse-lambda-list '(&optional (list 2)))) + (oll2 (parse-lambda-list '(&optional (list nil) find))) + (oll3 (parse-lambda-list '(reduce &optional list (find 2)))) + (mll1 (parse-lambda-list '(&optional (list 2)) 'macro-lambda-list)) + (mll2 (parse-lambda-list '(&optional (list nil) find) 'macro-lambda-list)) + (mll3 (parse-lambda-list '(reduce &optional list (find 2)) 'macro-lambda-list))) + (is-true (typep oll1 'ordinary-lambda-list)) + (is (= 0 (length (required-parameters oll1)))) + (is (= 1 (length (optional-parameters oll1)))) + (is (= 0 (length (keyword-parameters oll1)))) + (is-true (null (rest-parameter oll1))) + (is (= 0 (min-arg-index (first (optional-parameters oll1))))) + (is (string= 'list (name (first (optional-parameters oll1))))) + (is (= 2 (init-form (first (optional-parameters oll1))))) + + (is-true (typep oll2 'ordinary-lambda-list)) + (is (= 0 (length (required-parameters oll2)))) + (is (= 2 (length (optional-parameters oll2)))) + (is (= 0 (length (keyword-parameters oll2)))) + (is-true (null (rest-parameter oll2))) + (is (= 0 (min-arg-index (first (optional-parameters oll2))))) + (is (string= 'list (name (first (optional-parameters oll2))))) + (is-true (null (init-form (first (optional-parameters oll2))))) + (is (= 1 (min-arg-index (second (optional-parameters oll2))))) + (is (string= 'find (name (second (optional-parameters oll2))))) + (is-true (null (init-form (second (optional-parameters oll2))))) + + (is-true (typep oll3 'ordinary-lambda-list)) + (is (= 1 (length (required-parameters oll3)))) + (is (= 2 (length (optional-parameters oll3)))) + (is (= 0 (length (keyword-parameters oll3)))) + (is-true (null (rest-parameter oll3))) + (is (= 1 (min-arg-index (first (optional-parameters oll3))))) + (is (string= 'list (name (first (optional-parameters oll3))))) + (is-true (null (init-form (first (optional-parameters oll3))))) + (is (= 2 (min-arg-index (second (optional-parameters oll3))))) + (is (string= 'find (name (second (optional-parameters oll3))))) + (is (= 2 (init-form (second (optional-parameters oll3))))) + + (is-true (typep mll1 'macro-lambda-list)) + (is (= 0 (length (required-parameters mll1)))) + (is (= 1 (length (optional-parameters mll1)))) + (is (= 0 (length (keyword-parameters mll1)))) + (is-true (null (rest-parameter mll1))) + (is (= 0 (min-arg-index (first (optional-parameters mll1))))) + (is (string= 'list (name (first (optional-parameters mll1))))) + (is (= 2 (init-form (first (optional-parameters mll1))))) + + (is-true (typep mll2 'macro-lambda-list)) + (is (= 0 (length (required-parameters mll2)))) + (is (= 2 (length (optional-parameters mll2)))) + (is (= 0 (length (keyword-parameters mll2)))) + (is-true (null (rest-parameter mll2))) + (is (= 0 (min-arg-index (first (optional-parameters mll2))))) + (is (string= 'list (name (first (optional-parameters mll2))))) + (is-true (null (init-form (first (optional-parameters mll2))))) + (is (= 1 (min-arg-index (second (optional-parameters mll2))))) + (is (string= 'find (name (second (optional-parameters mll2))))) + (is-true (null (init-form (second (optional-parameters mll2))))) + + (is-true (typep mll3 'macro-lambda-list)) + (is (= 1 (length (required-parameters mll3)))) + (is (= 2 (length (optional-parameters mll3)))) + (is (= 0 (length (keyword-parameters mll3)))) + (is-true (null (rest-parameter mll3))) + (is (= 1 (min-arg-index (first (optional-parameters mll3))))) + (is (string= 'list (name (first (optional-parameters mll3))))) + (is-true (null (init-form (first (optional-parameters mll3))))) + (is (= 2 (min-arg-index (second (optional-parameters mll3))))) + (is (string= 'find (name (second (optional-parameters mll3))))) + (is (= 2 (init-form (second (optional-parameters mll3))))))) + +(test parse-lambda-list-3a + "Test that `parse-lambda-list' can correctly parse +destructuring optional parameters in macro lambda lists." + (let ((mll1 (parse-lambda-list '(&optional ((list))))) + (mll2 (parse-lambda-list '(&optional ((list) '(2))))) + (mll3 (parse-lambda-list '(&optional ((list find))))) + (mll4 (parse-lambda-list '(&optional ((list find) '(2 3)))))) + (is-true (typep mll1 'macro-lambda-list)) + (is-true (typep (first (optional-parameters mll1)) 'destructuring-optional-parameter)) + (is (= 0 (min-arg-index (first (optional-parameters mll1))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll1)))))))) + + (is-true (typep mll2 'macro-lambda-list)) + (is-true (typep (first (optional-parameters mll2)) 'destructuring-optional-parameter)) + (is (= 0 (min-arg-index (first (optional-parameters mll2))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll2)))))))) + (is (equal ''(2) (init-form (first (optional-parameters mll2))))) + + (is-true (typep mll3 'macro-lambda-list)) + (is-true (typep (first (optional-parameters mll3)) 'destructuring-optional-parameter)) + (is (= 0 (min-arg-index (first (optional-parameters mll3))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll3)))))))) + (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list (first (optional-parameters mll3)))))))) + + (is-true (typep mll4 'macro-lambda-list)) + (is-true (typep (first (optional-parameters mll4)) 'destructuring-optional-parameter)) + (is (= 0 (min-arg-index (first (optional-parameters mll4))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (optional-parameters mll4)))))))) + (is (= 1 (min-arg-index (second (required-parameters (inner-lambda-list (first (optional-parameters mll4)))))))) + (is (equal ''(2 3) (init-form (first (optional-parameters mll4))))))) + +(test parse-lambda-list-4 + "Test that `parse-lambda-list' can correctly parse keyword +parameters in ordinary and macro lambda lists." + (let ((oll1 (parse-lambda-list '(&key (list 2)))) + (oll2 (parse-lambda-list '(&key (list nil) find))) + (oll3 (parse-lambda-list '(reduce &key list (find 2)))) + (oll4 (parse-lambda-list '(&key ((:fooarg list) 2)))) + (mll1 (parse-lambda-list '(&key (list 2)) 'macro-lambda-list)) + (mll2 (parse-lambda-list '(&key (list nil) find) 'macro-lambda-list)) + (mll3 (parse-lambda-list '(reduce &key list (find 2)) 'macro-lambda-list)) + (mll4 (parse-lambda-list '(&key ((:fooarg list) 2)) 'macro-lambda-list))) + (is-true (typep oll1 'ordinary-lambda-list)) + (is (= 0 (length (required-parameters oll1)))) + (is (= 0 (length (optional-parameters oll1)))) + (is (= 1 (length (keyword-parameters oll1)))) + (is-true (null (rest-parameter oll1))) + (is (= 0 (min-arg-index (first (keyword-parameters oll1))))) + (is (string= :list (keyword-name (first (keyword-parameters oll1))))) + (is (= 2 (init-form (first (keyword-parameters oll1))))) + + (is-true (typep oll2 'ordinary-lambda-list)) + (is (= 0 (length (required-parameters oll2)))) + (is (= 0 (length (optional-parameters oll2)))) + (is (= 2 (length (keyword-parameters oll2)))) + (is-true (null (rest-parameter oll2))) + (is (= 0 (min-arg-index (first (keyword-parameters oll2))))) + (is (string= :list (keyword-name (first (keyword-parameters oll2))))) + (is-true (null (init-form (first (keyword-parameters oll2))))) + (is (= 0 (min-arg-index (second (keyword-parameters oll2))))) + (is (string= :find (keyword-name (second (keyword-parameters oll2))))) + (is-true (null (init-form (second (keyword-parameters oll2))))) + + (is-true (typep oll3 'ordinary-lambda-list)) + (is (= 1 (length (required-parameters oll3)))) + (is (= 0 (length (optional-parameters oll3)))) + (is (= 2 (length (keyword-parameters oll3)))) + (is-true (null (rest-parameter oll3))) + (is (= 1 (min-arg-index (first (keyword-parameters oll3))))) + (is (string= :list (keyword-name (first (keyword-parameters oll3))))) + (is-true (null (init-form (first (keyword-parameters oll3))))) + (is (= 1 (min-arg-index (second (keyword-parameters oll3))))) + (is (string= :find (keyword-name (second (keyword-parameters oll3))))) + (is (= 2 (init-form (second (keyword-parameters oll3))))) + + (is-true (typep oll4 'ordinary-lambda-list)) + (is (= 0 (length (required-parameters oll4)))) + (is (= 0 (length (optional-parameters oll4)))) + (is (= 1 (length (keyword-parameters oll4)))) + (is-true (null (rest-parameter oll4))) + (is (= 0 (min-arg-index (first (keyword-parameters oll4))))) + (is (string= :fooarg (keyword-name (first (keyword-parameters oll4))))) + (is (= 2 (init-form (first (keyword-parameters oll4))))) + + (is-true (typep mll1 'macro-lambda-list)) + (is (= 0 (length (required-parameters mll1)))) + (is (= 0 (length (optional-parameters mll1)))) + (is (= 1 (length (keyword-parameters mll1)))) + (is-true (null (rest-parameter mll1))) + (is (= 0 (min-arg-index (first (keyword-parameters mll1))))) + (is (string= :list (keyword-name (first (keyword-parameters mll1))))) + (is (= 2 (init-form (first (keyword-parameters mll1))))) + + (is-true (typep mll2 'macro-lambda-list)) + (is (= 0 (length (required-parameters mll2)))) + (is (= 0 (length (optional-parameters mll2)))) + (is (= 2 (length (keyword-parameters mll2)))) + (is-true (null (rest-parameter mll2))) + (is (= 0 (min-arg-index (first (keyword-parameters mll2))))) + (is (string= :list (keyword-name (first (keyword-parameters mll2))))) + (is-true (null (init-form (first (keyword-parameters mll2))))) + (is (= 0 (min-arg-index (second (keyword-parameters mll2))))) + (is (string= :find (keyword-name (second (keyword-parameters mll2))))) + (is-true (null (init-form (second (keyword-parameters mll2))))) + + (is-true (typep mll3 'macro-lambda-list)) + (is (= 1 (length (required-parameters mll3)))) + (is (= 0 (length (optional-parameters mll3)))) + (is (= 2 (length (keyword-parameters mll3)))) + (is-true (null (rest-parameter mll3))) + (is (= 1 (min-arg-index (first (keyword-parameters mll3))))) + (is (string= :list (keyword-name (first (keyword-parameters mll3))))) + (is-true (null (init-form (first (keyword-parameters mll3))))) + (is (= 1 (min-arg-index (second (keyword-parameters mll3))))) + (is (string= :find (keyword-name (second (keyword-parameters mll3))))) + (is (= 2 (init-form (second (keyword-parameters mll3))))) + + (is-true (typep mll4 'macro-lambda-list)) + (is (= 0 (length (required-parameters mll4)))) + (is (= 0 (length (optional-parameters mll4)))) + (is (= 1 (length (keyword-parameters mll4)))) + (is-true (null (rest-parameter mll4))) + (is (= 0 (min-arg-index (first (keyword-parameters mll4))))) + (is (string= :fooarg (keyword-name (first (keyword-parameters mll4))))) + (is (= 2 (init-form (first (keyword-parameters mll4))))))) + +(test parse-lambda-list-4a + "Test that `parse-lambda-list' can correctly parse +destructuring keyword parameters in macro lambda lists." + (let ((mll1 (parse-lambda-list '(&key ((:list (list)))))) + (mll2 (parse-lambda-list '(&key ((:list (list)) '(2))))) + (mll3 (parse-lambda-list '(&key ((:list (list find)))))) + (mll4 (parse-lambda-list '(&key ((:list (list find)) '(2 3)))))) + (is-true (typep mll1 'macro-lambda-list)) + (is-true (typep (first (keyword-parameters mll1)) 'destructuring-keyword-parameter)) + (is (= 0 (min-arg-index (first (keyword-parameters mll1))))) + (is (= 0 (min-arg-index (first (required-parameters (inner-lambda-list (first (keyword-parameters mll1)))))))) + (is (equal :list (keyword-name (first (keyword-parameters mll1))))) + (is-true (null (init-form (first (keyword-parameters mll1))))) + [226 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-swine-tests.lisp 2007/08/13 21:58:44 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-swine-tests.lisp 2007/08/13 21:58:44 1.1 [579 lines skipped] From thenriksen at common-lisp.net Mon Aug 13 21:58:46 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 13 Aug 2007 17:58:46 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070813215846.CC0EB586C1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv19592 Modified Files: mcclim.asd Log Message: Revised Lisp syntax module, making a bunch of improvements and added handling of even the craziest lambda lists. Now conses more! --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/04/27 21:37:14 1.56 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/08/13 21:58:46 1.57 @@ -342,7 +342,8 @@ (:file "buffer-streams-tests" :depends-on ("testing")) (:file "rectangle-tests" :depends-on ("testing")) (:file "undo-tests" :depends-on ("testing")) - (:file "lisp-syntax-tests" :depends-on ("testing" "motion-tests")))))) + (:file "lisp-syntax-tests" :depends-on ("testing" "motion-tests")) + (:file "lisp-syntax-swine-tests" :depends-on ("lisp-syntax-tests")))))) (defsystem :clim :depends-on (:clim-core :goatee-core :clim-postscript :drei-mcclim) From thenriksen at common-lisp.net Wed Aug 15 10:03:32 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 15 Aug 2007 06:03:32 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests/cl-automaton Message-ID: <20070815100332.384E12E1CB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton In directory clnet:/tmp/cvs-serv25734/Drei/Tests/cl-automaton Modified Files: state-and-transition-tests.lisp regexp-tests.lisp eqv-hash-tests.lisp automaton-tests.lisp Log Message: Revamped the Drei test suite infrastructure slightly. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/state-and-transition-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/state-and-transition-tests.lisp 2007/08/15 10:03:31 1.2 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) (def-suite state-and-transition-tests :description "The test -suite for CL-AUTOMATON state-and-transition related tests.") +suite for CL-AUTOMATON state-and-transition related tests." :in automaton-tests) (in-suite state-and-transition-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/regexp-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/regexp-tests.lisp 2007/08/15 10:03:32 1.2 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) (def-suite regexp-tests :description "The test suite for -CL-AUTOMATON regexp related tests.") +CL-AUTOMATON regexp related tests." :in automaton-tests) (in-suite regexp-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/eqv-hash-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/eqv-hash-tests.lisp 2007/08/15 10:03:32 1.2 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) (def-suite eqv-hash-tests :description "The test suite for -CL-AUTOMATON eqv-hash related tests.") +CL-AUTOMATON eqv-hash related tests." :in automaton-tests) (in-suite eqv-hash-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/automaton-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/cl-automaton/automaton-tests.lisp 2007/08/15 10:03:32 1.2 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) (def-suite automaton-tests :description "The test suite for -CL-AUTOMATON related tests.") +CL-AUTOMATON related tests." :in drei-tests) (in-suite automaton-tests) From thenriksen at common-lisp.net Wed Aug 15 10:03:32 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 15 Aug 2007 06:03:32 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20070815100332.A850D2F00A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv25734/Drei/Tests Modified Files: undo-tests.lisp testing.lisp rectangle-tests.lisp motion-tests.lisp lisp-syntax-tests.lisp kill-ring-tests.lisp editing-tests.lisp core-tests.lisp buffer-tests.lisp buffer-streams-tests.lisp base-tests.lisp Log Message: Revamped the Drei test suite infrastructure slightly. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/undo-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/undo-tests.lisp 2007/08/15 10:03:32 1.2 @@ -21,7 +21,7 @@ (cl:in-package :drei-tests) (def-suite undo-tests :description "The test suite for tests -related to Drei's undo system.") +related to Drei's undo system." :in drei-tests) (in-suite undo-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/02/17 17:54:06 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/testing.lisp 2007/08/15 10:03:32 1.5 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) ;; Define some stuff to ease the pain of writing repetitive test -;; cases. Also provide test-running entry point. +;; cases. Also provide global test-suite and test-running entry point. (defclass delegating-standard-buffer (delegating-buffer) () (:default-initargs :implementation (make-instance 'standard-buffer))) @@ -93,34 +93,11 @@ (with-bound-drei-special-variables (,drei :minibuffer nil) , at body))))) +(def-suite drei-tests :description "The test suite for all Drei +test cases. Has nested test suites for the actual tests.") + (defun run-tests () - (format t "Testing buffer protocol implementation(s)~%") - (run! 'buffer-tests) - (format t "Testing basic functions~%") - (run! 'base-tests) - (format t "Testing the kill ring~%") - (run! 'kill-ring-tests) - (format t "Testing mark motion~%") - (run! 'motion-tests) - (format t "Testing text editing functions~%") - (run! 'editing-tests) - (format t "Testing miscellaneus editor functions~%") - (run! 'core-tests) - (format t "Testing buffer-based gray streams~%") - (run! 'buffer-streams-tests) - (format t "Testing rectangle editing~%") - (run! 'rectangle-tests) - (format t "Testing undo~%") - (run! 'undo-tests) - (format t "Testing the Lisp syntax module~%") - (run! 'lisp-syntax-tests) - - (format t "Running the CL-AUTOMATON tests~%") - (format t "Testing regular expressions~%") - (run! 'regexp-tests) - (format t "Testing eqv-hash~%") - (run! 'eqv-hash-tests) - (format t "Testing states and transitions~%") - (run! 'state-and-transition-tests) - (format t "Testing core automata functions~%") - (run! 'automaton-tests)) + "Run the Drei test suite. A dot will be printed for each passed +test, a \"f\" for each failed test, a \"X\" for each test that +causes an error, and an \"s\" for each skipped test." + (run! 'drei-tests)) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/rectangle-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/rectangle-tests.lisp 2007/08/15 10:03:32 1.2 @@ -21,7 +21,7 @@ (cl:in-package :drei-tests) (def-suite rectangle-tests :description "The test suite for -rectangle-editing related tests.") +rectangle-editing related tests." :in drei-tests) (in-suite rectangle-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/04/27 21:37:15 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/motion-tests.lisp 2007/08/15 10:03:32 1.4 @@ -22,7 +22,7 @@ (cl:in-package :drei-tests) (def-suite motion-tests :description "The test suite for -DREI-MOTION related tests.") +DREI-MOTION related tests." :in drei-tests) (in-suite motion-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/08/13 21:58:43 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/lisp-syntax-tests.lisp 2007/08/15 10:03:32 1.6 @@ -25,7 +25,7 @@ explicitly tested. Instead, it is hoped that any defects will be caught by other test cases, all of which depend on correct parsing. Also, redisplay is not tested, because no-one has any -idea how to do it.") +idea how to do it." :in drei-tests) (in-suite lisp-syntax-tests) @@ -1797,6 +1797,7 @@ ;; Also, as fun as infinite recursion would be... disable this ;; test before running the suite. (let ((*run-self-compilation-test* nil)) - (format t "Re-running Drei test suite with newly evaluated Drei definitions~%") - (run-tests))) + (format *test-dribble* "~%Re-running Drei test suite with newly evaluated Drei definitions~%") + (is-true (results-status (let ((fiveam:*test-dribble* (make-broadcast-stream))) + (fiveam:run 'drei-tests)))))) (skip "Sensibly skipping self-compilation test. Set DREI-TESTS:*RUN-SELF-COMPILATION-TEST* to true if you don't want to skip it"))) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/kill-ring-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/kill-ring-tests.lisp 2007/08/15 10:03:32 1.2 @@ -27,7 +27,7 @@ (in-package :drei-tests) (def-suite kill-ring-tests :description "The test suite for DREI-KILL-RING -related tests.") +related tests." :in drei-tests) (in-suite kill-ring-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2007/08/15 10:03:32 1.2 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) (def-suite editing-tests :description "The test suite for -DREI-EDITING related tests.") +DREI-EDITING related tests." :in drei-tests) (in-suite editing-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/02/13 12:14:11 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/core-tests.lisp 2007/08/15 10:03:32 1.4 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) (def-suite core-tests :description "The test suite for -DREI-CORE related tests.") +DREI-CORE related tests." :in drei-tests) (in-suite core-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-tests.lisp 2006/12/04 07:54:51 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-tests.lisp 2007/08/15 10:03:32 1.2 @@ -28,7 +28,7 @@ (cl:in-package :drei-tests) (def-suite buffer-tests :description "The test suite for -buffer-protocol related tests.") +buffer-protocol related tests." :in drei-tests) (in-suite buffer-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-streams-tests.lisp 2007/01/15 11:35:53 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/buffer-streams-tests.lisp 2007/08/15 10:03:32 1.2 @@ -23,7 +23,7 @@ (cl:in-package :drei-tests) (def-suite buffer-streams-tests :description "The test suite for -buffer-streams related tests.") +buffer-streams related tests." :in drei-tests) (in-suite buffer-streams-tests) --- /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2007/02/13 12:14:11 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/base-tests.lisp 2007/08/15 10:03:32 1.3 @@ -26,7 +26,7 @@ (cl:in-package :drei-tests) (def-suite base-tests :description "The test suite for DREI-BASE -related tests.") +related tests." :in drei-tests) (in-suite base-tests) From thenriksen at common-lisp.net Wed Aug 15 10:03:32 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 15 Aug 2007 06:03:32 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070815100332.ED9212F047@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25734 Modified Files: mcclim.asd Log Message: Revamped the Drei test suite infrastructure slightly. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/08/13 21:58:46 1.57 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/08/15 10:03:32 1.58 @@ -327,10 +327,10 @@ "cl-automaton" :depends-on ("testing") :components - ((:file "eqv-hash-tests") - (:file "state-and-transition-tests") - (:file "automaton-tests") - (:file "regexp-tests"))) + ((:file "automaton-tests") + (:file "state-and-transition-tests" :depends-on ("automaton-tests")) + (:file "eqv-hash-tests" :depends-on ("automaton-tests")) + (:file "regexp-tests" :depends-on ("automaton-tests")))) (:file "packages") (:file "testing" :depends-on ("packages")) (:file "buffer-tests" :depends-on ("testing")) From thenriksen at common-lisp.net Mon Aug 20 14:27:14 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Aug 2007 10:27:14 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070820142714.403614D051@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv30204/Drei Modified Files: input-editor.lisp Log Message: Fixed last known Drei input-editing-stream issue by implementing Goatee-style handling of :REPLACE keyword parameter to STREAM-REPLACE-INPUT (not mentioned in the spec). --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/02/19 00:12:22 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/08/20 14:27:13 1.18 @@ -165,8 +165,8 @@ (loop with buffer = (buffer (drei-instance stream)) until (>= (stream-scan-pointer stream) (size buffer)) - while (typep (buffer-object buffer (stream-scan-pointer stream)) - 'noise-string) + while (or (typep #1=(buffer-object buffer (stream-scan-pointer stream)) 'noise-string) + (delimiter-gesture-p #1#)) do (incf (stream-scan-pointer stream))) (setf (input-position stream) (stream-scan-pointer stream)))) @@ -310,7 +310,7 @@ (start 0) (end (length new-input)) (buffer-start (input-position stream)) - rescan) + (rescan nil rescan-supplied-p)) (check-type start integer) (check-type end integer) (check-type buffer-start integer) @@ -338,7 +338,11 @@ ;; Make the buffer reflect the changes in the array. (synchronize-input-buffer-array stream)) (display-drei drei) - (when (or rescan (not equal)) + ;; XXX: This behavior for the :rescan parameter is not mentioned + ;; explicitly in any CLIM guide, but McCLIM input-editing + ;; machinery relies on it. + (when (and (or rescan (not equal)) + (or rescan (not rescan-supplied-p))) (queue-rescan stream)) ;; We have to return "the position in the input buffer". We ;; return the insertion position. From thenriksen at common-lisp.net Mon Aug 20 14:27:14 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Aug 2007 10:27:14 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070820142714.95ABA4E00F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30204 Modified Files: input-editing.lisp decls.lisp Log Message: Fixed last known Drei input-editing-stream issue by implementing Goatee-style handling of :REPLACE keyword parameter to STREAM-REPLACE-INPUT (not mentioned in the spec). --- /project/mcclim/cvsroot/mcclim/input-editing.lisp 2006/12/12 22:36:32 1.55 +++ /project/mcclim/cvsroot/mcclim/input-editing.lisp 2007/08/20 14:27:14 1.56 @@ -382,6 +382,7 @@ (adjust-array so-far (length input) :fill-pointer (length input)) (replace so-far input) + ;; XXX: Relies on non-specified behavior of :rescan. (replace-input stream input :rescan nil))) (multiple-value-bind (object success input) (complete-input-rescan stream func partial-completers @@ -420,9 +421,8 @@ :n-columns 1) (declare (ignore event)) (if item - (progn - (setf (values input success object nmatches) - (values (car item) t menu-object 1))) + (setf (values input success object nmatches) + (values (car item) t menu-object 1)) (setf success nil nmatches 0)))) (unless (and (eq mode :complete) (not success)) --- /project/mcclim/cvsroot/mcclim/decls.lisp 2007/02/07 12:44:16 1.46 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2007/08/20 14:27:14 1.47 @@ -581,10 +581,42 @@ ;;; 24.4 Reading and Writing of Tokens (defgeneric replace-input - (stream new-input &key start end buffer-start rescan)) + (stream new-input &key start end buffer-start rescan) + ;; XXX: Nonstandard behavior for :rescan. + (:documentation "Replaces the part of the input editing stream +`stream's input buffer that extends from `buffer-start' to its +scan pointer with the string `new-input'. `buffer-start' defaults +to the current input position of stream, which is the position at +which the current accept \"session\" starts. `start' and `end' can be +supplied to specify a subsequence of `new-input'; start defaults to +0 and end defaults to the length of `new-input'. + +`replace-input' will queue a rescan by calling `queue-rescan' if +the new input does not match the old input, or `rescan' is +true. If `rescan' is explicitly provided as NIL, no rescan will +be queued in any case. + +The returned value is the position in the input buffer.")) + (defgeneric presentation-replace-input (stream object type view - &key buffer-start rescan query-identifier for-context-type)) + &key buffer-start rescan query-identifier for-context-type) + (:documentation "Like `replace-input', except that the new +input to insert into the input buffer is gotten by presenting +`object' with the presentation type `type' and view +`view'. `buffer-start' and `rescan' are as for `replace-input', +and `query-identifier' and `for-context-type' as as for +`present'. + +Typically, this function will be implemented by calling +`present-to-string' on `object', `type', `view', and +`for-context-type', and then calling `replace-input' on the +resulting string. + +If the object cannot be transformed into an acceptable textual +form, it may be inserted as a special \"accept result\" that is +considered a single gesture. These accept result objects have no +standardised form.")) ;;; 27.3 Command Menus From thenriksen at common-lisp.net Mon Aug 20 14:58:28 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Aug 2007 10:58:28 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070820145828.EBEC57208F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv5440/Drei Modified Files: basic-commands.lisp editing.lisp Log Message: Print a message and beep not only for unsuccessful motion but also for editing. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2007/01/17 12:02:04 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2007/08/20 14:58:28 1.6 @@ -33,6 +33,20 @@ (in-package :drei-commands) +(defmacro handling-motion-limit-errors ((unit-plural &key (beep t) + (display-message t)) + &body body) + "Evaluate body, if a `motion-limit-error' is signalled, beep if +`beep' is true (the default), and display a message stating that +there are no more `unit-plural's if `display-message' is +true (the default)." + `(handler-case (progn , at body) + (motion-limit-error () + ,(when beep + `(beep)) + ,(when display-message + `(display-message ,(concatenate 'string "No more " unit-plural)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Motion commands. @@ -75,12 +89,10 @@ ,(concat "Move point forward by one " noun ". With a numeric argument N, move point forward by N " plural ". With a negative argument -N, move point backward by N " plural ".") - (handler-case (,forward *current-point* - (SYNTAX *current-buffer*) - COUNT) - (motion-limit-error () - (beep) - (display-message ,(concat "No more " plural))))) + (handling-motion-limit-errors (,plural) + (,forward *current-point* + (SYNTAX *current-buffer*) + COUNT))) (DEFINE-COMMAND (,com-backward :NAME T :COMMAND-TABLE ,command-table) @@ -88,12 +100,10 @@ ,(concat "Move point backward by one " noun ". With a numeric argument N, move point backward by N " plural ". With a negative argument -N, move point forward by N " plural ".") - (handler-case (,backward *current-point* - (SYNTAX *current-buffer*) - COUNT) - (motion-limit-error () - (beep) - (display-message ,(concat "No more " plural))))))))) + (handling-motion-limit-errors (,plural) + (,backward *current-point* + (SYNTAX *current-buffer*) + COUNT))))))) ;;; Manually define some commands @@ -113,24 +123,18 @@ "Move point forward by one object. With a numeric argument N, move point forward by N objects. With a negative argument -N, move point backward by M objects." - (handler-case - (forward-object *current-point* - count) - (motion-limit-error nil - (beep) - (display-message "No more objects")))) + (handling-motion-limit-errors ("objects") + (forward-object *current-point* + count))) (define-command (com-backward-object :name t :command-table movement-table) ((count 'integer :prompt "number of objects")) "Move point backward by one object. With a numeric argument N, move point backward by N objects. With a negative argument -N, move point forward by N objects." - (handler-case - (backward-object *current-point* - count) - (motion-limit-error nil - (beep) - (display-message "No more objects")))) + (handling-motion-limit-errors ("objects") + (backward-object *current-point* + count))) ;;; Autogenerate commands (define-motion-commands word movement-table) @@ -280,13 +284,11 @@ that many " plural ". Successive kills append to the kill ring.") - (handler-case (,forward-kill *current-point* - (syntax *current-buffer*) - count - (eq (command-name *previous-command*) ',com-kill)) - (motion-limit-error () - (beep) - (display-message ,(concat "No more " plural " to kill"))))) + (handling-motion-limit-errors (,plural) + (,forward-kill *current-point* + (syntax *current-buffer*) + count + (eq (command-name *previous-command*) ',com-kill)))) ;; Backward Kill Unit (define-command (,com-backward-kill @@ -298,13 +300,11 @@ that many " plural ". Successive kills append to the kill ring.") - (handler-case (,backward-kill *current-point* - (syntax *current-buffer*) - count - (eq (command-name *previous-command*) ',com-backward-kill)) - (motion-limit-error () - (beep) - (display-message ,(concat "No more " plural "to kill"))))) + (handling-motion-limit-errors (,plural) + (,backward-kill *current-point* + (syntax *current-buffer*) + count + (eq (command-name *previous-command*) ',com-backward-kill)))) ;; Delete Unit (define-command (,com-delete :name t :command-table ,command-table) @@ -349,11 +349,9 @@ transpose that " noun " with the next one. With point before the first " noun " of the buffer, transpose the first two " plural " of the buffer.") - (handler-case (,transpose *current-point* - (syntax *current-buffer*)) - (motion-limit-error () - (beep) - (display-message ,(concat "No more " plural " to transpose"))))))))) + (handling-motion-limit-errors (,plural) + (,transpose *current-point* + (syntax *current-buffer*)))))))) ;;; Some manually defined commands @@ -371,9 +369,10 @@ "Delete the object after point. With a numeric argument, kill that many objects after (or before, if negative) point." - (if killp - (forward-kill-object *current-point* count) - (forward-delete-object *current-point* count))) + (handling-motion-limit-errors ("objects") + (if killp + (forward-kill-object *current-point* count) + (forward-delete-object *current-point* count)))) (define-command (com-backward-delete-object :name t :command-table deletion-table) ((count 'integer :prompt "Number of Objects") @@ -381,9 +380,10 @@ "Delete the object before point. With a numeric argument, kills that many objects before (or after, if negative) point." - (if killp - (backward-kill-object *current-point* count) - (backward-delete-object *current-point* count))) + (handling-motion-limit-errors ("objects") + (if killp + (backward-kill-object *current-point* count #'error-limit-action) + (backward-delete-object *current-point* count #'error-limit-action)))) ;; We require somewhat special behavior from Kill Line, so define a ;; new function and use that to implement the Kill Line command. --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2007/04/27 21:37:14 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2007/08/20 14:58:28 1.6 @@ -82,12 +82,14 @@ (:documentation ,(concat "Delete COUNT " plural " beginning from MARK."))) (defmethod ,forward-delete - (mark syntax &optional (count 1) limit-action) + (mark syntax &optional (count 1) + (limit-action #'error-limit-action)) (let ((mark2 (clone-mark mark))) (,forward mark2 syntax count limit-action) (delete-region mark mark2))) (defmethod ,forward-delete :around - (mark syntax &optional (count 1) limit-action) + (mark syntax &optional (count 1) + (limit-action #'error-limit-action)) (cond ((minusp count) (,backward-delete mark syntax (- count) limit-action)) ((plusp count) @@ -98,12 +100,14 @@ (:documentation ,(concat "Delete COUNT " plural " backwards beginning from MARK."))) (defmethod ,backward-delete - (mark syntax &optional (count 1) limit-action) + (mark syntax &optional (count 1) + (limit-action #'error-limit-action)) (let ((mark2 (clone-mark mark))) (,backward mark2 syntax count limit-action) (delete-region mark mark2))) (defmethod ,backward-delete :around - (mark syntax &optional (count 1) limit-action) + (mark syntax &optional (count 1) + (limit-action #'error-limit-action)) (cond ((minusp count) (,forward-delete mark syntax (- count) limit-action)) ((plusp count) @@ -114,7 +118,8 @@ (:documentation ,(concat "Kill COUNT " plural " beginning from MARK."))) (defmethod ,forward-kill - (mark syntax &optional (count 1) concatenate-p limit-action) + (mark syntax &optional (count 1) concatenate-p + (limit-action #'error-limit-action)) (let ((start (offset mark))) (,forward mark syntax count limit-action) (unless (mark= mark start) @@ -128,7 +133,8 @@ (region-to-sequence start mark))) (delete-region start mark)))) (defmethod ,forward-kill :around - (mark syntax &optional (count 1) concatenate-p limit-action) + (mark syntax &optional (count 1) concatenate-p + (limit-action #'error-limit-action)) (declare (ignore concatenate-p)) (cond ((minusp count) (,backward-kill mark syntax (- count) limit-action)) @@ -140,7 +146,8 @@ (:documentation ,(concat "Kill COUNT " plural " backwards beginning from MARK."))) (defmethod ,backward-kill - (mark syntax &optional (count 1) concatenate-p limit-action) + (mark syntax &optional (count 1) concatenate-p + (limit-action #'error-limit-action)) (let ((start (offset mark))) (,backward mark syntax count limit-action) (unless (mark= mark start) @@ -154,7 +161,8 @@ (region-to-sequence start mark))) (delete-region start mark)))) (defmethod ,backward-kill :around - (mark syntax &optional (count 1) concatenate-p limit-action) + (mark syntax &optional (count 1) concatenate-p + (limit-action #'error-limit-action)) (declare (ignore concatenate-p)) (cond ((minusp count) (,forward-kill mark syntax (- count) limit-action)) From thenriksen at common-lisp.net Mon Aug 20 17:52:44 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Aug 2007 13:52:44 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070820175244.C039B2E1D9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18549/Drei Modified Files: syntax.lisp Log Message: Finished documentation for syntax command tables. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/01/17 10:02:08 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2007/08/20 17:52:44 1.6 @@ -88,24 +88,29 @@ syntax to use standard editor commands, you should *not* inherit from `editor-table' - the command tables containing the editor commands will be added automatically, as long as this function -returns T.") +returns true. For most syntax command tables, you do not need to +define a method for this generic function, you really do want the +standard editor commands for all but the most esoteric +syntaxes.") (:method ((command-table standard-command-table)) t)) (defgeneric additional-command-tables (editor command-table) (:method-combination append) - (:documentation "Get a list of additional command tables that -should be checked for commands in addition to those + (:documentation "Return a list of additional command tables +that should be checked for commands in addition to those `command-table' inherits from. The idea is that methods are -specialised to `editor', and that those methods may call the -function again recursively with a new `editor' argument to -provide arbitrary granularity for command-table-selection. For -instance, some commands may be applicable in a situation where -the editor is a pane or gadget in its own right, but not when it -functions as an input-editor. In this case, a method could be -defined for `application-frame' as the `editor' argument, that -calls `additional-command-tables' again with whatever the -\"current\" editor instance is.") +specialised to `editor' (which is at first a Drei instance), and +that those methods may call the function again recursively with a +new `editor' argument to provide arbitrary granularity for +command-table-selection. For instance, some commands may be +applicable in a situation where the editor is a pane or gadget in +its own right, but not when it functions as an input-editor. In +this case, a method could be defined for `application-frame' as +the `editor' argument, that calls `additional-command-tables' +again with whatever the \"current\" editor instance is. The +default method on this generic function just returns the empty +list.") (:method append (editor command-table) '())) From thenriksen at common-lisp.net Mon Aug 20 17:52:45 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Aug 2007 13:52:45 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20070820175245.0E2D52F050@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv18549/Doc Modified Files: drei.texi docstrings.lisp Log Message: Finished documentation for syntax command tables. --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/01/22 11:37:12 1.7 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/08/20 17:52:44 1.8 @@ -1245,7 +1245,29 @@ In order to provide conditionally active command tables, Drei defines the @class{syntax-command-table} class. While this class is meant to facilitate the addition of commands to syntaxes when they are run in a -specific context (for example, a large editor application adding a Show -Macroexpansion command to Lisp syntax), their modus operandi is general -enough to be used for all conditional activity of command tables. +specific context (for example, a large editor application adding a + at command{Show Macroexpansion} command to Lisp syntax), their modus +operandi is general enough to be used for all conditional activity of +command tables. This is useful for making commands available that +could not be generally implemented for all Drei instances --- +returning to the @command{Show Macroexpansion} example, such a command +can only be implemented if there is a sufficiently large place to show +the expansion, and this might not be available for a generic Drei +input-editor instance, but could be provided by an application +designed for it. +Syntax command tables work by conditionally inheriting from other +command tables, so it is necessary to define one (or more) command +tables for the commands you wish to make conditionally available. + +When providing a @var{:command-table} argument to + at fmacro{define-syntax} that names a syntax command table, an instance +of the syntax command table will be used for the syntax. + + at include class-drei-syntax-syntax-command-table.texi + + at include fun-drei-syntax-use-editor-commands-p.texi + + at include fun-drei-syntax-additional-command-tables.texi + + at include macro-drei-syntax-define-syntax-command-table.texi --- /project/mcclim/cvsroot/mcclim/Doc/docstrings.lisp 2006/12/21 12:22:03 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/docstrings.lisp 2007/08/20 17:52:44 1.2 @@ -764,26 +764,37 @@ (format *texinfo-output* "@findex ~A~%" title))))) (defun texinfo-inferred-body (doc) - (when (member (get-kind doc) '(class structure condition)) - (let ((name (get-name doc))) - ;; class precedence list - (format *texinfo-output* "Class precedence list: @code{~(~{@w{~A}~^, ~}~)}~%~%" - (remove-if (lambda (class) (hide-superclass-p name class)) - (mapcar #'class-name (class-precedence-list (progn (finalize-inheritance (find-class name)) - (find-class name)))))) - ;; slots - (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot)) - (class-direct-slots (find-class name))))) - (when slots - (format *texinfo-output* "Slots:~%@itemize~%") - (dolist (slot slots) - (format *texinfo-output* "@item ~(@code{~A} ~ + (cond ((member (get-kind doc) '(class structure condition)) + (let ((name (get-name doc))) + ;; class precedence list + (format *texinfo-output* "Class precedence list: @code{~(~{@w{~A}~^, ~}~)}~%~%" + (remove-if (lambda (class) (hide-superclass-p name class)) + (mapcar #'class-name (class-precedence-list (progn (finalize-inheritance (find-class name)) + (find-class name)))))) + ;; slots + (let ((slots (remove-if (lambda (slot) (hide-slot-p name slot)) + (class-direct-slots (find-class name))))) + (when slots + (format *texinfo-output* "Slots:~%@itemize~%") + (dolist (slot slots) + (format *texinfo-output* "@item ~(@code{~A} ~ ~@[--- initargs: @code{~{@w{~S}~^, ~}}~]~)~%~%" - (slot-definition-name slot) - (slot-definition-initargs slot)) - ;; FIXME: Would be neater to handler as children - (write-texinfo-string (docstring slot t))) - (format *texinfo-output* "@end itemize~%~%")))))) + (slot-definition-name slot) + (slot-definition-initargs slot)) + ;; FIXME: Would be neater to handler as children + (write-texinfo-string (docstring slot t))) + (format *texinfo-output* "@end itemize~%~%"))))) + ((eq (get-kind doc) 'generic-function) + (let* ((method-combination + (sb-mop:generic-function-method-combination + (fdefinition (get-name doc)))) + (combination-name (sb-pcl::method-combination-type-name + method-combination)) + (options (sb-pcl::method-combination-options method-combination))) + (unless (eq combination-name 'standard) + (format *texinfo-output* + "Method combination: @code{~A} (~(~{@w{~A}~^, ~}~))~%~%" + combination-name options)))))) (defun texinfo-body (doc) (write-texinfo-string (get-string doc))) From thenriksen at common-lisp.net Mon Aug 20 18:32:26 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Aug 2007 14:32:26 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070820183226.7BF2472091@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv29471 Modified Files: NEWS Log Message: Added mention of the delimiter gesture support to NEWS. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/02/07 12:44:16 1.21 +++ /project/mcclim/cvsroot/mcclim/NEWS 2007/08/20 18:32:26 1.22 @@ -1,4 +1,5 @@ * Changes in mcclim-0.9.5 relative to 0.9.4: +** Drei now has better support for delimiter gestures. ** Installation: the systems clim-listener, scigraph, clim-examples, and clouseau can now be loaded without loading the system mcclim first. From thenriksen at common-lisp.net Mon Aug 20 18:43:06 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Aug 2007 14:43:06 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070820184306.24965111D1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv380/Drei Modified Files: lisp-syntax.lisp Log Message: Handle weirdly placed quote characters in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/08/13 21:58:44 1.29 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/08/20 18:43:06 1.30 @@ -1395,7 +1395,8 @@ "Return the bottom token object for `token', return `token' or the form that `token' quotes, peeling away all quote forms." (labels ((descend (form) - (cond ((form-quoted-p form) + (cond ((and (form-quoted-p form) + (rest (children form))) (descend (first-form (children form)))) (t form)))) (descend token))) From thenriksen at common-lisp.net Mon Aug 20 19:44:19 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Aug 2007 15:44:19 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei/Tests Message-ID: <20070820194419.8990D4D053@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Tests In directory clnet:/tmp/cvs-serv15234/Drei/Tests Modified Files: editing-tests.lisp Log Message: Changed Drei tests to give more sensible information on errors. --- /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2007/08/15 10:03:32 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/Tests/editing-tests.lisp 2007/08/20 19:44:19 1.3 @@ -39,13 +39,13 @@ (let ((mark (clone-mark (point buffer) mark-stickto))) (setf (offset mark) offset) (funcall action buffer mark) - (is (string= (buffer-contents buffer) - end-contents)) + (is (string= end-contents + (buffer-contents buffer))) ;; `kill-ring-end-contents' is a list of what should ;; be at the top of the kill ring now. Assert that ;; it is. (handler-case (mapcar #'(lambda (killed-string expected) - (is (string= killed-string expected))) + (is (string= expected killed-string))) (loop repeat (length kill-ring-end-contents) collecting (coerce (kill-ring-yank kill-ring nil) 'string) do (rotate-yank-position kill-ring 1)) From thenriksen at common-lisp.net Mon Aug 20 19:44:44 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Aug 2007 15:44:44 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070820194444.252B04D0E3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15306/Drei Modified Files: motion.lisp Log Message: Now considering the beginning of a buffer a page delimiter. --- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2007/04/27 21:37:14 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2007/08/20 19:44:44 1.5 @@ -372,7 +372,7 @@ (progn (forward-object mark (length (page-delimiter syntax))) t) (progn (beginning-of-buffer mark) - nil)))) + t)))) (define-motion-fns page) From thenriksen at common-lisp.net Mon Aug 20 20:07:45 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Aug 2007 16:07:45 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070820200745.80E60100A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv20491/Drei Modified Files: input-editor.lisp Log Message: Fixed the nemesis for my earlier Drei hubris. Never declare the last bug fixed. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/08/20 14:27:13 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2007/08/20 20:07:45 1.19 @@ -341,9 +341,11 @@ ;; XXX: This behavior for the :rescan parameter is not mentioned ;; explicitly in any CLIM guide, but McCLIM input-editing ;; machinery relies on it. - (when (and (or rescan (not equal)) - (or rescan (not rescan-supplied-p))) - (queue-rescan stream)) + (if (and (or rescan (not equal)) + (not (and (null rescan) rescan-supplied-p))) + (queue-rescan stream) + (incf (stream-scan-pointer stream) (- (length new-contents) + (length old-contents)))) ;; We have to return "the position in the input buffer". We ;; return the insertion position. buffer-start))) From thenriksen at common-lisp.net Tue Aug 21 21:45:50 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 21 Aug 2007 17:45:50 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070821214550.159B05F058@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22905 Modified Files: panes.lisp Log Message: Attempt at making layout panes (scrollers in particular) less likely to eat space requirements. Issues may still crop up, I do not vouch for its correctness, but the old way was certainly just wrong. Please test. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2007/07/21 13:18:59 1.183 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2007/08/21 21:45:49 1.184 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.183 2007/07/21 13:18:59 rstrandh Exp $ +;;; $Id: panes.lisp,v 1.184 2007/08/21 21:45:49 thenriksen Exp $ (in-package :clim-internals) @@ -1171,7 +1171,7 @@ sum (space-requirement-max-major sr) into max-major maximize (space-requirement-minor sr) into minor maximize (space-requirement-min-minor sr) into min-minor - maximize (space-requirement-max-minor sr) into max-minor + minimize (space-requirement-max-minor sr) into max-minor finally (return (space-requirement+* @@ -1830,8 +1830,15 @@ (defmethod compose-space ((pane viewport-pane) &key width height) (declare (ignorable width height)) - ; I _think_ this is right, it certainly shouldn't be the requirements of the child. - (make-space-requirement)) + ;; I _think_ this is right, it certainly shouldn't be the + ;; requirements of the child, apart from the max sizes. If the child + ;; does not want to go bigger than a specific size, we should not + ;; force it to do so. + (let ((child-sr (compose-space (first (sheet-children pane))))) + (if child-sr + (make-space-requirement :max-width (space-requirement-max-width child-sr) + :max-height (space-requirement-max-height child-sr)) + (make-space-requirement)))) (defmethod allocate-space ((pane viewport-pane) width height) (with-slots (hscrollbar vscrollbar) (sheet-parent pane) @@ -1960,34 +1967,59 @@ (defmethod compose-space ((pane scroller-pane) &key width height) (declare (ignore width height)) (with-slots (viewport vscrollbar hscrollbar suggested-width suggested-height - x-spacing y-spacing scroll-bar) + x-spacing y-spacing scroll-bar) pane (if viewport (let ((req - ; v-- where does this requirement come from? - ; a: just an arbitrary default - (make-space-requirement + ;; v-- where does this requirement come from? + ;; a: just an arbitrary default + (make-space-requirement :width suggested-width :height suggested-height :max-width +fill+ :max-height +fill+ :min-width (max (* 2 x-spacing) (if (null scroll-bar) 0 30)) - :min-height (max (* 2 y-spacing) (if (null scroll-bar) 0 30))) - #+nil - (make-space-requirement :height +fill+ :width +fill+))) + :min-height (max (* 2 y-spacing) (if (null scroll-bar) 0 30)))) + (viewport-child (first (sheet-children viewport)))) (when vscrollbar (setq req (space-requirement+* - (space-requirement-combine #'max - req - (compose-space vscrollbar)) - :height *scrollbar-thickness* - :min-height *scrollbar-thickness* - :max-height *scrollbar-thickness*))) + (space-requirement-combine #'max + req + (compose-space vscrollbar)) + :height *scrollbar-thickness* + :min-height *scrollbar-thickness* + :max-height *scrollbar-thickness*))) (when hscrollbar (setq req (space-requirement+* - (space-requirement-combine #'max - req - (compose-space hscrollbar)) - :width *scrollbar-thickness* - :min-width *scrollbar-thickness* - :max-width *scrollbar-thickness*))) + (space-requirement-combine + #'max req (compose-space hscrollbar)) + :width *scrollbar-thickness* + :min-width *scrollbar-thickness* + :max-width *scrollbar-thickness*))) + (let* ((viewport-sr (compose-space viewport + :width suggested-width + :height suggested-height)) + (max-width (+ (space-requirement-max-width viewport-sr) + (if vscrollbar *scrollbar-thickness* 0) + ;; I don't know why this is necessary. + (if (extended-output-stream-p viewport-child) + (* 4 (stream-vertical-spacing viewport-child)) + 0))) + (max-height (+ (space-requirement-max-height viewport-sr) + (if hscrollbar *scrollbar-thickness* 0) + ;; I don't know why this is necessary. + (if (extended-output-stream-p viewport-child) + (* 4 (stream-vertical-spacing viewport-child)) + 0)))) + (setq req (make-space-requirement + :width (min (space-requirement-width req) + max-width) + :height (min (space-requirement-height req) + max-height) + :min-width (min (space-requirement-min-width req) + max-width) + :min-height (min (space-requirement-min-height req) + max-height) + :max-width max-width + :max-height max-height))) + req) (make-space-requirement)))) From thenriksen at common-lisp.net Tue Aug 21 22:09:02 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 21 Aug 2007 18:09:02 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070821220902.2F1D719018@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27201 Modified Files: text-editor-gadget.lisp gadgets.lisp Log Message: Attempt at cleaning up the text-field and text-editor gadget mess. Drei/Goatee selection now more elegant and complex setups (scrolling, minibuffer for Drei) now handled well without relying on undocumented McCLIM quirks. The various size-specification-features should also work now. --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2007/02/07 12:44:17 1.8 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2007/08/21 22:09:01 1.9 @@ -27,30 +27,89 @@ ;;; This file contains the concrete implementation of the text-field ;;; and text-editor gadgets. It is loaded rather late, because it -;;; requires Drei. +;;; requires Drei. Half of the complexity here is about working around +;;; annoying Goatee quirks, generalising it to three editor substrates +;;; is nontrivial. (in-package :clim-internals) -;;; ------------------------------------------------------------------------------------------ -;;; 30.4.8 The concrete text-field Gadget +;;; The text editor gadget(s) is implemented as a class implementing +;;; the text editor gadget protocol, but containing an editor +;;; substrate object that takes care of the actual editing logic, +;;; redisplay, etc. The substrates need to be gadgets themselves and +;;; are defined here. -(defclass text-field-pane (text-field - drei:drei-gadget-pane) - ((previous-focus :accessor previous-focus :initform nil - :documentation - "The pane that previously had keyboard focus") - (activation-gestures :accessor activation-gestures - :initarg :activation-gestures - :documentation "gestures that cause the -activate callback to be called")) - (:default-initargs - :activation-gestures *standard-activation-gestures*)) +(defparameter *default-text-field-text-style* + (make-text-style :fixed :roman :normal)) + +(defclass editor-substrate-mixin (value-gadget) + ((activation-gestures :reader activation-gestures + :initarg :activation-gestures) + (user :reader user-gadget + :initarg :user-gadget + :documentation "The editor gadget using this editor substrate." + :initform (error "Editor substrates must have a user."))) + (:documentation "A mixin class for text editor gadget substrates.") + (:default-initargs :activation-gestures '())) + +(defmethod gadget-id ((gadget editor-substrate-mixin)) + (gadget-id (user-gadget gadget))) + +(defmethod (setf gadget-id) (value (gadget editor-substrate-mixin)) + (setf (gadget-id (user-gadget gadget)) value)) + +(defmethod gadget-client ((gadget editor-substrate-mixin)) + (gadget-client (user-gadget gadget))) + +(defmethod (setf gadget-client) (value (gadget editor-substrate-mixin)) + (setf (gadget-client (user-gadget gadget)) value)) + +(defmethod gadget-armed-callback ((gadget editor-substrate-mixin)) + (gadget-armed-callback (user-gadget gadget))) + +(defmethod gadget-disarmed-callback ((gadget editor-substrate-mixin)) + (gadget-disarmed-callback (user-gadget gadget))) + +(defclass text-field-substrate-mixin (editor-substrate-mixin) + () + (:documentation "A mixin class for editor substrates used for text field gadgets.")) -(defmethod initialize-instance :after ((object text-field-pane) &key value) - ;; Why doesn't `value-gadget' do this for us? - (setf (gadget-value object) value)) +(defclass text-editor-substrate-mixin (editor-substrate-mixin) + ((ncolumns :reader text-editor-ncolumns + :initarg :ncolumns + :initform nil + :type (or null integer)) + (nlines :reader text-editor-nlines + :initarg :nlines + :initform nil + :type (or null integer))) + (:documentation "A mixin class for editor substrates used for text editor gadgets.")) + +;;; Now, define the Drei substrate. + +(defclass drei-editor-substrate (drei:drei-gadget-pane + editor-substrate-mixin) + () + (:documentation "A class for Drei-based editor substrates.")) -(defmethod compose-space ((pane text-field-pane) &key width height) +(defmethod (setf gadget-value) :after (value (gadget drei-editor-substrate) + &key invoke-callback) + (declare (ignore invoke-callback)) + ;; Hm! I wonder if this can cause trouble. I think not. + (drei:display-drei gadget)) + +(defclass drei-text-field-substrate (text-field-substrate-mixin + drei-editor-substrate) + () + (:documentation "The class for Drei-based text field substrates.")) + +(defmethod drei:handle-gesture ((drei drei-text-field-substrate) gesture) + (if (with-activation-gestures ((activation-gestures drei)) + (activation-gesture-p gesture)) + (activate-callback drei (gadget-client drei) (gadget-id drei)) + (call-next-method))) + +(defmethod compose-space ((pane drei-text-field-substrate) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) (let ((as (text-style-ascent (medium-text-style medium) medium)) @@ -59,44 +118,14 @@ (let ((width w) (height (+ as ds))) (make-space-requirement :height height :max-height height :min-height height - :min-width width :width width))))) + :min-width width :width width))))) -(defmethod drei:handle-gesture ((drei text-field-pane) gesture) - (if (with-activation-gestures ((activation-gestures drei)) - (activation-gesture-p gesture)) - (activate-callback drei (gadget-client drei) (gadget-id drei)) - (call-next-method))) - -(defmethod allocate-space ((pane text-field-pane) w h) - (resize-sheet pane w h)) - -;;; ------------------------------------------------------------------------------------------ -;;; 30.4.9 The concrete text-editor Gadget +(defclass drei-text-editor-substrate (text-editor-substrate-mixin + drei-editor-substrate) + () + (:documentation "The class for Drei-based text editor substrates.")) -(defclass text-editor-pane (text-editor drei:drei-gadget-pane) - ((ncolumns :type (or null integer) - :initarg :ncolumns - :initform nil - :accessor text-editor-ncolumns) - (nlines :type (or null integer) - :initarg :nlines - :initform nil - :accessor text-editor-nlines)) - (:default-initargs :activation-gestures nil)) - -(defmethod initialize-instance :after ((object text-editor-pane) &key value) - ;; Why doesn't `value-gadget' do this for us? - (setf (gadget-value object) value)) - -(defmethod make-pane-1 :around (fm (frame application-frame) - (type (eql 'text-editor)) - &rest args &key) - (apply #'make-pane-1 fm frame :drei - :drei-class 'text-editor-pane - :minibuffer t - args)) - -(defmethod compose-space ((pane text-editor-pane) &key width height) +(defmethod compose-space ((pane drei-text-editor-substrate) &key width height) (with-sheet-medium (medium pane) (let* ((text-style (medium-text-style medium)) (line-height (+ (text-style-height text-style medium) @@ -113,86 +142,72 @@ (height (if nlines (+ (* nlines line-height)) height))) - (list :width width :max-width width :min-width width - :height height :max-height height :min-height height))))))) + (list + :width width :max-width width :min-width width + :height height :max-height height :min-height height))))))) -(defmethod allocate-space ((pane text-editor-pane) w h) +(defmethod allocate-space ((pane drei-text-editor-substrate) w h) (resize-sheet pane w h)) -;;; ------------------------------------------------------------------------------------------ -;;; 30.4.9 Alternative Goatee-based implementation - -(defparameter *default-text-field-text-style* - (make-text-style :fixed :roman :normal)) +;;; Now, define the Goatee substrate. -(defclass goatee-text-field-pane (text-field - standard-extended-output-stream - standard-output-recording-stream - basic-pane) - ((area :accessor area :initform nil - :documentation "The Goatee area used for text editing.") - (previous-focus :accessor previous-focus :initform nil - :documentation - "The pane that previously had keyboard focus") - (activation-gestures :accessor activation-gestures - :initarg :activation-gestures - :documentation "gestures that cause the - activate callback to be called")) +(defclass goatee-editor-substrate (editor-substrate-mixin + text-field + clim-stream-pane) + ((area :accessor area + :initform nil + :documentation "The Goatee area used for text editing.") + ;; This hack is necessary because the Goatee editing area is not + ;; created until the first redisplay... yuck. + (value :documentation "The initial value for the Goatee area.")) (:default-initargs - :text-style *default-text-field-text-style* - :activation-gestures *standard-activation-gestures*)) + :text-style *default-text-field-text-style*)) -(defmethod initialize-instance :after ((gadget text-field) &rest rest) - (unless (getf rest :normal) - (setf (slot-value gadget 'current-color) +white+ - (slot-value gadget 'normal) +white+))) - -(defmethod initialize-instance :after ((pane goatee-text-field-pane) &rest rest) +(defmethod initialize-instance :after ((pane goatee-editor-substrate) &rest rest) (declare (ignore rest)) - #-nil (setf (medium-text-style (sheet-medium pane)) - (slot-value pane 'text-style))) + (setf (medium-text-style (sheet-medium pane)) + (slot-value pane 'text-style))) ;; Is there really a benefit to waiting until the first painting to ;; create the goatee instance? Why not use INITIALIZE-INSTANCE? -(defmethod handle-repaint :before ((pane goatee-text-field-pane) region) +(defmethod handle-repaint :before ((pane goatee-editor-substrate) region) (declare (ignore region)) (unless (area pane) (multiple-value-bind (cx cy) - (stream-cursor-position pane) + (stream-cursor-position pane) (setf (cursor-visibility (stream-text-cursor pane)) nil) (setf (area pane) (make-instance 'goatee:simple-screen-area - :area-stream pane - :x-position cx - :y-position cy - :initial-contents (slot-value pane - 'value)))) + :area-stream pane + :x-position cx + :y-position cy + :initial-contents (slot-value pane 'value)))) (stream-add-output-record pane (area pane)))) ;;; This implements click-to-focus-keyboard-and-pass-click-through ;;; behaviour. -(defmethod handle-event :before - ((gadget goatee-text-field-pane) (event pointer-button-press-event)) +(defmethod handle-event :before + ((gadget goatee-editor-substrate) (event pointer-button-press-event)) (let ((previous (stream-set-input-focus gadget))) (when (and previous (typep previous 'gadget)) (disarmed-callback previous (gadget-client previous) (gadget-id previous))) (armed-callback gadget (gadget-client gadget) (gadget-id gadget)))) -(defmethod armed-callback :after ((gadget goatee-text-field-pane) client id) +(defmethod armed-callback :after ((gadget goatee-editor-substrate) client id) (declare (ignore client id)) (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :solid)))) -(defmethod disarmed-callback :after ((gadget goatee-text-field-pane) client id) +(defmethod disarmed-callback :after ((gadget goatee-editor-substrate) client id) (declare (ignore client id)) (handle-repaint gadget +everywhere+) ;FIXME: trigger initialization (let ((cursor (cursor (area gadget)))) (letf (((cursor-state cursor) nil)) (setf (cursor-appearance cursor) :hollow)))) -(defmethod handle-event - ((gadget goatee-text-field-pane) (event key-press-event)) +(defmethod handle-event + ((gadget goatee-editor-substrate) (event key-press-event)) (let ((gesture (convert-to-gesture event)) (*activation-gestures* (activation-gestures gadget))) (when (activation-gesture-p gesture) @@ -209,7 +224,7 @@ (gadget-id gadget) new-value))))) -(defmethod (setf gadget-value) :after (new-value (gadget goatee-text-field-pane) +(defmethod (setf gadget-value) :after (new-value (gadget goatee-editor-substrate) &key invoke-callback) (declare (ignore invoke-callback)) (let* ((area (area gadget)) @@ -221,7 +236,7 @@ (goatee::redisplay-area area))) #+nil -(defmethod handle-repaint ((pane goatee-text-field-pane) region) +(defmethod handle-repaint ((pane goatee-editor-substrate) region) (declare (ignore region)) (with-special-choices (pane) (with-sheet-medium (medium pane) @@ -233,8 +248,12 @@ :align-x :left :align-y :baseline))))) +(defclass goatee-text-field-substrate (text-field-substrate-mixin + goatee-editor-substrate) + () + (:documentation "The class for Goatee-based text field substrates.")) -(defmethod compose-space ((pane goatee-text-field-pane) &key width height) +(defmethod compose-space ((pane goatee-text-field-substrate) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) (let ((as (text-style-ascent (medium-text-style medium) medium)) @@ -243,48 +262,140 @@ (let ((width w) (height (+ as ds))) (make-space-requirement :width width :height height - :max-width width :max-height height - :min-width width :min-height height))))) + :max-width width :max-height height + :min-width width :min-height height))))) + +(defclass goatee-text-editor-substrate (text-editor-substrate-mixin + goatee-editor-substrate) + () + (:documentation "The class for Goatee-based text field substrates.")) -(defmethod allocate-space ((pane goatee-text-field-pane) w h) +(defmethod compose-space ((pane goatee-text-editor-substrate) &key width height) + (with-sheet-medium (medium pane) + (let* ((text-style (medium-text-style medium)) + (line-height (+ (text-style-height text-style medium) + (stream-vertical-spacing pane))) + (column-width (text-style-width text-style medium))) + (with-accessors ((ncolumns text-editor-ncolumns) + (nlines text-editor-nlines)) pane + (apply #'space-requirement-combine* #'(lambda (req1 req2) + (or req2 req1)) + (call-next-method) + (let ((width (if ncolumns + (+ (* ncolumns column-width)) + width)) + (height (if nlines + (+ (* nlines line-height)) + height))) + (list :width width :max-width width :min-width width + :height height :max-height height :min-height height))))))) + +(defmethod allocate-space ((pane goatee-text-editor-substrate) w h) (resize-sheet pane w h)) -(defclass goatee-text-editor-pane (goatee-text-field-pane) - ((width :type integer - :initarg :width - :initform 300 - :reader text-editor-width) - (height :type integer - :initarg :height - :initform 300 - :reader text-editor-height)) - (:default-initargs :activation-gestures nil)) - -(defmethod compose-space ((pane goatee-text-editor-pane) &key width height) - (declare (ignore width height)) - (let ((width (text-editor-width pane)) - (height (text-editor-height pane))) - (make-space-requirement :width width - :min-width width - :max-width width - :height height - :min-height height - :max-height height))) +(defun make-text-field-substrate (user &rest args) + "Create an appropriate text field gadget editing substrate object." + (let* ((substrate (apply #'make-pane (if *use-goatee* + 'goatee-text-field-substrate + 'drei-text-field-substrate) + :user-gadget user args)) + (sheet substrate)) + (values substrate sheet))) + +(defun make-text-editor-substrate (user &rest args &key scroll-bars value + &allow-other-keys) + "Create an appropriate text editor gadget editing substrate +object. Returns two values, the first is the substrate object, +the second is the sheet that should be adopted by the user +gadget." + (let* ((minibuffer (when (and (not *use-goatee*) scroll-bars) + (make-pane 'drei::drei-minibuffer-pane))) + (substrate (apply #'make-pane (if *use-goatee* + 'goatee-text-editor-substrate + 'drei-text-editor-substrate) + :user-gadget user + :minibuffer minibuffer args)) + (sheet (if scroll-bars + (scrolling (:scroll-bars scroll-bars) + substrate) + substrate))) + (if *use-goatee* + (setf (slot-value substrate 'value) value) + (setf (gadget-value substrate) value)) + (values substrate (if minibuffer + (vertically () [90 lines skipped] --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/03/04 22:27:30 1.106 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2007/08/21 22:09:01 1.107 @@ -644,6 +644,11 @@ (:documentation "The value is a string") (:default-initargs :value "")) +(defmethod initialize-instance :after ((gadget text-field) &rest rest) + (unless (getf rest :normal) + (setf (slot-value gadget 'current-color) +white+ + (slot-value gadget 'normal) +white+))) + ;;; 30.4.9 The abstract text-editor Gadget (defclass text-editor (text-field) From thenriksen at common-lisp.net Fri Aug 24 13:04:40 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 24 Aug 2007 09:04:40 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070824130440.B66AA2D064@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3818/Drei Modified Files: drei-redisplay.lisp Log Message: Fix handling of tabs in Drei cursor positioning. This is a hack. The real solution is to stop using tabs. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/08/06 13:19:03 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/08/24 13:04:40 1.8 @@ -194,7 +194,12 @@ for object = (when go-again (object-before line-beg-mark)) while go-again - when (characterp object) + if (eql object #\Tab) + do (progn (incf displacement (string-size array)) + (incf displacement (tab-width pane)) + (setf (fill-pointer array) 0)) + else if (and (characterp object) + (not (eql object #\Tab))) do (vector-push-extend object array) else do (progn (incf displacement (string-size array)) (incf displacement (object-size object)) From thenriksen at common-lisp.net Fri Aug 24 13:07:54 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 24 Aug 2007 09:07:54 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20070824130754.049C63001A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv4113/Drei Modified Files: lisp-syntax.lisp Log Message: Make Drei's form-at-top-level-p function more general. Also, an indentation fix. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/08/20 18:43:06 1.30 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2007/08/24 13:07:53 1.31 @@ -1441,7 +1441,7 @@ (defgeneric form-at-top-level-p (form) (:documentation "Return NIL if `form' is not a top-level-form, T otherwise.") - (:method ((form form)) + (:method ((form parser-symbol)) (or (typep (parent form) 'form*) (null (parent form))))) @@ -1539,10 +1539,10 @@ (defmethod display-parse-tree :around (parse-symbol stream (drei drei) (syntax lisp-syntax)) (with-slots (top bot) drei - (when (and (start-offset parse-symbol) - (mark< (start-offset parse-symbol) bot) - (mark> (end-offset parse-symbol) top)) - (call-next-method)))) + (when (and (start-offset parse-symbol) + (mark< (start-offset parse-symbol) bot) + (mark> (end-offset parse-symbol) top)) + (call-next-method)))) (defmethod display-parse-tree (parse-symbol stream (drei drei) (syntax lisp-syntax)) From thenriksen at common-lisp.net Sun Aug 26 16:02:48 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 26 Aug 2007 12:02:48 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20070826160248.0B525100A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14745 Modified Files: NEWS Log Message: Added mention of the space-requirement stuff for the layout panes. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/08/20 18:32:26 1.22 +++ /project/mcclim/cvsroot/mcclim/NEWS 2007/08/26 16:02:47 1.23 @@ -1,4 +1,6 @@ * Changes in mcclim-0.9.5 relative to 0.9.4: +** specification compliance: various layout panes no longer quite as + aggressive at eating the space requirements of their children. ** Drei now has better support for delimiter gestures. ** Installation: the systems clim-listener, scigraph, clim-examples, and clouseau can now be loaded without loading the system mcclim From dlichteblau at common-lisp.net Sun Aug 26 20:55:25 2007 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 26 Aug 2007 16:55:25 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20070826205525.515A8830AC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv27401 Modified Files: keys.lisp Log Message: revert my previous commit for the release because of unresolved bugs --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2007/07/15 12:00:08 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/keys.lisp 2007/08/26 20:55:25 1.4 @@ -64,7 +64,6 @@ (DEFINE-KEY 91 (T :[ #\[)) (DEFINE-KEY 92 (T :|\\| #\\)) (DEFINE-KEY 93 (T :] #\])) -(DEFINE-KEY 94 (T :^ #\^)) (DEFINE-KEY 95 (T :_ #\_)) (DEFINE-KEY 96 (T :|`| #\`)) (DEFINE-KEY 97 (T :|a| #\a)) @@ -96,27 +95,16 @@ (DEFINE-KEY 123 (T :{ #\{)) (DEFINE-KEY 124 (T :|\|| #\|)) (DEFINE-KEY 125 (T :} #\})) -(DEFINE-KEY 167 (T :SECTION NIL)) -(DEFINE-KEY 176 (T :DEGREE NIL)) -(DEFINE-KEY 196 (T :A-DIAERESIS #.(code-char 196))) -(DEFINE-KEY 214 (T :O-DIAERESIS #.(code-char 214))) -(DEFINE-KEY 220 (T :U-DIAERESIS #.(code-char 220))) -(DEFINE-KEY 223 (T :SSHARP #.(code-char 223))) -(DEFINE-KEY 228 (T :|a-DIAERESIS| #.(code-char 228))) -(DEFINE-KEY 246 (T :|o-DIAERESIS| #.(code-char 246))) -(DEFINE-KEY 252 (T :|u-DIAERESIS| #.(code-char 252))) (DEFINE-KEY 65056 (T :ISO-LEFT-TAB NIL)) (DEFINE-KEY 65106 (T :DEAD-CIRCUMFLEX NIL)) (DEFINE-KEY 65107 (T :DEAD-TILDE NIL)) -(DEFINE-KEY 65237 ((12) :BACKSPACE #\Backspace) (T :TERMINATE-SERVER NIL)) (DEFINE-KEY 65273 (T :POINTER-ENABLE-KEYS NIL)) (DEFINE-KEY 65288 (T :BACKSPACE #\Backspace)) -(DEFINE-KEY 65288 ((4 8 0) :BACKSPACE #\Backspace) (T :TERMINATE-SERVER NIL)) (DEFINE-KEY 65289 (T :TAB #\Tab)) (DEFINE-KEY 65293 (T :RETURN #\Return)) (DEFINE-KEY 65299 ((9 1) :BREAK NIL) (T :PAUSE NIL)) (DEFINE-KEY 65300 (T :SCROLL-LOCK NIL)) -(DEFINE-KEY 65301 ((12 8) :PRINT NIL) (T :SYS-REQ NIL)) +(DEFINE-KEY 65301 (T :SYS-REQ NIL)) (DEFINE-KEY 65307 (T :ESCAPE NIL)) (DEFINE-KEY 65312 (T :MULTI-KEY NIL)) (DEFINE-KEY 65360 (T :HOME NIL)) @@ -128,11 +116,9 @@ (DEFINE-KEY 65366 (T :NEXT NIL)) (DEFINE-KEY 65367 (T :END NIL)) (DEFINE-KEY 65377 ((12 4 8 0) :PRINT NIL) (T :SYS-REQ NIL)) -(DEFINE-KEY 65377 ((4 0) :PRINT NIL) (T :SYS-REQ NIL)) (DEFINE-KEY 65379 (T :INSERT NIL)) (DEFINE-KEY 65383 (T :MENU NIL)) (DEFINE-KEY 65387 ((12 4) :PAUSE NIL) (T :BREAK NIL)) -(DEFINE-KEY 65406 (T :MODE-SWITCH NIL)) (DEFINE-KEY 65407 (T :NUM-LOCK NIL)) (DEFINE-KEY 65421 (T :KP-ENTER NIL)) (DEFINE-KEY 65429 (T :KP-HOME NIL)) @@ -151,11 +137,6 @@ (DEFINE-KEY 65453 (T :KP-SUBTRACT NIL)) (DEFINE-KEY 65454 (T :KP-DECIMAL NIL)) (DEFINE-KEY 65455 (T :KP-DIVIDE NIL)) -(DEFINE-KEY 65450 ((4 8 0) :KP-MULTIPLY NIL) (T NIL NIL)) -(DEFINE-KEY 65451 ((4 8 0) :KP-ADD NIL) (T NIL NIL)) -(DEFINE-KEY 65452 (T :KP-SEPARATOR NIL)) -(DEFINE-KEY 65453 ((4 8 0) :KP-SUBTRACT NIL) (T NIL NIL)) -(DEFINE-KEY 65455 ((4 8 0) :KP-DIVIDE NIL) (T NIL NIL)) (DEFINE-KEY 65456 (T :KP-0 NIL)) (DEFINE-KEY 65457 (T :KP-1 NIL)) (DEFINE-KEY 65458 (T :KP-2 NIL)) @@ -177,18 +158,6 @@ (DEFINE-KEY 65478 (T :F9 NIL)) (DEFINE-KEY 65479 (T :F10 NIL)) (DEFINE-KEY 65480 (T :F11 NIL)) -(DEFINE-KEY 65470 ((4 8 0) :F1 NIL) (T NIL NIL)) -(DEFINE-KEY 65471 ((4 8 0) :F2 NIL) (T NIL NIL)) -(DEFINE-KEY 65472 ((4 8 0) :F3 NIL) (T NIL NIL)) -(DEFINE-KEY 65473 ((4 8 0) :F4 NIL) (T NIL NIL)) -(DEFINE-KEY 65474 ((4 8 0) :F5 NIL) (T NIL NIL)) -(DEFINE-KEY 65475 ((4 8 0) :F6 NIL) (T NIL NIL)) -(DEFINE-KEY 65476 ((4 8 0) :F7 NIL) (T NIL NIL)) -(DEFINE-KEY 65477 ((4 8 0) :F8 NIL) (T NIL NIL)) -(DEFINE-KEY 65478 ((4 8 0) :F9 NIL) (T NIL NIL)) -(DEFINE-KEY 65479 ((4 8 0) :F10 NIL) (T NIL NIL)) -(DEFINE-KEY 65480 ((4 8 0) :F11 NIL) (T NIL NIL)) -(DEFINE-KEY 65481 ((4 8 0) :F12 NIL) (T NIL NIL)) (DEFINE-KEY 65505 (T :SHIFT-LEFT NIL)) (DEFINE-KEY 65506 (T :SHIFT-RIGHT NIL)) (DEFINE-KEY 65507 (T :CONTROL-LEFT NIL)) @@ -196,25 +165,7 @@ (DEFINE-KEY 65509 (T :CAPS-LOCK NIL)) (DEFINE-KEY 65511 (T :META-LEFT NIL)) (DEFINE-KEY 65512 (T :META-RIGHT NIL)) -(DEFINE-KEY 65513 (T :ALT-LEFT NIL)) -(DEFINE-KEY 65515 (T :SUPER-LEFT NIL)) (DEFINE-KEY 65535 (T :DELETE #\Rubout)) (DEFINE-KEY 268828535 (T :SUN-AUDIO-LOWER-VOLUME NIL)) (DEFINE-KEY 268828536 (T :SUN-AUDIO-MUTE NIL)) -(DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) -(DEFINE-KEY 269024769 ((12) :F1 NIL) (T NIL NIL)) -(DEFINE-KEY 269024770 ((12) :F2 NIL) (T NIL NIL)) -(DEFINE-KEY 269024771 ((12) :F3 NIL) (T NIL NIL)) -(DEFINE-KEY 269024772 ((12) :F4 NIL) (T NIL NIL)) -(DEFINE-KEY 269024773 ((12) :F5 NIL) (T NIL NIL)) -(DEFINE-KEY 269024774 ((12) :F6 NIL) (T NIL NIL)) -(DEFINE-KEY 269024775 ((12) :F7 NIL) (T NIL NIL)) -(DEFINE-KEY 269024776 ((12) :F8 NIL) (T NIL NIL)) -(DEFINE-KEY 269024777 ((12) :F9 NIL) (T NIL NIL)) -(DEFINE-KEY 269024778 ((12) :F10 NIL) (T NIL NIL)) -(DEFINE-KEY 269024779 ((12) :F11 NIL) (T NIL NIL)) -(DEFINE-KEY 269024780 ((12) :F12 NIL) (T NIL NIL)) -(DEFINE-KEY 269024800 ((12) :KP-DIVIDE NIL) (T NIL NIL)) -(DEFINE-KEY 269024801 ((12) :KP-MULTIPLY NIL) (T NIL NIL)) -(DEFINE-KEY 269024802 ((12) :KP-ADD NIL) (T NIL NIL)) -(DEFINE-KEY 269024803 ((12) :KP-SUBTRACT NIL) (T NIL NIL)) +(DEFINE-KEY 268828537 (T :SUN-AUDIO-RAISE-VOLUME NIL)) \ No newline at end of file From crhodes at common-lisp.net Tue Aug 28 14:50:25 2007 From: crhodes at common-lisp.net (crhodes) Date: Tue, 28 Aug 2007 10:50:25 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20070828145025.571475609E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv11067/Backends/PostScript Modified Files: graphics.lisp Log Message: Allow addition of a rectangle set path in postscript. Needed for clipping regions, at least, in certain complicated beam groups in gsharp. --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2007/07/11 15:26:20 1.19 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/graphics.lisp 2007/08/28 14:50:25 1.20 @@ -228,6 +228,10 @@ (let ((ellipse (transform-region *transformation* ellipse))) (put-ellipse stream ellipse t))) +(defmethod postscript-add-path (stream (rs climi::standard-rectangle-set)) + (map-over-region-set-regions + (lambda (r) (postscript-add-path stream r)) + rs)) ;;; Graphics state