From thenriksen at common-lisp.net Tue Nov 13 13:05:38 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 13 Nov 2007 08:05:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071113130538.EDA9A2E1C8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv6956 Modified Files: esa-buffer.lisp Log Message: Pass on arguments from `create-new-buffer' to `frame-create-new-buffer'. --- /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp 2006/11/08 01:10:16 1.1 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp 2007/11/13 13:05:38 1.2 @@ -32,9 +32,9 @@ (defgeneric frame-make-new-buffer (application-frame &key &allow-other-keys) (:documentation "Create a empty buffer for the application frame.")) -(defun make-new-buffer (&key &allow-other-keys) +(defun make-new-buffer (&rest args &key &allow-other-keys) "Create a empty buffer for the current frame." - (frame-make-new-buffer *application-frame*)) + (apply #'frame-make-new-buffer *application-frame* args)) (defgeneric frame-save-buffer-to-stream (application-frame buffer stream) (:documentation "Save the entire BUFFER to STREAM in the appropriate From thenriksen at common-lisp.net Fri Nov 16 09:28:46 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 16 Nov 2007 04:28:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071116092846.0F8667B4AE@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31402/Drei Modified Files: search-commands.lisp packages.lisp drei.lisp Added Files: targets.lisp Log Message: Added Drei "target" concept, facilitating search/replace-commands that act over multiple buffers (or "targets"). --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2007/11/16 09:28:44 1.2 @@ -8,6 +8,8 @@ ;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic at yahoo.com) +;;; (c) copyright 2007 by +;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -28,6 +30,29 @@ (in-package :drei-commands) +(defun simple-search (drei-instance search-function + targets more-targets-predicate more-targets-fn) + (let ((old-buffer (buffer drei-instance)) + (old-offset (offset (point drei-instance)))) + (activate-target-specification targets) + (or (loop until (funcall search-function (point drei-instance)) + if (funcall more-targets-predicate targets) + do (funcall more-targets-fn targets) + else return nil + finally (return t)) + (setf (buffer drei-instance) old-buffer + (offset (point drei-instance)) old-offset)))) + +(defun simple-search-forward (drei-instance search-function &optional + (targets (funcall *default-target-creator* drei-instance))) + (simple-search drei-instance search-function targets + #'subsequent-targets-p #'next-target)) + +(defun simple-search-backward (drei-instance search-function &optional + (targets (funcall *default-target-creator* drei-instance))) + (simple-search drei-instance search-function targets + #'preceding-targets-p #'previous-target)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; String search @@ -36,13 +61,19 @@ ((string 'string :prompt "String Search")) "Prompt for a string and search forward for it. If found, leaves point after string. If not, leaves point where it is." - (search-forward *current-point* string :test (case-relevant-test string))) + (simple-search-forward *current-window* + #'(lambda (mark) + (search-forward mark string + :test (case-relevant-test string))))) (define-command (com-reverse-string-search :name t :command-table search-table) ((string 'string :prompt "Reverse String Search")) "Prompt for a string and search backward for it. If found, leaves point before string. If not, leaves point where it is." - (search-backward *current-point* string :test (case-relevant-test string))) + (simple-search-backward *current-window* + #'(lambda (mark) + (search-backward mark string + :test (case-relevant-test string))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -52,13 +83,17 @@ ((word 'string :prompt "Search word")) "Prompt for a whitespace delimited word and search forward for it. If found, leaves point after the word. If not, leaves point where it is." - (search-word-forward *current-point* word)) + (simple-search-forward *current-window* + #'(lambda (mark) + (search-word-forward mark word)))) (define-command (com-reverse-word-search :name t :command-table search-table) ((word 'string :prompt "Search word")) "Prompt for a whitespace delimited word and search backward for it. If found, leaves point before the word. If not, leaves point where it is." - (search-word-backward *current-point* word)) + (simple-search-backward *current-window* + #'(lambda (mark) + (search-backward mark word)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -66,51 +101,75 @@ (make-command-table 'isearch-drei-table :errorp nil) -(defun isearch-command-loop (pane forwardp) - (let* ((point (point pane)) - (orig-offset (offset point))) - (unless (endp (isearch-states pane)) - (setf (isearch-previous-string pane) - (search-string (first (isearch-states pane))))) - (setf (isearch-mode pane) t) - (setf (isearch-states pane) +(defun isearch-command-loop (drei-instance forwardp) + (let* ((point (point drei-instance)) + (orig-offset (offset point)) + (orig-buffer (buffer drei-instance))) + (unless (endp (isearch-states drei-instance)) + (setf (isearch-previous-string drei-instance) + (search-string (first (isearch-states drei-instance))))) + (setf (isearch-mode drei-instance) t) + (setf (isearch-states drei-instance) (list (make-instance 'isearch-state :search-string "" :search-mark (clone-mark point) + :search-buffer orig-buffer :search-forward-p forwardp - :search-success-p t))) + :search-success-p t + :targets (funcall *default-target-creator* drei-instance)))) + (activate-target-specification (targets (first (isearch-states drei-instance)))) (simple-command-loop 'isearch-drei-table - (isearch-mode pane) + (isearch-mode drei-instance) ((display-message "Mark saved where search started") - (setf (offset (mark pane)) orig-offset) - (setf (isearch-mode pane) nil)) + (setf (offset (mark drei-instance)) orig-offset) + (setf (isearch-mode drei-instance) nil)) ((display-message "Returned point to original location") - (setf (offset (point pane)) orig-offset) - (setf (isearch-mode pane) nil) + (setf (buffer drei-instance) orig-buffer) + (setf (offset (point drei-instance)) orig-offset) + (setf (isearch-mode drei-instance) nil) (signal 'abort-gesture :event *current-gesture*))))) -(defun isearch-from-mark (pane mark string forwardp) - (let* ((point (point pane)) +(defun isearch-from-mark (drei-instance mark string forwardp) + (let* ((point (point drei-instance)) (mark2 (clone-mark mark)) (success (funcall (if forwardp #'search-forward #'search-backward) mark2 string - :test (case-relevant-test string)))) - (when success - (setf (offset point) (offset mark2) - (offset mark) (if forwardp - (- (offset mark2) (length string)) - (+ (offset mark2) (length string))))) + :test (case-relevant-test string))) + (state (first (isearch-states drei-instance)))) + (if success + (setf (offset point) (offset mark2) + (offset mark) (if forwardp + (- (offset mark2) (length string)) + (+ (offset mark2) (length string)))) + (when (funcall (if forwardp + #'subsequent-targets-p + #'preceding-targets-p) + (targets state)) + (funcall (if forwardp #'next-target #'previous-target) + (targets state)) + (if (isearch-from-mark drei-instance (clone-mark (point drei-instance)) + string forwardp) + (return-from isearch-from-mark t) + (progn (pop (isearch-states drei-instance)) + (funcall (if forwardp #'previous-target #'next-target) + (targets state)) + (setf (offset (point drei-instance)) + (offset (search-mark state))) + nil)))) (display-message "~:[Failing ~;~]Isearch~:[ backward~;~]: ~A" success forwardp (display-string string)) (push (make-instance 'isearch-state - :search-string string - :search-mark mark - :search-forward-p forwardp - :search-success-p success) - (isearch-states pane)) + :search-string string + :search-mark mark + :search-buffer (buffer drei-instance) + :search-forward-p forwardp + :search-success-p success + :targets (targets state)) + (isearch-states drei-instance)) (unless success - (beep)))) + (beep)) + success)) (define-command (com-isearch-forward :name t :command-table search-table) () (display-message "Isearch: ") @@ -280,15 +339,20 @@ (defun query-replace-find-next-match (state) (with-accessors ((string string1) - (buffers buffers) - (mark mark)) state - (let ((offset-before (offset mark))) + (targets targets)) state + (let* ((mark (point (drei-instance (targets state)))) + (offset-before (offset mark))) (search-forward mark string :test (case-relevant-test string)) - (/= (offset mark) offset-before)))) + (if (= (offset mark) offset-before) + (when (subsequent-targets-p targets) + (next-target targets) + (beginning-of-buffer (point (buffer (drei-instance targets)))) + (query-replace-find-next-match state)) + t)))) (define-command (com-query-replace :name t :command-table search-table) () - (let* ((pane *current-window*) - (old-state (query-replace-state pane)) + (let* ((drei *current-window*) + (old-state (query-replace-state drei)) (old-string1 (when old-state (string1 old-state))) (old-string2 (when old-state (string2 old-state))) (string1 (handler-case @@ -313,21 +377,25 @@ (error () (progn (beep) (display-message "Empty string") (return-from com-query-replace nil)))))) - (setf (query-replace-state pane) (make-instance 'query-replace-state + (setf (query-replace-state drei) (make-instance 'query-replace-state :string1 string1 :string2 string2 - :mark *current-point*)) - (when (query-replace-find-next-match (query-replace-state pane)) - (setf (query-replace-mode pane) t) - (display-message "Replace ~A with ~A:" - string1 string2) - (simple-command-loop 'query-replace-drei-table - (query-replace-mode pane) - ((setf (query-replace-mode pane) nil) - (display-message "Replaced ~A occurence~:P" - (occurrences (query-replace-state pane)))) - ((setf (query-replace-mode pane) nil) - (signal 'abort-gesture :event *current-gesture*)))))) + :targets (funcall *default-target-creator* drei))) + (activate-target-specification (targets (query-replace-state drei))) + (if (query-replace-find-next-match (query-replace-state drei)) + (progn + (setf (query-replace-mode drei) t) + (display-message "Replace ~A with ~A:" + string1 string2) + (simple-command-loop 'query-replace-drei-table + (query-replace-mode drei) + ((setf (query-replace-mode drei) nil) + (deactivate-target-specification (targets (query-replace-state drei))) + (display-message "Replaced ~A occurence~:P" + (occurrences (query-replace-state drei)))) + ((setf (query-replace-mode drei) nil) + (signal 'abort-gesture :event *current-gesture*)))) + (display-message "Replaced 0 occurences")))) (set-key 'com-query-replace 'search-table @@ -338,15 +406,17 @@ (state (query-replace-state pane))) (with-accessors ((string1 string1) (string2 string2) - (occurrences occurrences)) state - (let ((string1-length (length string1))) - (backward-object (mark state) string1-length) - (replace-one-string (mark state) + (occurrences occurrences) + (targets targets)) state + (let ((string1-length (length string1)) + (mark (point (drei-instance targets)))) + (backward-object mark string1-length) + (replace-one-string mark string1-length string2 (no-upper-p string1)) (incf occurrences) - (if (query-replace-find-next-match (query-replace-state pane)) + (if (query-replace-find-next-match state) (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode pane) nil)))))) @@ -359,10 +429,12 @@ (state (query-replace-state pane))) (with-accessors ((string1 string1) (string2 string2) - (occurrences occurrences)) state - (let ((string1-length (length string1))) - (backward-object (mark state) string1-length) - (replace-one-string (mark state) + (occurrences occurrences) + (targets targets)) state + (let ((string1-length (length string1)) + (mark (point (drei-instance targets)))) + (backward-object mark string1-length) + (replace-one-string mark string1-length string2 (no-upper-p string1)) @@ -377,15 +449,17 @@ (state (query-replace-state pane))) (with-accessors ((string1 string1) (string2 string2) - (occurrences occurrences)) state - (let ((string1-length (length string1))) - (loop do (backward-object (mark state) string1-length) - (replace-one-string (mark state) + (occurrences occurrences) + (targets targets)) state + (let ((string1-length (length string1)) + (mark (point (drei-instance targets)))) + (loop do (backward-object mark string1-length) + (replace-one-string mark string1-length string2 (no-upper-p string1)) (incf occurrences) - while (query-replace-find-next-match (query-replace-state pane)) + while (query-replace-find-next-match state) finally (setf (query-replace-mode pane) nil)))))) (define-command (com-query-replace-skip :name t :command-table query-replace-drei-table) () @@ -435,14 +509,18 @@ :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (re-search-forward *current-point* (normalise-minibuffer-regex string)))) + (simple-search-forward *current-window* + #'(lambda (mark) + (re-search-forward mark (normalise-minibuffer-regex string)))))) (define-command (com-regex-search-backward :name t :command-table search-table) () (let ((string (accept 'string :prompt "RE search backward" :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (re-search-backward *current-point* (normalise-minibuffer-regex string)))) + (simple-search-backward *current-window* + #'(lambda (mark) + (re-search-backward mark (normalise-minibuffer-regex string)))))) (define-command (com-how-many :name t :command-table search-table) ((regex 'string :prompt "How many matches for")) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/08/13 21:58:44 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/11/16 09:28:44 1.16 @@ -186,9 +186,9 @@ #:offset-to-screen-position #:page-down #:page-up #:indent-tabs-mode - #:isearch-state #:search-string #:search-mark + #:isearch-state #:search-string #:search-mark #:search-buffer #:search-forward-p #:search-success-p - #:query-replace-state #:string1 #:string2 #:buffers #:mark #:occurrences + #:query-replace-state #:string1 #:string2 #:targets #:occurrences ;; Undo. #:undo-mixin #:undo-tree #:undo-accumulate #:performing-undo @@ -433,7 +433,17 @@ #:start-mark #:end-mark - #:make-buffer-stream) + #:make-buffer-stream + + #:target-specification + #:activate-target-specification + #:deactivate-target-specification + #:subsequent-targets-p #:preceding-targets-p + #:next-target #:previous-target + #:previous-target + #:no-more-targets + #:*default-target-creator* + #:buffer-list-target-specification) (:documentation "Implementation of much syntax-aware, yet no syntax-specific, core functionality of Drei.")) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/01/14 20:03:00 1.15 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/11/16 09:28:44 1.16 @@ -325,8 +325,10 @@ (defclass isearch-state () ((search-string :initarg :search-string :accessor search-string) (search-mark :initarg :search-mark :accessor search-mark) + (search-buffer :initarg :search-buffer :accessor search-buffer) (search-forward-p :initarg :search-forward-p :accessor search-forward-p) - (search-success-p :initarg :search-success-p :accessor search-success-p))) + (search-success-p :initarg :search-success-p :accessor search-success-p) + (targets :initarg :targets :accessor targets ))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -335,7 +337,7 @@ (defclass query-replace-state () ((string1 :initarg :string1 :accessor string1) (string2 :initarg :string2 :accessor string2) - (mark :initarg :mark :accessor mark) + (targets :initarg :targets :accessor targets) (occurences :initform 0 :accessor occurrences))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -675,7 +677,11 @@ :active active) cursors))) -(defmethod (setf buffer) :after (buffer (object drei)) +(defmethod (setf buffer) :before ((buffer drei-buffer) (object drei)) + (with-slots (buffer point) object + (setf (point buffer) point))) + +(defmethod (setf buffer) :after ((buffer drei-buffer) (object drei)) (with-slots (point mark top bot) object (setf point (clone-mark (point buffer)) mark (clone-mark (low-mark buffer) :right) --- /project/mcclim/cvsroot/mcclim/Drei/targets.lisp 2007/11/16 09:28:46 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/targets.lisp 2007/11/16 09:28:46 1.1 ;;; -*- Mode: Lisp; Package: DREI-CORE -*- ;;; (c) copyright 2007 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Facilities and protocols for iterating through buffer objects, the ;;; point being that the buffer may be magically exchanged for some ;;; other buffer, permitting easy iteration through multiple buffers ;;; as a single sequence. This is meant to support Climacs' ;;; Group-facility, I'm not sure what else it could be used for. (in-package :drei-core) (defclass target-specification () ((%drei :reader drei-instance :initarg :drei-instance :initform (error "A Drei instance must be provided for a target specification"))) (:documentation "The base class for target specifications, objects that permit browsing through targets for various operations. `Target-specification' instances start off deactivated.")) (defgeneric activate-target-specification (target-specification) (:documentation "Cause the Drei instance associated with `target-specification' to switch to the \"current\" target of `target-specification', whatever that is. It is illegal to call any other target function on a `target-specification' object until it has been activated by this function, and it is illegal to call this function on an already activated `target-specification' instance.")) (defgeneric deactivate-target-specification (target-specification) (:documentation "Deactivate the `target-specification' instance, restoring whatever state the call to `activate-target-specification' modified. It is illegal to call `deactivate-target-specification' on a deactivated `target-specification' instance.")) (defgeneric subsequent-targets-p (target-specification) (:documentation "Return true if there are more targets to act on, that is, if the `next-target' function would not signal an error.")) (defgeneric preceding-targets-p (target-specification) (:documentation "Return true if there are targets to act on in sequence before the current target, that is, if the `previous-target' function would not signal an error.")) (defgeneric next-target (target-specification) (:documentation "Change to the next target specified by the target specification. Signals an error of type `no-more-targets' if `subsequent-targets-p' is false.")) (defgeneric previous-target (target-specification) (:documentation "Change to the previous target specified by the target specification. Signals an error of type `no-more-targets' if `preceding-targets-p' is false.")) (define-condition no-more-targets (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "No more targets available for iteration"))) (:documentation "Signal that there are no more targets available for iteration, either forward or backwards in the sequence of targets.")) (defclass current-buffer-target (target-specification) ((%buffer :accessor buffer)) (:documentation "A target specification class specifying just one buffer, the current buffer of the Drei instance at the time of object creation. This is mostly used as a dummy target specification to make target-aware commands behave \"normally\" when no particular targets are specified.")) (defmethod initialize-instance :after ((obj current-buffer-target) &rest initargs) (declare (ignore initargs)) (setf (buffer obj) (buffer (drei-instance obj)))) (defmethod activate-target-specification ((spec current-buffer-target)) ;; Noop. ) (defmethod deactivate-target-specification ((spec current-buffer-target)) ;; Noop. ) (defmethod subsequent-targets-p ((spec current-buffer-target)) nil) (defmethod preceding-targets-p ((spec current-buffer-target)) nil) (defmethod next-target ((spec current-buffer-target)) (error 'no-more-targets)) (defmethod previous-target ((spec current-buffer-target)) (error 'no-more-targets)) (defvar *default-target-creator* #'(lambda (drei) (make-instance 'current-buffer-target :drei-instance drei)) "A function of a single argument, the Drei instance, that creates a target specification object (or subtype thereof) that should be used for aquiring targets.") (defclass buffer-list-target-specification (target-specification) ((%buffers :initarg :buffers :initform '() :accessor buffers) (%buffer-count :accessor buffer-count) (%current-buffer-index :initform 0 :accessor current-buffer-index)) (:documentation "A target specification that has a provided list of existing buffers as its target.")) (defmethod initialize-instance :after ((obj buffer-list-target-specification) &rest initargs) (declare (ignore initargs)) (setf (buffer-count obj) (length (buffers obj))) ;; If the current buffer is in the list of buffers, we move it to ;; the head of the list, since it makes sense to make it the ;; starting point. (when (/= (length (setf (buffers obj) (remove (buffer (drei-instance obj)) (buffers obj)))) (buffer-count obj)) (push (buffer (drei-instance obj)) (buffers obj)))) (defmethod activate-target-specification ((spec buffer-list-target-specification)) (unless (or (null (buffers spec)) (eq (buffer (drei-instance spec)) (first (buffers spec)))) (setf (buffer (drei-instance spec)) (first (buffers spec))) (beginning-of-buffer (point (drei-instance spec))))) (defmethod deactivate-target-specification ((spec buffer-list-target-specification))) (defmethod subsequent-targets-p ((spec buffer-list-target-specification)) (/= (1+ (current-buffer-index spec)) (buffer-count spec))) (defmethod preceding-targets-p ((spec buffer-list-target-specification)) (plusp (current-buffer-index spec))) (defmethod next-target ((spec buffer-list-target-specification)) (if (subsequent-targets-p spec) (progn (setf (buffer (drei-instance spec)) (elt (buffers spec) (incf (current-buffer-index spec)))) (beginning-of-buffer (point (drei-instance spec)))) (error 'no-more-targets))) (defmethod previous-target ((spec buffer-list-target-specification)) (if (preceding-targets-p spec) (progn (setf (buffer (drei-instance spec)) (elt (buffers spec) (decf (current-buffer-index spec)))) (end-of-buffer (point (drei-instance spec)))) (error 'no-more-targets))) From thenriksen at common-lisp.net Fri Nov 16 09:28:47 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 16 Nov 2007 04:28:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071116092847.5487A113F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv31402 Modified Files: mcclim.asd Log Message: Added Drei "target" concept, facilitating search/replace-commands that act over multiple buffers (or "targets"). --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/09/30 21:12:50 1.61 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2007/11/16 09:28:47 1.62 @@ -299,6 +299,7 @@ (:file "core" :depends-on ("drei")) (:file "buffer-streams" :depends-on ("core")) (:file "rectangle" :depends-on ("core")) + (:file "targets" :depends-on ("core")) (:file "core-commands" :depends-on ("core" "rectangle" "drei-clim")) (:file "persistent-buffer" :pathname #.(make-pathname :directory '(:relative "Persistent") @@ -310,7 +311,7 @@ :depends-on ("packages" "buffer" "persistent-buffer" "undo")) (:file "misc-commands" :depends-on ("basic-commands")) (:file "unicode-commands" :depends-on ("core" "drei-clim")) - (:file "search-commands" :depends-on ("core" "drei-clim")) + (:file "search-commands" :depends-on ("core" "targets" "drei-clim")) (:file "lr-syntax" :depends-on ("fundamental-syntax" "core")) (:file "lisp-syntax" :depends-on ("lr-syntax" "motion" "core")) (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) From rstrandh at common-lisp.net Sat Nov 17 14:00:29 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 17 Nov 2007 09:00:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071117140029.A23533D064@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv9736 Added Files: esa.texi Log Message: Embryonic documentation. Feel free to add to it. --- /project/mcclim/cvsroot/mcclim/ESA/esa.texi 2007/11/17 14:00:29 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa.texi 2007/11/17 14:00:29 1.1 * Introduction ESA is a library that makes it easier to write Emacs-Style Applications on top of McCLIM. It supplies a command processor that is different from the one supplied by standard CLIM, making it practical to use multi-keystroke command invocation, and invocation of commands with no keyboard binding possible through M-x. ESA assumes that an application that displays a certain number of buffers in a certain number of windows, and that at all times, there is a current buffer that is being worked on. * Basic use of ESA ** Mixin classes For basic use of the ESA library, the application needs to supply it with certain functionality. The basic application document should be a class that inherits from the class esa-buffer:esa-buffer mixin. This class supplies functionality for associating the buffer with a file, to determine whether the buffer has been modified since last saved, and whether the buffer is read-only. Application panes should inherit from the class esa:esa-pane-mixin. Application frames should inherit from the class esa:esa-frame-mixin. This class supplies a slot that stores a list of the windows used by the application, and an accessor esa:windows that can be used by application code to return or to modify the list of windows used. Notice that the class definition for the application frame must explicitly inherit not only from esa-frame-mixin, but also from standard-application-frame, since the latter is automatically supplied only if the list of superclasses is empty. Applications should supply a method on the generic function esa:buffers which takes a single argument, the application frame. It should return a list of all the application documents (buffers) that the application is currently manipulating. Applications should also supply a method on the generic function esa:frame-current-buffer, which also take a single argument, the application frame. The method should return the current buffer, i.e. the buffer that is currently being manipulated by the user. This might be the buffer that is on display in the window with the current keyboard focus. This method is called by functions that require the current buffer, in particular in order to save the current buffer to file, or to toggle the read-only flag of the current buffer. ** The info pane ESA supplies a class esa:info-pane which is typically used to display something similar to the status line of Emacs. It supplies a slot that contains a main application pane. This slot can be initialized with the :initarg :master-pane and can be read using the reader master-pane. An application typically supplies a CLIM display-function for an info pane that displays some data about its master pane. ** The minibuffer pane ESA supplies a class esa:minibuffer-pane that is used to display messages to the user of the application, and also to acquire arguments to commands. Applications should make sure the application frame contains an instance of this class, or of a subclass of it. ** Command tables Typically, an application using the ESA library will need a number of CLIM command tables. ESA supplies a number of such command tables that the application can inherit from. esa:global-esa-table [command table] This command table contains a few basic commands that every application using the ESA library will need. esa:com-quit [command] This command quits the application by invoking the CLIM function FRAME-EXIT on the application frame. It is included in the global-esa-table, together with the standard key bindings C-x C-c. The global-esa-table also contains the keyboard binding M-x which invokes the command esa:com-extended-command. This command prompts the user for the name of a command in the minibuffer, and executes that command. esa:keyboard-macro-table [command table] This command table contains three commands, com-start-kbd-macro (C-x (), com-end-kbd-macro (C-x )) and com-call-last-kbd-macro (C-x e). Applications that want to use Emacs-style keyboard macros should include this table in the global application command table. * Using the ESA input/output functions From rstrandh at common-lisp.net Sun Nov 18 05:18:00 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sun, 18 Nov 2007 00:18:00 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071118051800.1F7DF16034@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv10124 Modified Files: esa.texi Log Message: A section about the i/o facility. --- /project/mcclim/cvsroot/mcclim/ESA/esa.texi 2007/11/17 14:00:29 1.1 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.texi 2007/11/18 05:17:59 1.2 @@ -95,5 +95,42 @@ * Using the ESA input/output functions +The ESA library provides facilities for loading a buffer from a file, +and saving a buffer to a file. The esa-io package contains symbols +related to this functionality. + +A command table, esa-io:esa-io-table contains a number of commands and +related key bindings related to input/output. Typically, an +application that needs such i/o would inherit from this command table +when creating its global command table. The commands that are +supplied by this table are com-find-file (C-x C-f), +com-find-file-read-only (C-x C-r), com-read-only (C-x C-q) which +toggle the read-only flag of the buffer, com-set-visited-file-name +(available as an extended command only) which prompts for a file name +to be associated with the current buffer, com-save-buffer (C-x C-s), +and com-write-buffer (C-x C-w). + +These commands handle prompting for file names, searching for existing +buffers with the file name given, Emacs-style file versioning, and +more. The only thing they need help from the application with is for +saving a buffer to a stream, and for creating a buffer from a stream. +For that, the ESA library calls the generic functions +esa-buffer:frame-save-buffer-to-stream and +esa-buffer:frame-make-buffer-from-stream respectively. Applications +that use the ESA i/o facility must provide methods on these generic +functions, specialized on the particular class of the application +frame. Applications should also provide a method on +esa-buffer:frame-make-new-buffer so that the ESA library can create a +new buffer whenever a non-existing file name is given. + +To implement the i/o functions, the ESA i/o facility calls the generic +functions esa-io:frame-find-file, esa-io:frame-find-file-read-only, +esa-io:frame-set-visited-file-name, esa-io:frame-save-buffer, and +esa-io:frame-write-buffer. Applications can override these methods, +or provide :before, :after, or :around methods on them in order to +customize their behavior. + +* Help facility + From thenriksen at common-lisp.net Mon Nov 19 20:28:43 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 15:28:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071119202843.191EA5B056@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv7043/ESA Modified Files: packages.lisp esa.lisp Log Message: Change the use of global variables in Drei to functions that query a single global variable (*drei-instance*). At the same time, change a few things in ESA to make Dreis use of it less hacky. --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/08/13 21:56:04 1.3 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/11/19 20:28:42 1.4 @@ -45,8 +45,9 @@ (defpackage :esa (:use :clim-lisp :clim :esa-utils) - (:export #:buffers #:frame-current-buffer #:current-buffer #:*current-buffer* - #:windows #:frame-current-window #:current-window #:*current-window* + (:export #:*esa-instance* + #:buffers #:esa-current-buffer #:current-buffer + #:windows #:esa-current-window #:current-window #:*previous-command* #:*minibuffer* #:minibuffer #:minibuffer-pane #:display-message #:with-minibuffer-stream --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/09/30 22:03:54 1.10 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2007/11/19 20:28:43 1.11 @@ -2,6 +2,8 @@ ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh at labri.fr) +;;; (c) copyright 2006-2007 by +;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -26,41 +28,38 @@ ;;; ;;; Querying ESAs. -(defgeneric buffers (application-frame) - (:documentation "Return a list of all the buffers of the application.")) +(defvar *esa-instance* nil + "This symbol should be bound to an ESA instance, though any +object will do, provided the proper methods are defined. It will +be used as the argument to the various \"query\" functions +defined by ESA. For the vast majority of ESAs, `*esa-instance*' +will probably have the same value as `*application-frame*'.") -(defgeneric frame-current-buffer (application-frame) - (:documentation "Return the current buffer of APPLICATION-FRAME.") - (:method ((frame application-frame)) - nil)) +(defgeneric buffers (esa) + (:documentation "Return a list of all the buffers of the application.")) -(defvar *current-buffer* nil - "When a command is being executed, the current buffer.") +(defgeneric esa-current-buffer (esa) + (:documentation "Return the current buffer of APPLICATION-FRAME.")) (defun current-buffer () - "Return the current buffer of `*application-frame*'." - (frame-current-buffer *application-frame*)) + "Return the currently active buffer of the running ESA." + (esa-current-buffer *esa-instance*)) -(defgeneric windows (application-frame) - (:documentation "Return a list of all the windows of the application.") - (:method ((application-frame application-frame)) +(defgeneric windows (esa) + (:documentation "Return a list of all the windows of the ESA.") + (:method ((esa application-frame)) '())) -(defgeneric frame-current-window (application-frame) - (:documentation "Return the current window of APPLICATION-FRAME.") - (:method ((frame application-frame)) - (first (windows frame)))) - -(defvar *current-window* nil - "When a command is being executed, the current window.") +(defgeneric esa-current-window (esa) + (:documentation "Return the current window of ESA.")) (defun current-window () - "Return the current window of `*application-frame*'." - (frame-current-window *application-frame*)) + "Return the currently active window of the running ESA instance." + (esa-current-window *esa-instance*)) (defvar *previous-command* nil "When a command is being executed, the command previously -executed by the current frame.") +executed by the application.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -766,6 +765,12 @@ (defclass esa-frame-mixin (command-processor) ((windows :accessor windows))) +(defmethod esa-current-buffer ((esa esa-frame-mixin)) + (first (buffers esa))) + +(defmethod esa-current-window ((esa esa-frame-mixin)) + (first (windows esa))) + (defmethod command-table ((frame esa-frame-mixin)) (find-applicable-command-table frame)) @@ -795,7 +800,7 @@ ;; FIXME: I'm not sure that we want to do this for commands sent ;; from other threads; we almost certainly don't want to do it twice ;; in such cases... - (setf (previous-command (frame-current-window frame)) command)) + (setf (previous-command (esa-current-window frame)) command)) (defmethod execute-frame-command :around ((frame esa-frame-mixin) command) (call-next-method) @@ -850,16 +855,15 @@ (*partial-command-parser* ,partial-command-parser) (*extended-command-prompt* ,prompt) (*pointer-documentation-output* - (frame-pointer-documentation-output ,frame))) + (frame-pointer-documentation-output ,frame)) + (*esa-instance* ,frame)) (unless (eq (frame-state ,frame) :enabled) (enable-frame ,frame)) (redisplay-frame-panes ,frame :force-p t) (loop do (restart-case (handler-case - (let* ((*current-window* (frame-current-window ,frame)) - (*current-buffer* (frame-current-buffer ,frame)) - (*command-processor* ,frame) + (let* ((*command-processor* ,frame) (command-table (find-applicable-command-table ,frame)) , at bindings) ;; for presentation-to-command-translators, From thenriksen at common-lisp.net Mon Nov 19 20:28:44 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 15:28:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071119202844.7FEC8650DB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7043 Modified Files: package.lisp Log Message: Change the use of global variables in Drei to functions that query a single global variable (*drei-instance*). At the same time, change a few things in ESA to make Dreis use of it less hacky. --- /project/mcclim/cvsroot/mcclim/package.lisp 2007/02/07 12:44:17 1.62 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2007/11/19 20:28:44 1.63 @@ -2072,6 +2072,7 @@ (defpackage :goatee (:use :clim :clim-lisp :clim-sys) (:import-from :clim-internals #:letf) + (:shadow #:point) (:export #:execute-gesture-command #:goatee-input-editing-mixin From thenriksen at common-lisp.net Mon Nov 19 20:32:23 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 15:32:23 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071119203223.E153237014@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv7575/ESA Modified Files: esa.texi Log Message: Texinfoficated ESA's embryonic documentation (which I really think should be in mcclim/Doc, btw). The indexes don't work yet, for some esoteric Texinfo reason I do not understand. --- /project/mcclim/cvsroot/mcclim/ESA/esa.texi 2007/11/18 05:17:59 1.2 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.texi 2007/11/19 20:32:23 1.3 @@ -1,4 +1,80 @@ -* Introduction +% @c -*- Coding: utf-8; Mode: Texinfo -*- +% @c Note that Texinfo does not support UTF-8. Please do not use literal +% @c UTF-8 characters in this document. +\input texinfo + + at setfilename esa + at settitle ESA User's Manual + + at copying +Copyright @copyright{} 2004,2005,2006,2007 the ESA hackers. + at end copying + + at dircategory Common Lisp + at direntry +* ESA User's Manual: (esa). A library for creating Emacs-Style Applications. + at end direntry + + at titlepage + at title{ESA User's Manual} + + at page + at vskip 0pt plus 1filll + at insertcopying + + at end titlepage + + at iftex + at contents + at end iftex + + at macro glossentry{ENTRY} + at b{\ENTRY\} + at cindex \ENTRY\ + at end macro + + at macro func{FUN} + at b{\FUN\} + at end macro + + at macro fmacro{MACRO} + at func{\MACRO\} + at end macro + + at macro genfun{FUN} + at func{\FUN\} + at end macro + + at alias gloss = i + at alias func = code + at alias class = code + at alias package = code + at alias gadget = code + at alias pane = code + at alias methcomp = t + at alias slot = code + at alias longref = t + at alias cl = code + at alias initarg = code + + at ifnottex + at node Top + at top McCLIM User's Manual + at insertcopying + at end ifnottex + + at menu +* Introduction:: +* Using the ESA input/output functions:: + +Index +* Concept Index:: +* Variable Index:: +* Function And Macro Index:: + at end menu + + at node Introduction + at chapter Introduction ESA is a library that makes it easier to write Emacs-Style Applications on top of McCLIM. It supplies a command processor that @@ -10,32 +86,43 @@ buffers in a certain number of windows, and that at all times, there is a current buffer that is being worked on. -* Basic use of ESA - -** Mixin classes + at node Basic use of ESA + at chapter Basic use of ESA -For basic use of the ESA library, the application needs to supply -it with certain functionality. The basic application document should -be a class that inherits from the class esa-buffer:esa-buffer mixin. + at menu +* Mixin classes:: +* The info pane:: +* The minibuffer pane:: +* Command tables:: + at end menu + + at node Mixin classes + at section Mixin classes + at cindex mixin classes + +For basic use of the ESA library, the application needs to supply it +with certain functionality. The basic application document should be a +class that inherits from the class @class{esa-buffer:esa-buffer} mixin. This class supplies functionality for associating the buffer with a file, to determine whether the buffer has been modified since last -saved, and whether the buffer is read-only. +saved, and whether the buffer is read-only. -Application panes should inherit from the class esa:esa-pane-mixin. +Application panes should inherit from the class + at class{esa:esa-pane-mixin}. -Application frames should inherit from the class esa:esa-frame-mixin. -This class supplies a slot that stores a list of the windows used by -the application, and an accessor esa:windows that can be used by -application code to return or to modify the list of windows used. -Notice that the class definition for the application frame must -explicitly inherit not only from esa-frame-mixin, but also from -standard-application-frame, since the latter is automatically supplied -only if the list of superclasses is empty. +Application frames should inherit from the class + at class{esa:esa-frame-mixin}. This class supplies a slot that stores a +list of the windows used by the application, and an accessor esa:windows +that can be used by application code to return or to modify the list of +windows used. Notice that the class definition for the application +frame must explicitly inherit not only from @class{esa-frame-mixin}, but +also from @class{standard-application-frame}, since the latter is +automatically supplied only if the list of superclasses is empty. Applications should supply a method on the generic function -esa:buffers which takes a single argument, the application frame. It -should return a list of all the application documents (buffers) that -the application is currently manipulating. + at cl{esa:buffers} which takes a single argument, the application frame. +It should return a list of all the application documents (buffers) that +the application is currently manipulating. Applications should also supply a method on the generic function esa:frame-current-buffer, which also take a single argument, the @@ -46,7 +133,9 @@ current buffer, in particular in order to save the current buffer to file, or to toggle the read-only flag of the current buffer. -** The info pane + at node The info pane + at section The info pane + at cindex info pane ESA supplies a class esa:info-pane which is typically used to display something similar to the status line of Emacs. It supplies a slot @@ -56,44 +145,54 @@ display-function for an info pane that displays some data about its master pane. -** The minibuffer pane + at node The minibuffer pane + at section The minibuffer pane + at cindex minibuffer pane ESA supplies a class esa:minibuffer-pane that is used to display messages to the user of the application, and also to acquire arguments to commands. Applications should make sure the application frame contains an instance of this class, or of a subclass of it. -** Command tables + at node Command tables + at section Command tables + at cindex command tables Typically, an application using the ESA library will need a number of CLIM command tables. ESA supplies a number of such command tables that the application can inherit from. - esa:global-esa-table [command table] - + at deftp {Command Table} esa:global-esa-table This command table contains a few basic commands that every application using the ESA library will need. + at end deftp - esa:com-quit [command] + at deffn {Command} esa:com-quit This command quits the application by invoking the CLIM function FRAME-EXIT on the application frame. It is included in the global-esa-table, together with the standard key bindings C-x C-c. + at end deffn -The global-esa-table also contains the keyboard binding M-x which -invokes the command esa:com-extended-command. This command prompts -the user for the name of a command in the minibuffer, and executes -that command. - - esa:keyboard-macro-table [command table] +The @class{global-esa-table} also contains the keyboard binding + at kbd{M-x} which invokes the command @cl{esa:com-extended-command}. This +command prompts the user for the name of a command in the minibuffer, +and executes that command. + at deftp {Command Table} esa:keyboard-macro-table This command table contains three commands, com-start-kbd-macro (C-x (), com-end-kbd-macro (C-x )) and com-call-last-kbd-macro (C-x e). Applications that want to use Emacs-style keyboard macros should include this table in the global application command table. + at end deftp + + at node Using the ESA input/output functions + at chapter Using the ESA input/output functions + at cindex IO + at cindex input + at cindex output -* Using the ESA input/output functions The ESA library provides facilities for loading a buffer from a file, and saving a buffer to a file. The esa-io package contains symbols @@ -130,7 +229,23 @@ or provide :before, :after, or :around methods on them in order to customize their behavior. -* Help facility + at node Help facility + at chapter Help facility + + at node Concept Index + at unnumbered Concept Index + + at printindex cp + + at node Variable Index + at unnumbered Variable Index + + at printindex vr + + at node Function And Macro Index + at unnumbered Function And Macro Index + at printindex fn + at bye From thenriksen at common-lisp.net Mon Nov 19 20:34:10 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 15:34:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20071119203410.98407450CB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv7676/ESA Modified Files: packages.lisp Log Message: ESA no longer defines a `macrorecord-processed-gestures-mixin' class, so removed the symbol export from the package. --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/11/19 20:28:42 1.4 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2007/11/19 20:34:10 1.5 @@ -56,7 +56,7 @@ #:esa-frame-mixin #:recordingp #:executingp #:*esa-abort-gestures* #:*numeric-argument-p* #:*current-gesture* #:*command-processor* #:unbound-gesture-sequence #:gestures - #:command-processor #:instant-macro-execution-mixin #:macrorecord-processed-gestures-mixin + #:command-processor #:instant-macro-execution-mixin #:asynchronous-command-processor #:command-loop-command-processor #:overriding-handler #:directly-processing-p #:process-gesture #:process-gestures-or-command #:*extended-command-prompt* From thenriksen at common-lisp.net Mon Nov 19 20:37:18 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 15:37:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071119203718.03D5548151@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7891/Drei Modified Files: packages.lisp Log Message: Removed DREI-LISP-SYNTAX package symbol exports for symbols not actually used for anything, and added export for `invalid-lambda-list'. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/11/19 20:28:43 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2007/11/19 20:37:18 1.18 @@ -508,7 +508,7 @@ #:destructuring-parameter #:required-parameter #:destructuring-required-parameter #:named-required-parameter #:optional-parameter #:destructuring-optional-parameter #:named-optional-parameter - #:keyword-parameter #:destructuring-keyword-parameter #:named-keyword-parameter + #:keyword-parameter #:destructuring-keyword-parameter #:rest-parameter #:body-parameter @@ -522,7 +522,7 @@ ;; Conditions. #:form-conversion-error - #:invalid-arglist) + #:invalid-lambda-list) (:shadow clim:form) (:documentation "Implementation of the syntax module used for editing Common Lisp code.")) From thenriksen at common-lisp.net Mon Nov 19 20:38:10 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 15:38:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20071119203810.74F5F48152@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv7960/Doc Modified Files: drei.texi Log Message: Added mention of new Drei functions to the documentation. --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/08/20 17:52:44 1.8 +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2007/11/19 20:38:10 1.9 @@ -75,52 +75,35 @@ malfunction. @menu -* Special Variables:: +* Special Variables:: +* Access Functions:: @end menu @node Special Variables @subsection Special Variables -Drei commands are meant to work by using the values of a number of -special variables bound by Drei during its pseudo command loop. Here is -a list of them: - - at defvar *current-window* - at vindex *current-window* -Somewhat counter-intuitively, the Drei instance. Not necessarily the -same as the editor pane. - at end defvar - at defvar *current-buffer* - at vindex *current-buffer* -The buffer of the Drei instance the command is being executed for. - at end defvar - at defvar *current-mark* - at vindex *current-mark* -The mark of the Drei instance. - at end defvar - at defvar *current-point* - at vindex *current-point* -The point of the Drei instance. - at end defvar - at defvar *current-syntax* - at vindex *current-syntax* -The syntax of @cl{*current-buffer*}. - at end defvar - at defvar *kill-ring* - at vindex *kill-ring* -The kill-ring object of the Drei instance. - at end defvar - at defvar *minibuffer* - at vindex *minibuffer* -The minibuffer of the Drei instance, which is where commands should -print information and other interesting things (using - at cl{display-message} or @cl{with-minibuffer-stream}). This may be - at cl{NIL} if no minibuffer is associated with the Drei instance. - at end defvar - at defvar *previous-command* - at vindex *previous-command* -The previous CLIM command that was executed by the Drei instance. - at end defvar +Drei uses a number of special variables to provide access to data +structures. These are described below. + + at include var-drei-star-drei-instance-star.texi + at include var-drei-kill-ring-star-kill-ring-star.texi + +Additionally, a number of ESA special variables are used in Drei. + + at include var-esa-star-minibuffer-star.texi + at include var-esa-star-previous-command-star.texi + + at node Access Functions + at subsection Access Functions + +The special variables essentially provide all that is needed to access +all parts of the Drei state, but for convenience, a number of utility +functions providing access to commonly used objects have been defined. + + at include fun-esa-current-buffer.texi + at include fun-drei-point.texi + at include fun-drei-mark.texi + at include fun-drei-current-syntax.texi @node External API @section External API @@ -1189,13 +1172,12 @@ (define-command (com-repeat-word :name t :command-table editing-table) () - (let ((mark (clone-mark *current-point*))) - (backward-word mark *current-syntax* 1) - (insert-sequence mark (region-to-sequence mark *current-point*)))) + (let ((mark (clone-mark (point))) + (backward-word mark (current-syntax 1) + (insert-sequence mark (region-to-sequence mark (point)))) @end lisp -For @cl{*current-point*} and @cl{*current-syntax*}, see @ref{Special -Variables}. +For @cl{(point)} and @cl{(current-syntax)}, see @ref{Access Functions}. This command facilitates the single repeat of a word, but that's it. This is not very useful - instead, we would like a command that @@ -1208,9 +1190,9 @@ (define-command (com-repeat-word :name t :command-table editing-table) ((count 'integer :prompt "Number of repeats")) - (let ((mark (clone-mark *current-point*))) - (backward-word mark *current-syntax* 1) - (let ((word (region-to-sequence mark *current-point*))) + (let ((mark (clone-mark (point))) + (backward-word mark (current-syntax 1) + (let ((word (region-to-sequence mark (point))) (dotimes (i count) (insert-sequence mark word))))) @end lisp From thenriksen at common-lisp.net Mon Nov 19 21:02:58 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 16:02:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071119210258.2A3521E0A2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv13661 Modified Files: presentations.lisp Log Message: Changed the `funcall-presentation-generic-function' macro to cause fewer compiler warnings. It still yells about "unknown keyword arguments" because, say, the accept generic function isn't strictly specified to take, say, :default and :default-type arguments. --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2007/01/10 11:19:01 1.79 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2007/11/19 21:02:58 1.80 @@ -1156,15 +1156,24 @@ (let ((gf (gethash name *presentation-gf-table*))) (unless gf (error "~S is not a presentation generic function" name)) - (let* ((rebound-args (mapcar (lambda (arg) - `(,(gensym "ARG") ,arg)) - args)) - (gf-name (generic-function-name gf)) - (type-spec-var (car (nth (1- (type-arg-position gf)) rebound-args)))) + (let* ((rebound-args (loop for arg in args + unless (symbolp arg) + collect (list (gensym "ARG")))) + (gf-name (generic-function-name gf)) + (type-spec-var (car (nth (1- (type-arg-position gf)) rebound-args)))) `(let ,rebound-args - (,gf-name (prototype-or-error (presentation-type-name - ,type-spec-var)) - ,@(mapcar #'car rebound-args)))))) + (,gf-name (prototype-or-error (presentation-type-name + ,type-spec-var)) + ,@(mapcar #'(lambda (arg) + ;; Order of evaluation doesn't matter + ;; for symbols, and this shuts up + ;; warnings about arguments in a + ;; keyword position not being + ;; constant. By the way, why do we + ;; care about order of evaluation + ;; here? -trh + (or (first (find arg rebound-args :key #'second)) + arg)) args)))))) (defmacro apply-presentation-generic-function (name &rest args) (let ((gf (gethash name *presentation-gf-table*))) From thenriksen at common-lisp.net Mon Nov 19 21:10:41 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 16:10:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071119211041.0173B32027@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14605 Modified Files: presentation-defs.lisp Log Message: `accept-from-string' is still WIP, but it should cause fewer compiler warnings now. The remaining one is actually out of our control, in fact, an SBCL hacker would be welcome to fix it, if that is possible. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/02/10 21:32:22 1.71 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/11/19 21:10:40 1.72 @@ -1121,11 +1121,11 @@ &key view (default nil defaultp) (default-type nil default-type-p) - activation-gestures + (activation-gestures nil activationsp) (additional-activation-gestures nil additional-activations-p) - delimiter-gestures + (delimiter-gestures nil delimitersp) (additional-delimiter-gestures nil additional-delimiters-p) @@ -1141,8 +1141,7 @@ additional-delimiter-gestures delimiter-gestures) :override delimitersp))) - (when (or (zerop (- end start)) - (let ((maybe-end)))) + (when (zerop (- end start)) (if defaultp (return-from accept-from-string (values default (if default-type-p @@ -1153,7 +1152,7 @@ (let ((index 0)) (multiple-value-bind (val ptype) (with-input-from-string (stream string :start start :end end - :index index) + :index index) (with-keywords-removed (args (:start :end)) (apply #'stream-accept stream type :view +textual-view+ args))) (values val ptype index)))) From thenriksen at common-lisp.net Mon Nov 19 21:14:01 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 16:14:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071119211401.C1EB537011@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv14875 Modified Files: presentations.lisp Log Message: Removed useless T clause in `fake-params-arg'. Two other clauses already handle atoms and conses respectively, there are no other kinds of objects. --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2007/11/19 21:02:58 1.80 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2007/11/19 21:14:01 1.81 @@ -240,9 +240,7 @@ (let ((var (car lambda-var))) (do-arg (if (and (eq state '&key) (consp var)) (car var) - var)))) - (t (list (fake-params-args lambda-var)))))))) - + var))))))))) ;;; Yet another variation on a theme... From thenriksen at common-lisp.net Mon Nov 19 22:04:29 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 17:04:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071119220429.A114A6200B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv23869 Modified Files: presentations.lisp Log Message: I must have been asleep, my `funcall-presentation-generic-function' fix broke the function completely. Unbroke it now. --- /project/mcclim/cvsroot/mcclim/presentations.lisp 2007/11/19 21:14:01 1.81 +++ /project/mcclim/cvsroot/mcclim/presentations.lisp 2007/11/19 22:04:29 1.82 @@ -1156,12 +1156,13 @@ (error "~S is not a presentation generic function" name)) (let* ((rebound-args (loop for arg in args unless (symbolp arg) - collect (list (gensym "ARG")))) + collect (list (gensym "ARG") arg))) (gf-name (generic-function-name gf)) - (type-spec-var (car (nth (1- (type-arg-position gf)) rebound-args)))) + (type-spec-var (nth (1- (type-arg-position gf)) args))) `(let ,rebound-args (,gf-name (prototype-or-error (presentation-type-name - ,type-spec-var)) + ,(or (first (find type-spec-var rebound-args :key #'second)) + type-spec-var))) ,@(mapcar #'(lambda (arg) ;; Order of evaluation doesn't matter ;; for symbols, and this shuts up From thenriksen at common-lisp.net Mon Nov 19 22:14:05 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 17:14:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071119221405.7B4794904E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25584 Modified Files: presentation-defs.lisp Log Message: Changed `highlight-current-presentation' to use its provided frame and input-context, instead of `*application-frame*' and `*input-context*'. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/11/19 21:10:40 1.72 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2007/11/19 22:14:05 1.73 @@ -794,10 +794,10 @@ (port *application-frame*))))) (when event - (frame-input-context-track-pointer *application-frame* - *input-context* - (event-sheet event) - event)))) + (frame-input-context-track-pointer frame + input-context + (event-sheet event) + event)))) (defmacro with-input-context ((type &key override) (&optional (object-var (gensym)) From thenriksen at common-lisp.net Mon Nov 19 22:16:47 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 17:16:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071119221647.7E7194D048@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv25861/Drei Modified Files: core-commands.lisp core.lisp drei-redisplay.lisp drei.lisp lisp-syntax-commands.lisp search-commands.lisp Log Message: As it turns out, a lot of Drei code still used (current-window), which is now actually the current window (imagine that), and not the Drei instance. Fixed. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/11/19 20:28:43 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2007/11/19 22:16:47 1.6 @@ -39,7 +39,7 @@ will replace the object after the point. When overwrite is off (the default), objects are inserted at point. In both cases point is positioned after the new object." - (with-slots (overwrite-mode) (current-window) + (with-slots (overwrite-mode) *drei-instance* (setf overwrite-mode (not overwrite-mode)))) (set-key 'com-overwrite-mode @@ -48,7 +48,7 @@ (defun set-fill-column (column) (if (> column 1) - (setf (auto-fill-column (current-window)) column) + (setf (auto-fill-column *drei-instance*) column) (progn (beep) (display-message "Set Fill Column requires an explicit argument.")))) (define-command (com-set-fill-column :name t :command-table fill-table) @@ -126,29 +126,26 @@ :name t :command-table ,command-table) ((count 'integer :prompt ,(concat "Number of " plural))) - ,(if (not (null move-point)) - (concat "Place point and mark around the current " noun ". + ,(if (not (null move-point)) + (concat "Place point and mark around the current " noun ". Put point at the beginning of the current " noun ", and mark at the end. With a positive numeric argument, put mark that many " plural " forward. With a negative numeric argument, put point at the end of the current " noun " and mark that many " plural " backward. Successive invocations extend the selection.") - (concat "Place mark at the next " noun " end. + (concat "Place mark at the next " noun " end. With a positive numeric argument, place mark at the end of that many " plural " forward. With a negative numeric argument, place mark at the beginning of that many " plural " backward. Successive invocations extend the selection.")) - (let* ((pane (current-window)) - (point (point pane)) - (mark (mark pane))) - (unless (eq (command-name *previous-command*) 'com-mark-word) - (setf (offset mark) (offset point)) - ,(when (not (null move-point)) - `(if (plusp count) - (,backward point (syntax (buffer pane))) - (,forward point (syntax (buffer pane)))))) - (,forward mark (syntax (buffer pane)) count)))))) + (unless (eq (command-name *previous-command*) 'com-mark-word) + (setf (offset (mark)) (offset (point))) + ,(when (not (null move-point)) + `(if (plusp count) + (,backward (point) (current-syntax)) + (,forward (point) (current-syntax))))) + (,forward (mark) (current-syntax) (current-buffer) count))))) (define-mark-unit-command word marking-table) (define-mark-unit-command expression marking-table) @@ -224,7 +221,7 @@ (tab-space-count (view *drei-instance*)))) (define-command (com-indent-line :name t :command-table indent-table) () - (indent-current-line (current-window) (point))) + (indent-current-line *drei-instance* (point))) (set-key 'com-indent-line 'indent-table @@ -239,7 +236,7 @@ (insert-object (point) #\Newline) (update-syntax (current-buffer) (syntax (current-buffer))) - (indent-current-line (current-window) (point))) + (indent-current-line *drei-instance* (point))) (set-key 'com-newline-and-indent 'indent-table @@ -248,7 +245,7 @@ (define-command (com-indent-region :name t :command-table indent-table) () "Indent every line of the current region as specified by the syntax for the buffer." - (indent-region (current-window) (point) (mark))) + (indent-region *drei-instance* (point) (mark))) (define-command (com-delete-indentation :name t :command-table indent-table) () "Join current line to previous non-blank line. @@ -264,8 +261,8 @@ '((#\^ :shift :meta))) (define-command (com-auto-fill-mode :name t :command-table fill-table) () - (setf (auto-fill-mode (current-window)) - (not (auto-fill-mode (current-window))))) + (setf (auto-fill-mode *drei-instance*) + (not (auto-fill-mode *drei-instance*)))) (define-command (com-fill-paragraph :name t :command-table fill-table) () (let* ((syntax (syntax (current-buffer))) @@ -301,7 +298,7 @@ '((:home :control))) (define-command (com-page-down :name t :command-table movement-table) () - (page-down (current-window))) + (page-down *drei-instance*)) (set-key 'com-page-down 'movement-table @@ -312,7 +309,7 @@ '((:next))) (define-command (com-page-up :name t :command-table movement-table) () - (page-up (current-window))) + (page-up *drei-instance*)) (set-key 'com-page-up 'movement-table @@ -542,7 +539,7 @@ (let* ((syntax (syntax (current-buffer)))) (with-accessors ((original-prefix original-prefix) (prefix-start-offset prefix-start-offset) - (dabbrev-expansion-mark dabbrev-expansion-mark)) (current-window) + (dabbrev-expansion-mark dabbrev-expansion-mark)) *drei-instance* (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark) (setf (offset dabbrev-expansion-mark) (offset (point))) @@ -634,8 +631,8 @@ (define-command (com-visible-region :name t :command-table marking-table) () "Toggle the visibility of the region in the current pane." - (setf (region-visible-p (current-window)) - (not (region-visible-p (current-window))))) + (setf (region-visible-p *drei-instance*) + (not (region-visible-p *drei-instance*)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/11/19 20:28:43 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2007/11/19 22:16:47 1.7 @@ -18,22 +18,18 @@ ;;; Misc stuff (defun possibly-fill-line () - (let* ((pane (current-window)) - (buffer (buffer pane))) - (when (auto-fill-mode pane) - (let* ((fill-column (auto-fill-column pane)) - (point (point pane)) - (offset (offset point)) - (tab-width (tab-space-count (stream-default-view pane))) - (syntax (syntax buffer))) - (when (>= (buffer-display-column buffer offset tab-width) - (1- fill-column)) - (fill-line point - (lambda (mark) - (syntax-line-indentation mark tab-width syntax)) - fill-column - tab-width - (syntax buffer))))))) + (when (auto-fill-mode *drei-instance*) + (let* ((fill-column (auto-fill-column *drei-instance*)) + (offset (offset (point))) + (tab-width (tab-space-count (view *drei-instance*)))) + (when (>= (buffer-display-column (current-buffer) offset tab-width) + (1- fill-column)) + (fill-line (point) + (lambda (mark) + (syntax-line-indentation mark tab-width (current-syntax))) + fill-column + tab-width + (current-syntax)))))) (defun back-to-indentation (mark syntax) (beginning-of-line mark) @@ -42,17 +38,16 @@ do (forward-object mark))) (defun insert-character (char) - (let* ((window (current-window)) - (point (point window))) - (unless (constituentp char) - (possibly-expand-abbrev point)) - (when (whitespacep (syntax (buffer window)) char) - (possibly-fill-line)) - (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point))) - (progn - (delete-range point) - (insert-object point char)) - (insert-object point char)))) + (unless (constituentp char) + (possibly-expand-abbrev (point))) + (when (whitespacep (syntax (current-buffer)) char) + (possibly-fill-line)) + (if (and (slot-value *drei-instance* 'overwrite-mode) + (not (end-of-line-p (point)))) + (progn + (delete-range (point)) + (insert-object (point) char)) + (insert-object (point) char))) (defun delete-horizontal-space (mark syntax &optional (backward-only-p nil)) (let ((mark2 (clone-mark mark))) @@ -65,9 +60,9 @@ do (forward-object mark2))) (delete-region mark mark2))) -(defun indent-current-line (pane point) - (let* ((buffer (buffer pane)) - (view (stream-default-view pane)) +(defun indent-current-line (drei point) + (let* ((buffer (buffer drei)) + (view (view drei)) (tab-space-count (tab-space-count view)) (indentation (syntax-line-indentation point tab-space-count @@ -164,11 +159,13 @@ ;;; ;;; Indentation -(defun indent-region (pane mark1 mark2) - "Indent all lines in the region delimited by `mark1' and `mark2' - according to the rules of the active syntax in `pane'." - (let* ((buffer (buffer pane)) - (view (clim:stream-default-view pane)) +(defun indent-region (drei mark1 mark2) + "Indent all lines in the region delimited by `mark1' and +`mark2' according to the rules of the active syntax in +`drei'. `Mark1' and `mark2' will not be modified by this +function." + (let* ((buffer (buffer drei)) + (view (view drei)) (tab-space-count (tab-space-count view)) (tab-width (and (indent-tabs-mode buffer) tab-space-count)) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/08/24 13:04:40 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2007/11/19 22:16:47 1.9 @@ -396,15 +396,15 @@ (reposition-pane pane)))) (adjust-pane-bot pane)) -(defun page-down (pane) - (with-slots (top bot) pane +(defun page-down (drei) + (with-slots (top bot) drei (when (mark> (size (buffer bot)) bot) (setf (offset top) (offset bot)) (beginning-of-line top) - (setf (offset (point pane)) (offset top))))) + (setf (offset (point drei)) (offset top))))) -(defun page-up (pane) - (with-slots (top bot) pane +(defun page-up (drei) + (with-slots (top bot) drei (when (> (offset top) 0) (let ((nb-lines-in-region (number-of-lines-in-region top bot))) (setf (offset bot) (offset top)) @@ -413,8 +413,8 @@ while (> (offset top) 0) do (decf (offset top)) (beginning-of-line top)) - (setf (offset (point pane)) (offset bot)) - (beginning-of-line (point pane)))))) + (setf (offset (point drei)) (offset bot)) + (beginning-of-line (point drei)))))) (defgeneric fix-pane-viewport (pane)) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/11/19 20:28:43 1.17 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/11/19 22:16:47 1.18 @@ -538,14 +538,14 @@ "Prompt for a command name and arguments, then run it." (let ((item (handler-case (accept - `(command :command-table ,(command-table (current-window))) + `(command :command-table ,(command-table *drei-instance*)) ;; this gets erased immediately anyway :prompt "" :prompt-mode :raw) ((or command-not-accessible command-not-present) () (beep) (display-message "No such command") (return-from com-drei-extended-command nil))))) - (execute-drei-command (current-window) item))) + (execute-drei-command *drei-instance* item))) (set-key 'com-drei-extended-command 'exclusive-gadget-table @@ -562,12 +562,12 @@ "This method allows users of Drei to extend syntaxes with new, app-specific commands, as long as they inherit from a Drei class and specialise a method for it." - (additional-command-tables (current-window) command-table)) + (additional-command-tables *drei-instance* command-table)) (defmethod command-table-inherit-from ((table drei-command-table)) (let ((syntax-table (command-table (current-syntax)))) (append `(,syntax-table) - (additional-command-tables (current-window) table) + (additional-command-tables *drei-instance* table) (when (use-editor-commands-p syntax-table) '(editor-table))))) @@ -760,21 +760,21 @@ ;; at, for example, the buffer level, after all. `(handler-case (progn , at body) (user-condition-mixin (c) - (handle-drei-condition (current-window) c)) + (handle-drei-condition *drei-instance* c)) (offset-before-beginning (c) - (handle-drei-condition (current-window) c)) + (handle-drei-condition *drei-instance* c)) (offset-after-end (c) - (handle-drei-condition (current-window) c)) + (handle-drei-condition *drei-instance* c)) (motion-before-beginning (c) - (handle-drei-condition (current-window) c)) + (handle-drei-condition *drei-instance* c)) (motion-after-end (c) - (handle-drei-condition (current-window) c)) + (handle-drei-condition *drei-instance* c)) (no-expression (c) - (handle-drei-condition (current-window) c)) + (handle-drei-condition *drei-instance* c)) (no-such-operation (c) - (handle-drei-condition (current-window) c)) + (handle-drei-condition *drei-instance* c)) (buffer-read-only (c) - (handle-drei-condition (current-window) c)))) + (handle-drei-condition *drei-instance* c)))) (defmacro with-bound-drei-special-variables ((drei-instance &key (kill-ring nil kill-ring-p) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/11/19 20:28:43 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/11/19 22:16:47 1.9 @@ -55,50 +55,40 @@ () "Fill paragraph at point. Will have no effect unless there is a string at point." - (let* ((pane (current-window)) - (buffer (buffer pane)) - (implementation (implementation buffer)) - (syntax (syntax buffer)) - (token (form-around syntax (offset (point pane)))) - (fill-column (auto-fill-column pane)) - (tab-width (tab-space-count (stream-default-view pane)))) + (let* ((buffer-implementation (implementation (current-buffer))) + (token (form-around (current-syntax) (offset (point)))) + (fill-column (auto-fill-column *drei-instance*)) + (tab-width (tab-space-count (view *drei-instance*)))) (when (form-string-p token) (with-accessors ((offset1 start-offset) (offset2 end-offset)) token (fill-region (make-instance 'standard-right-sticky-mark - :buffer implementation + :buffer buffer-implementation :offset offset1) (make-instance 'standard-right-sticky-mark - :buffer implementation + :buffer buffer-implementation :offset offset2) #'(lambda (mark) - (syntax-line-indentation mark tab-width syntax)) + (syntax-line-indentation (point) tab-width (current-syntax))) fill-column tab-width - syntax + (current-syntax) t))))) (define-command (com-indent-expression :name t :command-table lisp-table) ((count 'integer :prompt "Number of expressions")) - (let* ((pane (current-window)) - (point (point pane)) - (mark (clone-mark point)) - (syntax (syntax (buffer pane)))) + (let ((mark (point))) (if (plusp count) - (loop repeat count do (forward-expression mark syntax)) - (loop repeat (- count) do (backward-expression mark syntax))) - (indent-region pane (clone-mark point) mark))) + (loop repeat count do (forward-expression mark (current-syntax))) + (loop repeat (- count) do (backward-expression mark (current-syntax)))) + (indent-region *drei-instance* (point) mark))) (define-command (com-lookup-arglist-for-this-symbol :command-table lisp-table) () "Show argument list for symbol at point." - (let* ((pane (current-window)) - (buffer (buffer pane)) - (syntax (syntax buffer)) - (mark (point pane)) - (token (this-form syntax mark))) + (let* ((token (this-form (current-syntax) (point)))) (if (and token (form-token-p token)) - (com-lookup-arglist (form-to-object syntax token)) + (com-lookup-arglist (form-to-object (current-syntax) token)) (display-message "Could not find symbol at point.")))) (define-command (com-lookup-arglist :name t :command-table lisp-table) @@ -143,16 +133,12 @@ First indents the line. If the line was already indented, completes the symbol. If there's no symbol at the point, shows the arglist for the most recently enclosed operator." - (let* ((pane (current-window)) - (point (point pane)) - (old-offset (offset point))) - (indent-current-line pane point) + (let ((old-offset (offset (point)))) + (indent-current-line *drei-instance* (point)) (when (= old-offset - (offset point)) - (let* ((buffer (buffer pane)) - (syntax (syntax buffer))) - (or (complete-symbol-at-mark syntax point nil) - (show-arglist-for-form-at-mark point syntax)))))) + (offset (point))) + (or (complete-symbol-at-mark (current-syntax) (point) nil) + (show-arglist-for-form-at-mark (point) (current-syntax)))))) (define-presentation-to-command-translator lookup-symbol-arglist (symbol com-lookup-arglist lisp-table --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2007/11/19 20:28:43 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2007/11/19 22:16:47 1.4 @@ -61,7 +61,7 @@ ((string 'string :prompt "String Search")) "Prompt for a string and search forward for it. If found, leaves point after string. If not, leaves point where it is." - (simple-search-forward (current-window) + (simple-search-forward *drei-instance* #'(lambda (mark) (search-forward mark string :test (case-relevant-test string))))) @@ -70,7 +70,7 @@ ((string 'string :prompt "Reverse String Search")) "Prompt for a string and search backward for it. If found, leaves point before string. If not, leaves point where it is." - (simple-search-backward (current-window) + (simple-search-backward *drei-instance* #'(lambda (mark) (search-backward mark string :test (case-relevant-test string))))) @@ -83,7 +83,7 @@ ((word 'string :prompt "Search word")) "Prompt for a whitespace delimited word and search forward for it. If found, leaves point after the word. If not, leaves point where it is." - (simple-search-forward (current-window) + (simple-search-forward *drei-instance* #'(lambda (mark) (search-word-forward mark word)))) @@ -91,7 +91,7 @@ ((word 'string :prompt "Search word")) "Prompt for a whitespace delimited word and search backward for it. If found, leaves point before the word. If not, leaves point where it is." - (simple-search-backward (current-window) + (simple-search-backward *drei-instance* #'(lambda (mark) (search-backward mark word)))) @@ -173,7 +173,7 @@ (define-command (com-isearch-forward :name t :command-table search-table) () (display-message "Isearch: ") - (isearch-command-loop (current-window) t)) + (isearch-command-loop *drei-instance* t)) (set-key 'com-isearch-forward 'search-table @@ -181,14 +181,14 @@ (define-command (com-isearch-backward :name t :command-table search-table) () (display-message "Isearch backward: ") - (isearch-command-loop (current-window) nil)) + (isearch-command-loop *drei-instance* nil)) (set-key 'com-isearch-backward 'search-table '((#\r :control))) (defun isearch-append-char (char) - (let* ((states (isearch-states (current-window))) + (let* ((states (isearch-states *drei-instance*)) (string (concatenate 'string (search-string (first states)) (string char))) @@ -196,7 +196,7 @@ (forwardp (search-forward-p (first states)))) (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark))) - (isearch-from-mark (current-window) mark string forwardp))) + (isearch-from-mark *drei-instance* mark string forwardp))) (define-command (com-isearch-append-char :name t :command-table isearch-drei-table) () (isearch-append-char *current-gesture*)) @@ -205,7 +205,7 @@ (isearch-append-char #\Newline)) (defun isearch-append-text (movement-function) - (let* ((states (isearch-states (current-window))) + (let* ((states (isearch-states *drei-instance*)) (start (clone-mark (point))) (mark (clone-mark (search-mark (first states)))) (forwardp (search-forward-p (first states)))) @@ -219,7 +219,7 @@ point-offset)))) (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark) (- point-offset start-offset))) - (isearch-from-mark (current-window) mark string forwardp)))) + (isearch-from-mark *drei-instance* mark string forwardp)))) (define-command (com-isearch-append-word :name t :command-table isearch-drei-table) () (isearch-append-text #'(lambda (mark) (forward-word mark (current-syntax))))) @@ -228,7 +228,7 @@ (isearch-append-text #'end-of-line)) (define-command (com-isearch-append-kill :name t :command-table isearch-drei-table) () - (let* ((states (isearch-states (current-window))) + (let* ((states (isearch-states *drei-instance*)) (yank (handler-case (kill-ring-yank *kill-ring*) (empty-kill-ring () ""))) @@ -239,50 +239,49 @@ (forwardp (search-forward-p (first states)))) (unless (or forwardp (end-of-buffer-p mark)) (incf (offset mark) (length yank))) - (isearch-from-mark (current-window) mark string forwardp))) + (isearch-from-mark *drei-instance* mark string forwardp))) (define-command (com-isearch-delete-char :name t :command-table isearch-drei-table) () - (let* ((pane (current-window))) - (cond ((null (second (isearch-states pane))) - (display-message "Isearch: ") - (beep)) - (t - (pop (isearch-states pane)) - (loop until (endp (rest (isearch-states pane))) - until (search-success-p (first (isearch-states pane))) - do (pop (isearch-states pane))) - (let ((state (first (isearch-states pane)))) - (setf (offset (point pane)) - (if (search-forward-p state) - (+ (offset (search-mark state)) - (length (search-string state))) - (- (offset (search-mark state)) - (length (search-string state))))) - (display-message "Isearch~:[ backward~;~]: ~A" - (search-forward-p state) - (display-string (search-string state)))))))) + (cond ((null (second (isearch-states *drei-instance*))) + (display-message "Isearch: ") + (beep)) + (t + (pop (isearch-states *drei-instance*)) + (loop until (endp (rest (isearch-states *drei-instance*))) + until (search-success-p (first (isearch-states *drei-instance*))) + do (pop (isearch-states *drei-instance*))) + (let ((state (first (isearch-states *drei-instance*)))) + (setf (offset (point *drei-instance*)) + (if (search-forward-p state) + (+ (offset (search-mark state)) + (length (search-string state))) + (- (offset (search-mark state)) + (length (search-string state))))) + (display-message "Isearch~:[ backward~;~]: ~A" + (search-forward-p state) + (display-string (search-string state))))))) (define-command (com-isearch-search-forward :name t :command-table isearch-drei-table) () - (let* ((states (isearch-states (current-window))) + (let* ((states (isearch-states *drei-instance*)) (string (if (null (second states)) - (isearch-previous-string (current-window)) + (isearch-previous-string *drei-instance*) (search-string (first states)))) (mark (clone-mark (point)))) - (isearch-from-mark (current-window) mark string t))) + (isearch-from-mark *drei-instance* mark string t))) (define-command (com-isearch-search-backward :name t :command-table isearch-drei-table) () - (let* ((states (isearch-states (current-window))) + (let* ((states (isearch-states *drei-instance*)) (string (if (null (second states)) - (isearch-previous-string (current-window)) + (isearch-previous-string *drei-instance*) (search-string (first states)))) (mark (clone-mark (point)))) - (isearch-from-mark (current-window) mark string nil))) + (isearch-from-mark *drei-instance* mark string nil))) (define-command (com-isearch-exit :name t :command-table isearch-drei-table) () - (let* ((states (isearch-states (current-window))) + (let* ((states (isearch-states *drei-instance*)) (string (search-string (first states))) (search-forward-p (search-forward-p (first states)))) - (setf (isearch-mode (current-window)) nil) + (setf (isearch-mode *drei-instance*) nil) (when (string= string "") (execute-frame-command *application-frame* (funcall @@ -351,7 +350,7 @@ t)))) (define-command (com-query-replace :name t :command-table search-table) () - (let* ((drei (current-window)) + (let* ((drei *drei-instance*) (old-state (query-replace-state drei)) (old-string1 (when old-state (string1 old-state))) (old-string2 (when old-state (string2 old-state))) @@ -402,8 +401,7 @@ '((#\% :shift :meta))) (define-command (com-query-replace-replace :name t :command-table query-replace-drei-table) () - (let* ((pane (current-window)) - (state (query-replace-state pane))) + (let ((state (query-replace-state *drei-instance*))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) @@ -419,14 +417,13 @@ (if (query-replace-find-next-match state) (display-message "Replace ~A with ~A:" string1 string2) - (setf (query-replace-mode pane) nil)))))) + (setf (query-replace-mode *drei-instance*) nil)))))) (define-command (com-query-replace-replace-and-quit :name t :command-table query-replace-drei-table) () - (let* ((pane (current-window)) - (state (query-replace-state pane))) + (let ((state (query-replace-state *drei-instance*))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) @@ -439,14 +436,13 @@ string2 (no-upper-p string1)) (incf occurrences) - (setf (query-replace-mode pane) nil))))) + (setf (query-replace-mode *drei-instance*) nil))))) (define-command (com-query-replace-replace-all :name t :command-table query-replace-drei-table) () - (let* ((pane (current-window)) - (state (query-replace-state pane))) + (let ((state (query-replace-state *drei-instance*))) (with-accessors ((string1 string1) (string2 string2) (occurrences occurrences) @@ -460,20 +456,19 @@ (no-upper-p string1)) (incf occurrences) while (query-replace-find-next-match state) - finally (setf (query-replace-mode pane) nil)))))) + finally (setf (query-replace-mode *drei-instance*) nil)))))) (define-command (com-query-replace-skip :name t :command-table query-replace-drei-table) () - (let* ((pane (current-window)) - (state (query-replace-state pane))) + (let ((state (query-replace-state *drei-instance*))) (with-accessors ((string1 string1) (string2 string2)) state (if (query-replace-find-next-match state) (display-message "Replace ~A with ~A:" string1 string2) - (setf (query-replace-mode pane) nil))))) + (setf (query-replace-mode *drei-instance*) nil))))) (define-command (com-query-replace-exit :name t :command-table query-replace-drei-table) () - (setf (query-replace-mode (current-window)) nil)) + (setf (query-replace-mode *drei-instance*) nil)) (defun query-replace-set-key (gesture command) (add-command-to-command-table command 'query-replace-drei-table @@ -509,7 +504,7 @@ :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (simple-search-forward (current-window) + (simple-search-forward *drei-instance* #'(lambda (mark) (re-search-forward mark (normalise-minibuffer-regex string)))))) @@ -518,7 +513,7 @@ :delimiter-gestures nil :activation-gestures '(:newline :return)))) - (simple-search-backward (current-window) + (simple-search-backward *drei-instance* #'(lambda (mark) (re-search-backward mark (normalise-minibuffer-regex string)))))) From thenriksen at common-lisp.net Mon Nov 19 22:35:04 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 17:35:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071119223504.E81AD2105A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv31186 Modified Files: builtin-commands.lisp Log Message: Fixed the OpenMCL-conditional-thing in expression reading to not cause compiler warnings. I cannot test my fix on OpenMCL, but it works elsewhere. --- /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2007/09/17 19:21:19 1.27 +++ /project/mcclim/cvsroot/mcclim/builtin-commands.lisp 2007/11/19 22:35:04 1.28 @@ -304,28 +304,29 @@ &key) (let* ((object nil) (ptype nil)) - (if (and #-openmcl nil subform-read) - (multiple-value-bind (val valid) - (funcall *sys-%read-list-expression* stream *dot-ok* *termch*) - (if valid - (setq object val) - (return-from accept (values nil 'list-terminator)))) - ;; We don't want activation gestures like :return causing an eof - ;; while reading a form. Also, we don't want spaces within forms or - ;; strings causing a premature return either! - ;; XXX This loses when rescanning (possibly in other contexts too) an - ;; activated input buffer (e.g., reading an expression from the accept - ;; method for OR where the previous readers have already given - ;; up). We should call *sys-read-preserving-whitespace* and handle the - ;; munching of whitespace ourselves according to the - ;; PRESERVE-WHITESPACE parameter. Fix after .9.2.2. - (with-delimiter-gestures (nil :override t) - (with-activation-gestures (nil :override t) - (setq object (funcall (if preserve-whitespace - *sys-read-preserving-whitespace* - *sys-read*) - stream - *eof-error-p* *eof-value* *recursivep*))))) + #.(funcall (if #+openmcl t #-openmcl nil #'identity #'fourth) + `(if subform-read + (multiple-value-bind (val valid) + (funcall *sys-%read-list-expression* stream *dot-ok* *termch*) + (if valid + (setq object val) + (return-from accept (values nil 'list-terminator)))) + ;; We don't want activation gestures like :return causing an eof + ;; while reading a form. Also, we don't want spaces within forms or + ;; strings causing a premature return either! + ;; XXX This loses when rescanning (possibly in other contexts too) an + ;; activated input buffer (e.g., reading an expression from the accept + ;; method for OR where the previous readers have already given + ;; up). We should call *sys-read-preserving-whitespace* and handle the + ;; munching of whitespace ourselves according to the + ;; PRESERVE-WHITESPACE parameter. Fix after .9.2.2. + (with-delimiter-gestures (nil :override t) + (with-activation-gestures (nil :override t) + (setq object (funcall (if preserve-whitespace + *sys-read-preserving-whitespace* + *sys-read*) + stream + *eof-error-p* *eof-value* *recursivep*)))))) (setq ptype (presentation-type-of object)) (unless (presentation-subtypep ptype 'expression) (setq ptype 'expression)) @@ -343,45 +344,46 @@ (stream input-editing-stream) (view textual-view) &key) - ;; This method is specialized to - ;; input-editing-streams and has thus been - ;; made slightly more tolerant of input - ;; errors. It is slightly hacky, but seems - ;; to work fine. - (let* ((object nil) + ;; This method is specialized to + ;; input-editing-streams and has thus been + ;; made slightly more tolerant of input + ;; errors. It is slightly hacky, but seems + ;; to work fine. + (let* ((object nil) (ptype nil)) - (if (and #-openmcl nil subform-read) - (multiple-value-bind (val valid) - (funcall *sys-%read-list-expression* stream *dot-ok* *termch*) - (if valid - (setq object val) - (return-from accept (values nil 'list-terminator)))) - ;; We don't want activation gestures like :return causing an - ;; eof while reading a form. Also, we don't want spaces within - ;; forms or strings causing a premature return either! - (with-delimiter-gestures (nil :override t) - (with-activation-gestures (nil :override t) - (setq object - ;; We loop in our accept of user input, if a reader - ;; error is signalled, we merely ignore it and ask - ;; for more input. This is so a single malplaced #\( - ;; or #\, won't throw up a debugger with a - ;; READER-ERROR and remove whatever the user wrote - ;; to the stream. - (loop for potential-object = - (handler-case (funcall - (if preserve-whitespace - *sys-read-preserving-whitespace* - *sys-read*) - stream - *eof-error-p* - *eof-value* - *recursivep*) - ((and reader-error) (e) - (declare (ignore e)) - nil)) - unless (null potential-object) - return potential-object))))) + #.(funcall (if #+openmcl t #-openmcl nil #'identity #'fourth) + `(if (and #-openmcl nil subform-read) + (multiple-value-bind (val valid) + (funcall *sys-%read-list-expression* stream *dot-ok* *termch*) + (if valid + (setq object val) + (return-from accept (values nil 'list-terminator)))) + ;; We don't want activation gestures like :return causing an + ;; eof while reading a form. Also, we don't want spaces within + ;; forms or strings causing a premature return either! + (with-delimiter-gestures (nil :override t) + (with-activation-gestures (nil :override t) + (setq object + ;; We loop in our accept of user input, if a reader + ;; error is signalled, we merely ignore it and ask + ;; for more input. This is so a single malplaced #\( + ;; or #\, won't throw up a debugger with a + ;; READER-ERROR and remove whatever the user wrote + ;; to the stream. + (loop for potential-object = + (handler-case (funcall + (if preserve-whitespace + *sys-read-preserving-whitespace* + *sys-read*) + stream + *eof-error-p* + *eof-value* + *recursivep*) + ((and reader-error) (e) + (declare (ignore e)) + nil)) + unless (null potential-object) + return potential-object)))))) (setq ptype (presentation-type-of object)) (unless (presentation-subtypep ptype 'expression) (setq ptype 'expression)) @@ -391,9 +393,9 @@ for c = (read-char stream) until (or (activation-gesture-p c) (delimiter-gesture-p c)) finally - (when (delimiter-gesture-p c) - (unread-char c stream)) - (return (values object ptype)))))) + (when (delimiter-gesture-p c) + (unread-char c stream)) + (return (values object ptype)))))) (with-system-redefinition-allowed From thenriksen at common-lisp.net Mon Nov 19 22:37:41 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 17:37:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071119223741.6FFD02400A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31329/Drei Modified Files: drei.lisp Log Message: Band-aid fix for the tab-width issue in Drei views. Really, views have no way of having a reasonable idea of how wide a tab or space character should be. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/11/19 22:16:47 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2007/11/19 22:37:41 1.19 @@ -136,7 +136,9 @@ 1) (defmethod tab-space-count ((tabify tabify-mixin)) - (round (tab-width tabify) (space-width tabify))) + (if (and (tab-width tabify) (space-width tabify)) + (round (tab-width tabify) (space-width tabify)) + 8)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Mon Nov 19 22:42:27 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 19 Nov 2007 17:42:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071119224227.F064D240C1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1006/Drei Modified Files: lisp-syntax-commands.lisp Log Message: Oops, use the provided mark, not the buffer mark, when asked for indentation information. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/11/19 22:16:47 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2007/11/19 22:42:27 1.10 @@ -69,7 +69,7 @@ :buffer buffer-implementation :offset offset2) #'(lambda (mark) - (syntax-line-indentation (point) tab-width (current-syntax))) + (syntax-line-indentation mark tab-width (current-syntax))) fill-column tab-width (current-syntax) From thenriksen at common-lisp.net Tue Nov 20 09:55:28 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 20 Nov 2007 04:55:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20071120095528.5FFEA111D8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv18392 Modified Files: drei-clim.lisp Log Message: Only drei-areas have editor panes. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/11/19 20:28:43 1.21 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2007/11/20 09:55:28 1.22 @@ -358,7 +358,7 @@ (multiple-value-list (output-record-position area))) (tree-recompute-extent area)) -(defmethod esa-current-window ((drei drei)) +(defmethod esa-current-window ((drei drei-area)) (editor-pane drei)) (defmethod display-drei ((drei drei-area)) From crhodes at common-lisp.net Wed Nov 21 22:33:51 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 21 Nov 2007 17:33:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20071121223351.22B004D04E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11284 Modified Files: NEWS Log Message: Improve the Null backend sufficiently to be able to run gsharp headlessly. --- /project/mcclim/cvsroot/mcclim/NEWS 2007/09/29 13:27:26 1.26 +++ /project/mcclim/cvsroot/mcclim/NEWS 2007/11/21 22:33:50 1.27 @@ -1,6 +1,9 @@ * Changes in mcclim-0.9.6 relative to 0.9.5: ** Bug fix: ESA's help commands are better at finding bindings and describing them +** Bug fix: Some missing methods and functions have been implemented + for the Null backend, allowing headless operation for many + applications. * Changes in mcclim-0.9.5 relative to 0.9.4: ** Installation: the systems clim-listener, clim-examples, From crhodes at common-lisp.net Wed Nov 21 22:33:51 2007 From: crhodes at common-lisp.net (crhodes) Date: Wed, 21 Nov 2007 17:33:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/Null Message-ID: <20071121223351.6A57D4F014@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/Null In directory clnet:/tmp/cvs-serv11284/Backends/Null Modified Files: frame-manager.lisp medium.lisp port.lisp Log Message: Improve the Null backend sufficiently to be able to run gsharp headlessly. --- /project/mcclim/cvsroot/mcclim/Backends/Null/frame-manager.lisp 2006/03/24 11:45:03 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/frame-manager.lisp 2007/11/21 22:33:51 1.2 @@ -22,9 +22,22 @@ (defclass null-frame-manager (frame-manager) ()) +;;; FIXME: maybe this or something like it belongs in CLIMI? +(defun generic-concrete-pane-class (name) + (let* ((concrete-name (get name 'climi::concrete-pane-class-name)) + (maybe-name (concatenate 'string (symbol-name name) + (symbol-name '#:-pane))) + (maybe-symbol (find-symbol maybe-name :climi)) + (maybe-class (find-class maybe-symbol nil))) + (or maybe-class + (find-class concrete-name nil) + (find-class (if (keywordp name) + (intern (symbol-name name) :climi) + name) nil)))) + (defmethod make-pane-1 ((fm null-frame-manager) (frame application-frame) type &rest initargs) - (apply #'make-instance type + (apply #'make-instance (generic-concrete-pane-class type) :frame frame :manager fm :port (port frame) initargs)) --- /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2007/07/17 15:58:47 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/medium.lisp 2007/11/21 22:33:51 1.4 @@ -204,3 +204,15 @@ (defmethod medium-miter-limit ((medium null-medium)) 0) + +;;; FIXME: need these to stop the default method attempting to do +;;; pixmaps, which it appears the null backend doesn't support yet. +(defmethod climi::medium-draw-bezier-design* + ((medium null-medium) (design climi::bezier-area)) + nil) +(defmethod climi::medium-draw-bezier-design* + ((medium null-medium) (design climi::bezier-union)) + nil) +(defmethod climi::medium-draw-bezier-design* + ((medium null-medium) (design climi::bezier-difference)) + nil) --- /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2007/07/17 15:58:47 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/Null/port.lisp 2007/11/21 22:33:51 1.5 @@ -145,6 +145,8 @@ (defmethod port-allocate-pixmap ((port null-port) sheet width height) (declare (ignore sheet width height)) + ;; FIXME: this isn't actually good enough; it leads to errors in + ;; WITH-OUTPUT-TO-PIXMAP nil) (defmethod port-deallocate-pixmap ((port null-port) pixmap) From crhodes at common-lisp.net Tue Nov 27 19:49:33 2007 From: crhodes at common-lisp.net (crhodes) Date: Tue, 27 Nov 2007 14:49:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/PostScript Message-ID: <20071127194933.D51DD1D116@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/PostScript In directory clnet:/tmp/cvs-serv12535/Backends/PostScript Modified Files: class.lisp sheet.lisp Log Message: New new-page handling for the Postscript backend. Initially from hefner; somewhat frobbed to make EPS continue to work too. --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/class.lisp 2006/03/29 10:43:38 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/class.lisp 2007/11/27 19:49:33 1.10 @@ -79,7 +79,8 @@ :reader sheet-native-transformation) (current-page :initform 0) (document-fonts :initform '()) - (graphics-state-stack :initform '()))) + (graphics-state-stack :initform '()) + (pages :initform nil :accessor postscript-pages))) (defun make-postscript-stream (file-stream port device-type multi-page scale-to-fit --- /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2006/04/01 21:07:04 1.15 +++ /project/mcclim/cvsroot/mcclim/Backends/PostScript/sheet.lisp 2007/11/27 19:49:33 1.16 @@ -62,7 +62,9 @@ (with-output-recording-options (stream :record t :draw nil) (with-graphics-state (stream) ;; we need at least one level of saving -- APD, 2002-02-11 - (funcall continuation stream))) + (funcall continuation stream) + (unless (eql (slot-value stream 'paper) :eps) + (new-page stream)))) ; Close final page. (with-slots (file-stream title for orientation paper) stream (format file-stream "%!PS-Adobe-3.0~@[ EPSF-3.0~*~]~%" (eq device-type :eps)) @@ -98,10 +100,17 @@ (write-font-to-postscript-stream (sheet-medium stream) text-style)) (start-page stream) (format file-stream "~@[~A ~]~@[~A translate~%~]" translate-x translate-y) - (let ((record (stream-output-history stream))) - (with-output-recording-options (stream :draw t :record nil) - (with-graphics-state (stream) - (replay record stream)))))) + + (with-output-recording-options (stream :draw t :record nil) + (with-graphics-state (stream) + (case paper + ((:eps) (replay (stream-output-history stream) stream)) + (t (let ((last-page (first (postscript-pages stream)))) + (dolist (page (reverse (postscript-pages stream))) + (replay page stream) + (unless (eql page last-page) + (emit-new-page stream)))))))))) + (with-slots (file-stream current-page) stream (format file-stream "end~%showpage~%~%") (format file-stream "%%Trailer~%") @@ -118,39 +127,21 @@ (format file-stream "%%Page: ~D ~:*~D~%" (incf current-page)) (format file-stream "~A begin~%" *dictionary-name*))) -;;; We define a new output-record class and a method on -;;; replay-output-record so that we can record calls to new-page. -;;; -;;; FIXME: I (CSR) think that this works because we stuff this in a -;;; sequence-output-record, so that the output records are replayed -;;; in order. That's fine, but if someone ever gets round to implementing -;;; R-trees or similar, this method for storing the order of events might -;;; stop working. CSR, 2005-12-30 -(defclass new-page-record (climi::basic-output-record) - ()) - -(defmethod replay-output-record ((record new-page-record) stream - &optional (region nil) (x-offset 0) (y-offset 0)) - (declare (ignore region x-offset y-offset)) - (new-page stream)) - -(defun new-page (stream) - (when (stream-recording-p stream) - (stream-add-output-record stream (make-instance 'new-page-record))) - (when (stream-drawing-p stream) - ;; FIXME: it is necessary to do smth with GS -- APD, 2002-02-11 - ;; FIXME^2: what do you mean by that? -- TPD, 2005-12-23 - (postscript-restore-graphics-state stream) - (format (postscript-stream-file-stream stream) "end~%showpage~%") - (start-page stream) - (postscript-save-graphics-state stream) - ;; If we call clear-output-record here, it wipes all remaining - ;; output, so all pages after the first are blank. But I don't - ;; know quite what the original purpose of the call was, so, - ;; FIXME. -- TPD 2005-12-23 - #-(and) (clear-output-record (stream-output-history stream))) +(defun new-page (stream) + (push (stream-output-history stream) (postscript-pages stream)) + (let ((history (make-instance 'standard-tree-output-history :stream stream))) + (setf (slot-value stream 'climi::output-history) history + (stream-current-output-record stream) history)) (setf (stream-cursor-position stream) (values 0 0))) +(defun emit-new-page (stream) + ;; FIXME: it is necessary to do smth with GS -- APD, 2002-02-11 + ;; FIXME^2: what do you mean by that? -- TPD, 2005-12-23 + (postscript-restore-graphics-state stream) + (format (postscript-stream-file-stream stream) "end~%showpage~%") + (start-page stream) + (postscript-save-graphics-state stream)) + ;;;; Output Protocol (defmethod medium-drawable ((medium postscript-medium)) From thenriksen at common-lisp.net Wed Nov 28 08:11:12 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 28 Nov 2007 03:11:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Lisp-Dep Message-ID: <20071128081112.CC5EA2D033@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv20064 Modified Files: mp-sbcl.lisp Log Message: Removed :locked keyword from call to sb-thread:get-mutex. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2006/08/04 12:49:53 1.9 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2007/11/28 08:11:12 1.10 @@ -63,7 +63,7 @@ (defvar *permanent-queue* (sb-thread:make-mutex :name "Lock for disabled threads")) (unless (sb-thread:mutex-value *permanent-queue*) - (sb-thread:get-mutex *permanent-queue* :locked nil)) + (sb-thread:get-mutex *permanent-queue* nil)) (defun make-process (function &key name) (let ((p (%make-process :name name :function function)))