[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Sat Dec 8 08:55:07 UTC 2007
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv14160
Modified Files:
c-syntax.lisp climacs-lisp-syntax-commands.lisp
climacs-lisp-syntax.lisp climacs.asd core.lisp
file-commands.lisp groups.lisp gui.lisp
java-syntax-commands.lisp java-syntax.lisp misc-commands.lisp
packages.lisp search-commands.lisp text-syntax.lisp
window-commands.lisp
Log Message:
Changed Climacs to use a view-paradigm. Somewhat hacky, probably buggy.
--- /project/climacs/cvsroot/climacs/c-syntax.lisp 2007/06/04 22:34:45 1.4
+++ /project/climacs/cvsroot/climacs/c-syntax.lisp 2007/12/08 08:55:05 1.5
@@ -552,6 +552,7 @@
finally (return dots-seen)))))
(defun lex-token (syntax scan)
+ (declare (ignore syntax))
(labels ((fo () (forward-object scan)))
(cond ((alpha-or-underscore-p (object-after scan))
(let ((token (make-array 32 :element-type 'character
@@ -781,145 +782,87 @@
`syntax'."
(buffer-substring (buffer syntax) (start-offset form) (end-offset form)))
-(defvar *white-space-start* nil)
+(define-standard-faces c-syntax
+ (make-face :error +red+)
+ (make-face :string +rosy-brown+ (make-text-style nil :italic nil))
+ (make-face :keyword +orchid+ nil)
+ (make-face :preprocessor +purple+ nil)
+ (make-face :type-specifier +dark-blue+ nil)
+ (make-face :storage-class +dark-green+ nil)
+ (make-face :comment +maroon+ nil)
+ (make-face :number +gray50+ nil))
-(defvar *current-line* 0)
-
-(defparameter *current-faces*
- `((:error ,+red+ nil)
- (:string ,+rosy-brown+ ,(make-text-style nil :italic nil))
- (:keyword ,+orchid+ nil)
- (:preprocessor ,+purple+ nil)
- (:type-specifier ,+dark-blue+ nil)
- (:storage-class ,+dark-green+ nil)
- (:comment ,+maroon+ nil)
- (:number ,+gray50+ nil)))
-
-(defun face-colour (type)
- (first (cdr (assoc type *current-faces*))))
-
-(defun face-style (type)
- (second (cdr (assoc type *current-faces*))))
-
-(defmacro with-face ((face &optional (stream-symbol 'stream)) &body body)
- `(with-drawing-options (,stream-symbol :ink (face-colour ,face)
- :text-style (face-style ,face))
- , at body))
-
-(defun handle-whitespace (pane buffer start end)
- (let ((space-width (space-width pane))
- (tab-width (tab-width pane)))
- (with-sheet-medium (medium pane)
- (with-accessors ((cursor-positions cursor-positions)) (syntax buffer)
- (loop while (< start end)
- do (case (buffer-object buffer start)
- (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*))
- (terpri pane)
- (stream-increment-cursor-position
- pane (first (aref cursor-positions 0)) 0))
- ((#\Page #\Return #\Space) (stream-increment-cursor-position
- pane space-width 0))
- (#\Tab (when (plusp tab-width)
- (let ((x (stream-cursor-position pane)))
- (stream-increment-cursor-position
- pane (- tab-width (mod x tab-width)) 0)))))
- (incf start))))))
-
-(defgeneric display-parse-tree (parse-symbol stream drei syntax)
- (:documentation "Display the given parse-symbol on the supplied
- stream, assuming `drei' to be the relevant Drei instance and
- `syntax' being the syntax object responsible for the parse
- symbol."))
-
-(defmethod display-parse-tree ((parse-symbol (eql nil)) stream (drei drei)
+(defmethod display-parse-tree ((parse-symbol (eql nil)) stream (view textual-drei-syntax-view)
(syntax c-syntax))
nil)
-(defmethod display-parse-tree :around (parse-symbol stream (drei drei)
- (syntax c-syntax))
- (with-slots (top bot) drei
- (when (and (start-offset parse-symbol)
- (mark< (start-offset parse-symbol) bot)
- (mark> (end-offset parse-symbol) top))
- (call-next-method))))
-
-(defmethod display-parse-tree (parse-symbol stream (drei drei)
- (syntax c-syntax))
- (with-slots (top bot) drei
- (loop for child in (children parse-symbol)
- when (and (start-offset child)
- (mark> (end-offset child) top))
- do (if (mark< (start-offset child) bot)
- (display-parse-tree child stream drei syntax)
- (return)))))
-
-(defmethod display-parse-tree ((parse-symbol error-symbol) stream (drei drei)
+(defmethod display-parse-tree ((parse-symbol error-symbol) stream (view textual-drei-syntax-view)
(syntax c-syntax))
(let ((children (children parse-symbol)))
(loop until (or (null (cdr children))
(typep (parser-state (cadr children)) 'error-state))
- do (display-parse-tree (pop children) stream drei syntax))
+ do (display-parse-tree (pop children) stream view syntax))
(if (and (null (cdr children))
(not (typep (parser-state parse-symbol) 'error-state)))
- (display-parse-tree (car children) stream drei syntax)
+ (display-parse-tree (car children) stream view syntax)
(with-face (:error)
(loop for child in children
- do (display-parse-tree child stream drei syntax))))))
+ do (display-parse-tree child stream view syntax))))))
-(defmethod display-parse-tree ((parse-symbol error-lexeme) stream (drei drei) (syntax c-syntax))
+(defmethod display-parse-tree ((parse-symbol error-lexeme) stream (view textual-drei-syntax-view) (syntax c-syntax))
(with-face (:error)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol integer-constant-lexeme)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(with-face (:number)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol floating-constant-lexeme)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(with-face (:number)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol type-specifier)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(with-face (:type-specifier)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol storage-class-specifier)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(with-face (:storage-class)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol function-specifier)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(with-face (:storage-class)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol type-qualifier)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(with-face (:type-specifier)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol operator)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(with-face (:keyword)
(call-next-method)))
-(defmethod display-parse-tree ((parser-symbol c-lexeme) stream (drei drei)
+(defmethod display-parse-tree ((parser-symbol c-lexeme) stream (view textual-drei-syntax-view)
(syntax c-syntax))
(flet ((cache-test (t1 t2)
(and (eq t1 t2)
@@ -928,7 +871,7 @@
(eq (slot-value t1 'face)
(text-style-face (medium-text-style (sheet-medium stream)))))))
(updating-output
- (stream :unique-id (list drei parser-symbol)
+ (stream :unique-id (list view parser-symbol)
:id-test #'equal
:cache-value parser-symbol
:cache-test #'cache-test)
@@ -937,107 +880,83 @@
face (text-style-face (medium-text-style (sheet-medium stream))))
(write-string (form-string syntax parser-symbol) stream)))))
-(defmethod display-parse-tree :before ((parse-symbol c-lexeme)
- stream
- (drei drei)
- (syntax c-syntax))
- (handle-whitespace stream (buffer drei)
- *white-space-start* (start-offset parse-symbol))
- (setf *white-space-start* (end-offset parse-symbol)))
-
(defmethod display-parse-tree ((parse-symbol complete-string-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(let ((children (children parse-symbol)))
(if (third children)
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)
+ (display-parse-tree (pop children) stream view syntax)
(loop until (null (cdr children))
- do (display-parse-tree (pop children) stream drei syntax))
- (display-parse-tree (pop children) stream drei syntax))
+ do (display-parse-tree (pop children) stream view syntax))
+ (display-parse-tree (pop children) stream view syntax))
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)
- (display-parse-tree (pop children) stream drei syntax)))))
+ (display-parse-tree (pop children) stream view syntax)
+ (display-parse-tree (pop children) stream view syntax)))))
(defmethod display-parse-tree ((parse-symbol incomplete-string-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(let ((children (children parse-symbol)))
(if (second children)
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)
+ (display-parse-tree (pop children) stream view syntax)
(loop until (null children)
- do (display-parse-tree (pop children) stream drei syntax)))
+ do (display-parse-tree (pop children) stream view syntax)))
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)))))
+ (display-parse-tree (pop children) stream view syntax)))))
(defmethod display-parse-tree ((parse-symbol complete-character-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(let ((children (children parse-symbol)))
(if (third children)
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)
+ (display-parse-tree (pop children) stream view syntax)
(loop until (null (cdr children))
- do (display-parse-tree (pop children) stream drei syntax))
- (display-parse-tree (pop children) stream drei syntax))
+ do (display-parse-tree (pop children) stream view syntax))
+ (display-parse-tree (pop children) stream view syntax))
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)
- (display-parse-tree (pop children) stream drei syntax)))))
+ (display-parse-tree (pop children) stream view syntax)
+ (display-parse-tree (pop children) stream view syntax)))))
(defmethod display-parse-tree ((parse-symbol incomplete-character-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(let ((children (children parse-symbol)))
(if (second children)
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)
+ (display-parse-tree (pop children) stream view syntax)
(loop until (null children)
- do (display-parse-tree (pop children) stream drei syntax)))
+ do (display-parse-tree (pop children) stream view syntax)))
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)))))
+ (display-parse-tree (pop children) stream view syntax)))))
(defmethod display-parse-tree ((parse-symbol preprocessor-directive-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(with-face (:preprocessor)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol line-comment-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(with-face (:comment)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol long-comment-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax c-syntax))
(with-face (:comment)
(call-next-method)))
-(defmethod display-drei-contents ((stream clim-stream-pane)
- (drei drei)
- (syntax c-syntax))
- (with-slots (top bot) drei
- (with-accessors ((cursor-positions cursor-positions)) syntax
- ;; There must always be room for at least one element of line
- ;; information.
- (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot))
- :initial-element nil)
- *current-line* 0
- (aref cursor-positions 0) (multiple-value-list
- (stream-cursor-position stream))))
- (setf *white-space-start* (offset top)))
- (with-slots (stack-top) syntax
- (display-parse-tree stack-top stream drei syntax)))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; exploit the parse
--- /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2007/11/20 12:59:53 1.5
+++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2007/12/08 08:55:06 1.6
@@ -58,7 +58,7 @@
The expanded expression will be displayed in a
\"*Macroexpansion*\"-buffer."
- (let*((token (expression-at-mark (point) (current-syntax))))
+ (let* ((token (expression-at-mark (current-syntax) (point))))
(if token
(macroexpand-token (current-syntax) token)
(esa:display-message "Nothing to expand at point."))))
@@ -69,7 +69,7 @@
The expanded expression will be displayed in a
\"*Macroexpansion*\"-buffer."
- (let ((token (expression-at-mark (point) (current-syntax))))
+ (let ((token (expression-at-mark (current-syntax) (point))))
(if token
(macroexpand-token (current-syntax) token t)
(esa:display-message "Nothing to expand at point."))))
@@ -86,7 +86,7 @@
"Compile the file open in the current buffer.
This command does not load the file after it has been compiled."
- (compile-file-interactively (current-buffer) nil))
+ (compile-file-interactively (current-view) nil))
(define-command (com-goto-location :name t :command-table climacs-lisp-table)
((note 'compiler-note))
@@ -131,7 +131,7 @@
()
"Compile and load definition at point."
(evaluating-interactively
- (compile-definition-interactively (point) (current-syntax))))
+ (compile-definition-interactively (current-view) (point))))
(esa:set-key 'com-eval-defun
'climacs-lisp-table
--- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2007/11/20 12:59:53 1.5
+++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2007/12/08 08:55:06 1.6
@@ -49,8 +49,8 @@
(snippet :initarg :snippet :accessor snippet :initform nil))
(:documentation "The base for all non-error locations."))
-(defclass buffer-location (actual-location)
- ((buffer-name :initarg :buffer :accessor buffer-name)))
+(defclass view-location (actual-location)
+ ((view-name :initarg :view :accessor view-name)))
(defclass file-location (actual-location)
((file-name :initarg :file :accessor file-name)))
@@ -121,7 +121,7 @@
(apply #'make-instance
(ecase (first buf)
(:file 'file-location)
- (:buffer 'buffer-location)
+ (:buffer 'view-location)
(:source-form 'source-location))
buf))
(position
@@ -204,9 +204,9 @@
(def-print-for-menu style-warning-compiler-note "Style Warning" +brown+)
(def-print-for-menu note-compiler-note "Note" +brown+)
-(defun show-notes (notes buffer-name definition)
+(defun show-notes (notes view-name definition)
(let ((stream (climacs-gui:typeout-window
- (format nil "~10TCompiler Notes: ~A ~A" buffer-name definition))))
+ (format nil "~10TCompiler Notes: ~A ~A" view-name definition))))
(loop for note in notes
do (with-output-as-presentation (stream note 'compiler-note)
(print-for-menu note stream))
@@ -221,27 +221,27 @@
(defmethod goto-location ((location error-location))
(esa:display-message (error-message location)))
-(defmethod goto-location ((location buffer-location))
- (let ((buffer (find (buffer-name location)
- (buffers *application-frame*)
- :test #'string= :key #'name)))
- (unless buffer
- (esa:display-message "No buffer ~A" (buffer-name location))
+(defmethod goto-location ((location view-location))
+ (let ((view (find (view-name location)
+ (climacs-gui:views *esa-instance*)
+ :test #'string= :key #'name)))
+ (unless view
+ (esa:display-message "No view ~A" (view-name location))
(beep)
(return-from goto-location))
- (climacs-core:switch-to-buffer (current-window) buffer)
- (goto-position (point (current-window))
+ (climacs-core:switch-to-view (current-window) view)
+ (goto-position (point)
(char-position (source-position location)))))
(defmethod goto-location ((location file-location))
- (let ((buffer (find (file-name location)
- (buffers *application-frame*)
- :test #'string= :key #'(lambda (buffer)
- (let ((path (filepath buffer)))
+ (let ((view (find (file-name location)
+ (views *application-frame*)
+ :test #'string= :key #'(lambda (view)
+ (let ((path (filepath view)))
(when path
(namestring path)))))))
- (if buffer
- (climacs-core:switch-to-buffer (current-window) buffer)
+ (if view
+ (climacs-core:switch-to-view (current-window) view)
(find-file (file-name location)))
(goto-position (point (current-window))
(char-position (source-position location)))))
@@ -259,25 +259,24 @@
all))
(expansion-string (with-output-to-string (s)
(pprint expansion s))))
- (let ((buffer (climacs-core:switch-to-buffer (current-window) "*Macroexpansion*")))
- (set-syntax buffer "Lisp"))
- (let ((point (point (current-window)))
- (header-string (one-line-ify (subseq string 0
+ (let ((view (climacs-core:switch-to-view (current-window) "*Macroexpansion*")))
+ (set-syntax view "Lisp"))
+ (let ((header-string (one-line-ify (subseq string 0
(min 40 (length string))))))
- (end-of-buffer point)
- (unless (beginning-of-buffer-p point)
- (insert-object point #\Newline))
- (insert-sequence point
+ (end-of-buffer (point))
+ (unless (beginning-of-buffer-p (point))
+ (insert-object (point) #\Newline))
+ (insert-sequence (point)
(format nil ";;; Macroexpand-~:[1~;all~] ~A...~%"
all header-string))
- (insert-sequence point expansion-string)
- (insert-object point #\Newline)))))
+ (insert-sequence (point) expansion-string)
+ (insert-object (point) #\Newline)))))
-(defun compile-definition-interactively (mark syntax)
- (let* ((token (definition-at-mark syntax mark))
+(defun compile-definition-interactively (view mark)
+ (let* ((syntax (syntax view))
+ (token (definition-at-mark syntax mark))
(string (form-string syntax token))
(m (clone-mark mark))
- (buffer-name (name (buffer syntax)))
(*read-base* (base syntax)))
(with-syntax-package (syntax mark)
(forward-definition m syntax 1 nil)
@@ -287,28 +286,28 @@
(form-to-object syntax token
:read t
:package (package-at-mark syntax mark))
- (buffer syntax)
- m)
+ syntax m)
(show-note-counts notes (second result))
(when (not (null notes))
- (show-notes notes buffer-name
+ (show-notes notes (name view)
(one-line-ify (subseq string 0 (min (length string) 20))))))
(display-message "No definition at point")))))
-(defun compile-file-interactively (buffer &optional load-p)
- (cond ((null (filepath buffer))
- (esa:display-message "Buffer ~A is not associated with a file" (name buffer)))
- (t
- (when (and (needs-saving buffer)
- (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer))))
- (climacs-core:save-buffer buffer))
- (let ((*read-base* (base (syntax buffer))))
- (multiple-value-bind (result notes)
- (compile-file-for-drei (get-usable-image (syntax buffer))
- (filepath buffer)
- (package-at-mark (syntax buffer) 0) load-p)
- (show-note-counts notes (second result))
- (when notes (show-notes notes (name buffer) "")))))))
+(defun compile-file-interactively (view &optional load-p)
+ (let ((buffer (buffer view)))
+ (cond ((null (filepath buffer))
+ (esa:display-message "View ~A is not associated with a file" (name view)))
+ (t
+ (when (and (needs-saving buffer)
+ (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name view))))
+ (climacs-core:save-buffer buffer))
+ (let ((*read-base* (base (syntax view))))
+ (multiple-value-bind (result notes)
+ (compile-file-for-drei (get-usable-image (syntax view))
+ (filepath buffer)
+ (package-at-mark (syntax view) 0) load-p)
+ (show-note-counts notes (second result))
+ (when notes (show-notes notes (name view) ""))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -318,12 +317,12 @@
(defun pop-find-definition-stack ()
(unless (null *find-definition-stack*)
- (let* ((offset+buffer (pop *find-definition-stack*))
- (offset (first offset+buffer))
- (buffer (second offset+buffer)))
- (if (find buffer (buffers *application-frame*))
- (progn (climacs-core:switch-to-buffer (current-window) buffer)
- (goto-position (point (current-window)) offset))
+ (let* ((offset+view (pop *find-definition-stack*))
+ (offset (first offset+view))
+ (view (second offset+view)))
+ (if (find view (views *esa-instance*))
+ (progn (climacs-core:switch-to-view (current-window) view)
+ (goto-position (point) offset))
(pop-find-definition-stack)))))
;; KLUDGE: We need to put more info in the definition objects to begin
@@ -331,18 +330,18 @@
(defun definition-type (definition)
(let ((data (read-from-string (first definition))))
(case (first data)
- ((or cl:defclass)
+ ((cl:defclass)
'cl:class)
- ((or cl:defgeneric
+ ((cl:defgeneric
cl:defmethod
cl:defun
- cl:defmacro)
+ cl:defmacro)
'cl:function)
(t t))))
(defun edit-definition (symbol &optional type)
(let ((all-definitions (find-definitions-for-drei
- (get-usable-image (syntax (current-buffer)))
+ (get-usable-image (current-syntax))
symbol)))
(let ((definitions (if (not type)
all-definitions
@@ -356,11 +355,7 @@
(goto-definition symbol definitions))))))
(defun goto-definition (name definitions)
- (let* ((pane (current-window))
- (buffer (buffer pane))
- (point (point pane))
- (offset (offset point)))
- (push (list offset buffer) *find-definition-stack*))
+ (push (list (offset (point)) (current-view)) *find-definition-stack*)
(cond ((null (cdr definitions))
(let* ((def (car definitions))
(xref (make-xref def)))
@@ -413,12 +408,11 @@
;; WARNING, using this group can be dangerous, as Climacs is not
;; really suited to opening up a large amount of buffers that each
-;; require a full syntax reparse. FIXME: Groups are currently
-;; disabled.
-#+nil (climacs-core:define-group "ASDF System Files" (group (system (asdf:find-system (accept 'symbol :prompt "System"))))
- (declare (ignore group))
- (when system
- (mapcar #'asdf:component-pathname
- (remove-if-not (lambda (c)
- (typep c 'asdf:cl-source-file))
- (asdf:module-components system)))))
\ No newline at end of file
+;; require a full syntax reparse.
+(climacs-core:define-group "ASDF System Files" (group (system (asdf:find-system (accept 'symbol :prompt "System"))))
+ (declare (ignore group))
+ (when system
+ (mapcar #'asdf:component-pathname
+ (remove-if-not (lambda (c)
+ (typep c 'asdf:cl-source-file))
+ (asdf:module-components system)))))
\ No newline at end of file
--- /project/climacs/cvsroot/climacs/climacs.asd 2007/11/16 09:29:47 1.61
+++ /project/climacs/cvsroot/climacs/climacs.asd 2007/12/08 08:55:06 1.62
@@ -34,18 +34,18 @@
:components
((:file "packages")
(:file "text-syntax" :depends-on ("packages"))
- (:file "cl-syntax" :depends-on ("packages"))
- (:file "html-syntax" :depends-on ("packages"))
- (:file "prolog-syntax" :depends-on ("packages"))
- (:file "prolog2paiprolog" :depends-on ("prolog-syntax"))
- (:file "ttcn3-syntax" :depends-on ("packages"))
+;; (:file "cl-syntax" :depends-on ("packages"))
+;; (:file "html-syntax" :depends-on ("packages"))
+;; (:file "prolog-syntax" :depends-on ("packages"))
+;; (:file "prolog2paiprolog" :depends-on ("prolog-syntax"))
+;; (:file "ttcn3-syntax" :depends-on ("packages"))
(:file "climacs-lisp-syntax" :depends-on ("core" "groups"))
(:file "climacs-lisp-syntax-commands" :depends-on ("climacs-lisp-syntax" "misc-commands"))
(:file "c-syntax" :depends-on ("core"))
(:file "c-syntax-commands" :depends-on ("c-syntax" "misc-commands"))
(:file "java-syntax" :depends-on ("core"))
(:file "java-syntax-commands" :depends-on ("java-syntax" "misc-commands"))
- (:file "gui" :depends-on ("packages" "text-syntax"))
+ (:file "gui" :depends-on ("packages"))
(:file "core" :depends-on ("gui"))
(:file "io" :depends-on ("packages" "gui"))
(:file "groups" :depends-on ("core"))
@@ -53,11 +53,12 @@
(:file "developer-commands" :depends-on ("core"))
(:file "file-commands" :depends-on ("gui" "core" "io"))
- (:file "misc-commands" :depends-on ("gui" "core" #+nil "groups"))
- (:file "search-commands" :depends-on ("gui" "core" #+nil "groups"))
+ (:file "misc-commands" :depends-on ("gui" "core" "groups"))
+ (:file "search-commands" :depends-on ("gui" "core" "groups"))
(:file "window-commands" :depends-on ("gui" "core"))
- (:file "slidemacs" :depends-on ("packages" ))
- (:file "slidemacs-gui" :depends-on ("packages" "gui" "slidemacs"))))
+ ;; (:file "slidemacs" :depends-on ("packages" ))
+;; (:file "slidemacs-gui" :depends-on ("packages" "gui" "slidemacs"))
+ ))
#+asdf
(defmethod asdf:perform :around ((o asdf:compile-op)
--- /project/climacs/cvsroot/climacs/core.lisp 2007/12/04 07:45:35 1.15
+++ /project/climacs/cvsroot/climacs/core.lisp 2007/12/08 08:55:06 1.16
@@ -19,40 +19,24 @@
(defmethod frame-make-new-buffer ((application-frame climacs)
&key (name "*scratch*"))
- (let ((buffer (make-instance 'climacs-buffer :name name)))
- (push buffer (buffers application-frame))
- buffer))
-
-(defgeneric erase-buffer (buffer))
-
-(defmethod erase-buffer ((buffer string))
- (let ((b (find buffer (buffers *application-frame*)
- :key #'name :test #'string=)))
- (when b (erase-buffer b))))
-
-(defmethod erase-buffer ((buffer drei-buffer))
- (let* ((point (point buffer))
- (mark (clone-mark point)))
- (beginning-of-buffer mark)
- (end-of-buffer point)
- (delete-region mark point)))
-
-(define-presentation-method present (object (type buffer)
- stream
- (view textual-view)
- &key acceptably for-context-type)
+ (make-instance 'climacs-buffer :name name))
+
+(define-presentation-method present ((object drei-view) (type view)
+ stream (view textual-view)
+ &key acceptably for-context-type)
(declare (ignore acceptably for-context-type))
- (princ (name object) stream))
+ (princ (subscripted-name object) stream))
-(define-presentation-method accept
- ((type buffer) stream (view textual-view) &key (default nil defaultp)
- (default-type type))
+(define-presentation-method accept ((type view) stream (view textual-view)
+ &key (default nil defaultp)
+ (default-type type))
(multiple-value-bind (object success string)
(complete-input stream
(lambda (so-far action)
(complete-from-possibilities
- so-far (buffers *application-frame*) '() :action action
- :name-key #'name
+ so-far (views *esa-instance*) '()
+ :action action
+ :name-key #'subscripted-name
:value-key #'identity))
:partial-completers '(#\Space)
:allow-any-input t)
@@ -65,56 +49,73 @@
(t
(values string 'string)))))
-(defgeneric switch-to-buffer (pane buffer))
+(defgeneric switch-to-view (drei view)
+ (:documentation "High-level function for changing the view
+displayed by a Drei instance."))
-(defmethod switch-to-buffer ((pane drei) (buffer drei-buffer))
- (setf (buffer pane) buffer))
+(defmethod switch-to-view ((drei climacs-pane) (view drei-view))
+ (setf (view drei) view))
-(defmethod switch-to-buffer ((pane typeout-pane) (buffer drei-buffer))
+(defmethod switch-to-view ((drei typeout-pane) (view drei-view))
(let ((usable-pane (or (find-if #'(lambda (pane)
(typep pane 'drei))
(windows *application-frame*))
(split-window t))))
- (switch-to-buffer usable-pane buffer)))
+ (switch-to-view usable-pane view)))
-(defmethod switch-to-buffer (pane (name string))
- (let ((buffer (find name (buffers *application-frame*)
- :key #'name :test #'string=)))
- (switch-to-buffer pane
- (or buffer
- (make-new-buffer :name name)))))
-
-;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR,
-;; ;;; 2005-10-31.
-;; (defmethod (setf buffer) :around (buffer (pane drei))
-;; (call-next-method)
-;; (note-pane-syntax-changed pane (syntax buffer)))
-
-(defgeneric kill-buffer (buffer))
-
-(defmethod kill-buffer ((buffer drei-buffer))
- (with-accessors ((buffers buffers)) *application-frame*
- (when (and (needs-saving buffer)
- (handler-case (accept 'boolean :prompt "Save buffer first?")
- (error () (progn (beep)
- (display-message "Invalid answer")
- (return-from kill-buffer nil)))))
- (save-buffer buffer))
- (setf buffers (remove buffer buffers))
- ;; Always need one buffer.
- (when (null buffers)
- (make-new-buffer :name "*scratch*"))
- (setf (current-buffer) (car buffers))
- (full-redisplay (current-window))
- (current-buffer)))
-
-(defmethod kill-buffer ((name string))
- (let ((buffer (find name (buffers *application-frame*)
- :key #'name :test #'string=)))
- (when buffer (kill-buffer buffer))))
+(defmethod switch-to-view (pane (name string))
+ (let ((view (find name (views (pane-frame pane))
+ :key #'subscripted-name :test #'string=)))
+ (switch-to-view
+ pane (or view (make-new-view-for-climacs
+ (pane-frame pane) 'textual-drei-syntax-view
+ :name name)))))
+
+(defun views-having-buffer (climacs buffer)
+ "Return a list of the buffer-views of `climacs' showing
+`buffer'."
+ (loop for view in (views climacs)
+ when (and (typep view 'drei-buffer-view)
+ (eq (buffer view) buffer))
+ collect view))
+
+(defun buffer-of-view-needs-saving (view)
+ "Return true if `view' is a `drei-buffer-view' and it needs to
+be saved (that is, it is related to a file and it has changed
+since it was last saved)."
+ (and (typep view 'drei-buffer-view)
+ (filepath (buffer view))
+ (needs-saving (buffer view))))
+
+(defgeneric kill-view (view)
+ (:documentation "Remove `view' from the Climacs specified in
+`*esa-instance*'. If `view' is currently displayed in a window,
+it will be replaced by some other view."))
+
+(defmethod kill-view ((view view))
+ (with-accessors ((views views)) *esa-instance*
+ ;; It might be the case that this view is the only view remaining
+ ;; of some particular buffer, in that case, the user might want to
+ ;; save it.
+ (when (and (buffer-of-view-needs-saving view)
+ (= (length (views-having-buffer *esa-instance* (buffer view)))
+ 1)
+ (handler-case (accept 'boolean :prompt "Save buffer first?")
+ (error () (progn (beep)
+ (display-message "Invalid answer")
+ (return-from kill-view nil)))))
+ (save-buffer (buffer view)))
+ (setf views (remove view views))
+ (full-redisplay (current-window))
+ (current-view)))
+
+(defmethod kill-view ((name string))
+ (let ((view (find name (views *application-frame*)
+ :key #'subscripted-name :test #'string=)))
+ (when view (kill-view view))))
-(defmethod kill-buffer ((symbol (eql 'nil)))
- (kill-buffer (current-buffer)))
+(defmethod kill-view ((symbol null))
+ (kill-view (current-view)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -139,10 +140,10 @@
syntax-description)
*default-syntax*)))
-(defun evaluate-attributes (buffer options)
- "Evaluate the attributes `options' and modify `buffer' as
- appropriate. `Options' should be an alist mapping option names
- to their values."
+(defun evaluate-attributes (view options)
+ "Evaluate the attributes `options' and modify `view' as
+appropriate. `Options' should be an alist mapping option names to
+their values."
;; First, check whether we need to change the syntax (via the SYNTAX
;; option). MODE is an alias for SYNTAX for compatibility with
;; Emacs. If there is more than one option with one of these names,
@@ -155,17 +156,16 @@
options
:key #'first)))))
(when (and specified-syntax
- (not (eq (class-of (syntax buffer))
+ (not (eq (class-of (syntax view))
specified-syntax)))
- (setf (syntax buffer)
- (make-instance specified-syntax
- :buffer buffer))))
+ (setf (syntax view)
+ (make-syntax-for-view view specified-syntax))))
;; Now we iterate through the options (discarding SYNTAX and MODE
;; options).
(loop for (name value) in options
unless (or (string-equal name "SYNTAX")
(string-equal name "MODE"))
- do (eval-option (syntax buffer) name value)))
+ do (eval-option (syntax view) name value)))
(defun split-attribute (string char)
(let (pairs)
@@ -187,10 +187,10 @@
(split-attribute line #\;))))
(defun find-attribute-line-position (buffer)
- (let ((scan (beginning-of-buffer (clone-mark (point buffer)))))
+ (let ((scan (make-buffer-mark buffer 0)))
;; skip the leading whitespace
(loop until (end-of-buffer-p scan)
- until (not (whitespacep (syntax buffer) (object-after scan)))
+ until (not (buffer-whitespacep (object-after scan)))
do (forward-object scan))
;; stop looking if we're already 1,000 objects into the buffer
(unless (> (offset scan) 1000)
@@ -232,39 +232,38 @@
(when end
(string-trim '(#\Space #\Tab) (subseq line 3 end)))))))))
-(defun replace-attribute-line (buffer new-attribute-line)
+(defun replace-attribute-line (view new-attribute-line)
(let ((full-attribute-line (concatenate 'string
"-*- "
new-attribute-line
"-*-")))
(multiple-value-bind (start-mark end-mark)
- (find-attribute-line-position buffer)
+ (find-attribute-line-position (buffer view))
(cond ((not (null end-mark))
;; We have an existing attribute line.
(delete-region start-mark end-mark)
(let ((new-line-start (clone-mark start-mark :left)))
(insert-sequence start-mark full-attribute-line)
- (comment-region (syntax buffer)
+ (comment-region (syntax view)
new-line-start
start-mark)))
(t
;; Create a new attribute line at beginning of buffer.
- (let* ((mark1 (beginning-of-buffer (clone-mark (point buffer) :left)))
+ (let* ((mark1 (make-buffer-mark (buffer view) 0 :left))
(mark2 (clone-mark mark1 :right)))
(insert-sequence mark2 full-attribute-line)
(insert-object mark2 #\Newline)
- (comment-region (syntax buffer)
+ (comment-region (syntax view)
mark1
mark2)))))))
-(defun update-attribute-line (buffer)
- (replace-attribute-line buffer
- (make-attribute-line (syntax buffer))))
+(defun update-attribute-line (view)
+ (replace-attribute-line
+ view (make-attribute-line (syntax view))))
-(defun evaluate-attribute-line (buffer)
+(defun evaluate-attribute-line (view)
(evaluate-attributes
- buffer
- (split-attribute-line (get-attribute-line buffer))))
+ view (split-attribute-line (get-attribute-line (buffer view)))))
;; Adapted from cl-fad/PCL
(defun directory-pathname-p (pathspec)
@@ -280,19 +279,21 @@
(and (probe-file pathname)
(not (directory-pathname-p pathname))))
-(defun find-buffer-with-pathname (pathname)
- "Return the (first) buffer associated with the file designated
-by `pathname'. Returns NIL if no buffer can be found."
+(defun find-view-with-pathname (pathname)
+ "Return the (first) with associated with the file designated by
+`pathname'. Returns NIL if no buffer can be found."
(flet ((usable-pathname (pathname)
(if (probe-file pathname)
(truename pathname)
pathname)))
- (find pathname (buffers *application-frame*)
- :key #'filepath
- :test #'(lambda (fp1 fp2)
- (and fp1 fp2
- (equal (usable-pathname fp1)
- (usable-pathname fp2)))))))
+ (find pathname (remove-if-not #'(lambda (view)
+ (typep view 'drei-buffer-view))
+ (views *application-frame*))
+ :key #'(lambda (view) (filepath (buffer view)))
+ :test #'(lambda (fp1 fp2)
+ (and fp1 fp2
+ (equal (usable-pathname fp1)
+ (usable-pathname fp2)))))))
(defun ensure-open-file (pathname)
"Make sure a buffer opened on `pathname' exists, finding the
@@ -309,33 +310,32 @@
(display-message "~A is a directory name." filepath)
(beep))
(t
- (let ((existing-buffer (find-buffer-with-pathname filepath)))
- (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
- (switch-to-buffer (current-window) existing-buffer)
- (progn
- (when readonlyp
- (unless (probe-file filepath)
- (beep)
- (display-message "No such file: ~A" filepath)
- (return-from find-file-impl nil)))
- (let ((buffer (if (probe-file filepath)
- (with-open-file (stream filepath :direction :input)
- (make-buffer-from-stream stream))
- (make-new-buffer)))
- (pane (current-window)))
- (setf (offset (point (buffer pane))) (offset (point pane))
- (buffer pane) buffer
- (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath)
- :buffer buffer)
- (file-write-time buffer) (file-write-date filepath))
- (evaluate-attribute-line buffer)
- (setf (filepath buffer) filepath
- (name buffer) (filepath-filename filepath)
- (read-only-p buffer) readonlyp)
- (beginning-of-buffer (point pane))
- (update-syntax buffer (syntax buffer))
- (clear-modify buffer)
- buffer)))))))
+ (let ((existing-view (find-view-with-pathname filepath)))
+ (if (and existing-view (if readonlyp (read-only-p (buffer existing-view)) t))
+ (switch-to-view (current-window) existing-view)
+ (progn
+ (when readonlyp
+ (unless (probe-file filepath)
+ (beep)
+ (display-message "No such file: ~A" filepath)
+ (return-from find-file-impl nil)))
+ (let* ((buffer (if (probe-file filepath)
+ (with-open-file (stream filepath :direction :input)
+ (make-buffer-from-stream stream))
+ (make-new-buffer)))
+ (view (make-new-view-for-climacs
+ *esa-instance* 'textual-drei-syntax-view
+ :name (filepath-filename filepath)
+ :buffer buffer)))
+ (setf (offset (point buffer)) (offset (point view))
+ (current-view) view
+ (syntax view) (make-syntax-for-view view (syntax-class-name-for-filepath filepath))
+ (file-write-time buffer) (file-write-date filepath))
+ (evaluate-attribute-line view)
+ (setf (filepath buffer) filepath
+ (read-only-p buffer) readonlyp)
+ (beginning-of-buffer (point))
+ buffer)))))))
(defmethod frame-find-file ((application-frame climacs) filepath)
(find-file-impl filepath nil))
@@ -345,8 +345,8 @@
(defun directory-of-buffer (buffer)
"Extract the directory part of the filepath to the file in BUFFER.
- If BUFFER does not have a filepath, the path to the user's home
- directory will be returned."
+If BUFFER does not have a filepath, the path to the user's home
+directory will be returned."
(make-pathname
:directory
(pathname-directory
@@ -375,18 +375,16 @@
t)))
(defmethod frame-exit :around ((frame climacs) #-mcclim &key)
- (loop for buffer in (buffers frame)
- when (and (needs-saving buffer)
- (filepath buffer)
- (handler-case (accept 'boolean
- :prompt (format nil "Save buffer: ~a ?" (name buffer)))
- (error () (progn (beep)
- (display-message "Invalid answer")
- (return-from frame-exit nil)))))
- do (save-buffer buffer))
- (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer)))
- (buffers frame))
- (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?")
+ (dolist (view (views frame))
+ (when (and (buffer-of-view-needs-saving view)
+ (handler-case (accept 'boolean
+ :prompt (format nil "Save buffer of view: ~a ?" (name view)))
+ (error () (progn (beep)
+ (display-message "Invalid answer")
+ (return-from frame-exit nil)))))
+ (save-buffer (buffer view))))
+ (when (or (notany #'buffer-of-view-needs-saving (views frame))
+ (handler-case (accept 'boolean :prompt "Modified buffers of views exist. Quit anyway?")
(error () (progn (beep)
[2 lines skipped]
--- /project/climacs/cvsroot/climacs/file-commands.lisp 2007/11/20 12:59:54 1.28
+++ /project/climacs/cvsroot/climacs/file-commands.lisp 2007/12/08 08:55:06 1.29
@@ -136,27 +136,30 @@
;;;
;;; Buffer commands
-(define-command (com-switch-to-buffer :name t :command-table pane-table)
- ((buffer 'buffer :default (or (second (buffers *application-frame*))
- (any-buffer))))
+(define-command (com-switch-to-view :name t :command-table pane-table)
+ ((view 'view :default (or (second (views *application-frame*))
+ (any-view))))
"Prompt for a buffer name and switch to that buffer.
If the a buffer with that name does not exist, create it. Uses
the name of the next buffer (if any) as a default."
- (switch-to-buffer (current-window) buffer))
+ (handler-case (switch-to-view (current-window) view)
+ (view-already-displayed (condition)
+ (other-window (window condition)))))
-(set-key `(com-switch-to-buffer ,*unsupplied-argument-marker*)
+(set-key `(com-switch-to-view ,*unsupplied-argument-marker*)
'pane-table
'((#\x :control) (#\b)))
-(define-command (com-kill-buffer :name t :command-table pane-table)
- ((buffer 'buffer
- :prompt "Kill buffer"
- :default (current-buffer)))
- "Prompt for a buffer name and kill that buffer.
-If the buffer needs saving, will prompt you to do so before killing it. Uses the current buffer as a default."
- (kill-buffer buffer))
+(define-command (com-kill-view :name t :command-table pane-table)
+ ((view 'view :prompt "Kill view"
+ :default (current-view)))
+ "Prompt for a view name and kill that view.
+If the view is of a buffer and the buffer needs saving, you will
+be prompted to do so before killing it. Uses the current view
+as a default."
+ (kill-view view))
-(set-key `(com-kill-buffer ,*unsupplied-argument-marker*)
+(set-key `(com-kill-view ,*unsupplied-argument-marker*)
'pane-table
'((#\x :control) (#\k)))
--- /project/climacs/cvsroot/climacs/groups.lisp 2007/11/16 09:29:47 1.5
+++ /project/climacs/cvsroot/climacs/groups.lisp 2007/12/08 08:55:06 1.6
@@ -30,7 +30,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
-;;; File/Buffer group classes.
+;;; File/View group classes.
(defclass group (name-mixin)
())
@@ -43,17 +43,17 @@
((%elements :initarg :elements :initform nil :reader elements))
(:documentation "Group class denoting a sequence of elements."))
-(defclass current-buffer-group (group)
+(defclass current-view-group (group)
()
(:documentation "Group class denoting the currently active
-buffer."))
+view."))
(defclass synonym-group (group)
((%other-name :initarg :other-name
- :initform (error "The name of another buffer must be provided")
- :reader other-name))
+ :initform (error "The name of another group must be provided")
+ :reader other-name))
(:documentation "Group class that forwards all methods to a
- group with a specific name."))
+group with a specific name."))
(defclass custom-group (group)
((%list-pathnames-lambda
@@ -75,14 +75,14 @@
;;;
;;; The group protocol.
-(defgeneric group-buffers (group)
- (:documentation "Get a list of buffers in `group'. Only already
-existing buffers will be returned, use `ensure-group-buffers' if
-you want all buffers defined by the group."))
+(defgeneric group-views (group)
+ (:documentation "Get a list of views in `group'. Only already
+existing views will be returned, use `ensure-group-views' if
+you want all views defined by the group."))
-(defgeneric ensure-group-buffers (group)
+(defgeneric ensure-group-views (group)
(:documentation "For each pathname in `group' that does not
-have a corresponding buffer, open a buffer for that pathname."))
+have a corresponding view, open a view for that pathname."))
(defgeneric select-group (group)
(:documentation "Tell the group object `group' that the user
@@ -98,7 +98,7 @@
(defgeneric display-group-contents (group stream)
(:documentation "Display the contents of `group' to
-`stream'. Basically, this should describe which buffers or files
+`stream'. Basically, this should describe which views or files
would be affected by group-aware commands if `group' was the
active group. There is no standard format for the output, but it
is intended for displaying to the user."))
@@ -109,14 +109,14 @@
;; Display helper functions.
(defun normalise-group-element (element)
- "Turn `element' into either a pathname, an existing buffer or
+ "Turn `element' into either a pathname, an existing view or
NIL. If a pathname is returned, it is assumed to be safe to find
the file with that name."
(typecase element
- (drei-buffer
- (find element (buffers *application-frame*)))
+ (drei-view
+ (find element (views *application-frame*)))
((or pathname string)
- (or (find-buffer-with-pathname (pathname element))
+ (or (find-view-with-pathname (pathname element))
(when (findablep element)
element)))
(group-element
@@ -125,27 +125,27 @@
(defun display-group-element (element stream)
(let ((norm-element (normalise-group-element element)))
(typecase norm-element
- (drei-buffer
- (present norm-element 'buffer stream))
+ (drei-view
+ (present norm-element 'view stream))
((or pathname string)
(present norm-element 'pathname stream)))))
;; Singular group elements.
-(defmethod group-buffers ((group group-element))
+(defmethod group-views ((group group-element))
(let ((element (element group)))
- (cond ((and (typep element 'drei-buffer)
- (find element (buffers *application-frame*)))
+ (cond ((and (typep element 'drei-view)
+ (find element (views *application-frame*)))
(list element))
((or (pathnamep element)
(stringp element))
- (let ((buffer (find-buffer-with-pathname (pathname element))))
- (when buffer (list buffer))))
+ (let ((view (find-view-with-pathname (pathname element))))
+ (when view (list view))))
(t '()))))
-(defmethod ensure-group-buffers ((group group-element))
+(defmethod ensure-group-views ((group group-element))
(typecase (element group)
- (drei-buffer
- (unless (find (element group) (buffers *application-frame*))
+ (drei-view
+ (unless (find (element group) (views *application-frame*))
(ensure-open-file (pathname (filepath (element group))))))
(pathname
(ensure-open-file (element group)))
@@ -156,31 +156,31 @@
(display-group-element (element group) stream))
;; Standard sequence groups.
-(defmethod group-buffers ((group standard-group))
- (apply #'append (mapcar #'group-buffers (elements group))))
+(defmethod group-views ((group standard-group))
+ (apply #'append (mapcar #'group-views (elements group))))
-(defmethod ensure-group-buffers ((group standard-group))
- (mapcar #'ensure-group-buffers (elements group)))
+(defmethod ensure-group-views ((group standard-group))
+ (mapcar #'ensure-group-views (elements group)))
(defmethod display-group-contents ((group standard-group) (stream extended-output-stream))
(present (remove-if #'null (mapcar #'normalise-group-element (elements group)))
- '(sequence (or pathname buffer)) :stream stream))
+ '(sequence (or pathname view)) :stream stream))
-;; The current buffer group (default).
-(defmethod group-buffers ((group current-buffer-group))
- (list (current-buffer)))
+;; The current view group (default).
+(defmethod group-views ((group current-view-group))
+ (list (current-view)))
-(defmethod ensure-group-buffers ((group current-buffer-group))
+(defmethod ensure-group-views ((group current-view-group))
nil)
-(defmethod display-group-contents ((group current-buffer-group) (stream extended-output-stream))
- (display-group-element (current-buffer) stream))
+(defmethod display-group-contents ((group current-view-group) (stream extended-output-stream))
+ (display-group-element (current-view) stream))
;; Custom groups.
-(defmethod group-buffers ((group custom-group))
- (remove-if #'null (mapcar #'find-buffer-with-pathname (funcall (pathname-lister group) group))))
+(defmethod group-views ((group custom-group))
+ (remove-if #'null (mapcar #'find-view-with-pathname (funcall (pathname-lister group) group))))
-(defmethod ensure-group-buffers ((group custom-group))
+(defmethod ensure-group-views ((group custom-group))
(mapcar #'ensure-open-file (funcall (pathname-lister group) group)))
(defmethod select-group ((group custom-group))
@@ -189,7 +189,7 @@
(defmethod display-group-contents ((group custom-group) (stream extended-output-stream))
(present (remove-if #'null (mapcar #'normalise-group-element (funcall (pathname-lister group) group)))
- '(sequence (or pathname buffer)) :stream stream))
+ '(sequence (or pathname view)) :stream stream))
;; Synonym groups.
@@ -203,14 +203,14 @@
group is unable to find the group that it is supposed to
forward method invocations to."))
-(defmethod group-buffers ((group synonym-group))
+(defmethod group-views ((group synonym-group))
(if (get-group (other-name group))
- (group-buffers (get-group (other-name group)))
+ (group-views (get-group (other-name group)))
(error 'group-not-found :group-name (other-name group))))
-(defmethod ensure-group-buffers ((group synonym-group))
+(defmethod ensure-group-views ((group synonym-group))
(if (get-group (other-name group))
- (ensure-group-buffers (get-group (other-name group)))
+ (ensure-group-views (get-group (other-name group)))
(error 'group-not-found :group-name (other-name group))))
(defmethod select-group ((group synonym-group))
@@ -242,7 +242,7 @@
(defun add-group (name elements)
"Define a group called `name' (a string) containing the elements `elements',
-which must be a list of pathnames and/or buffers, and add it to
+which must be a list of pathnames and/or views, and add it to
the list of defined groups."
(setf (gethash name (groups *application-frame*))
(make-instance
@@ -263,30 +263,30 @@
(defun deselect-group ()
"Deselect the currently active group."
(setf (active-group *application-frame*)
- (make-instance 'current-buffer-group
+ (make-instance 'current-view-group
:name "none")))
-(defmacro with-group-buffers ((buffers group &key keep) &body body)
+(defmacro with-group-views ((views group &key keep) &body body)
"Make sure that all files designated by `group' are open in
-buffers during the evaluation of `body'. If `keep' is NIL, all
-buffers created by this macro will be saved and killed after
-`body' has run. Also, `buffers' will be bound to a list of the
-buffers containing the files designated by `group' while `body'
+views during the evaluation of `body'. If `keep' is NIL, all
+views created by this macro will be saved and killed after
+`body' has run. Also, `views' will be bound to a list of the
+views containing the files designated by `group' while `body'
is run."
- (with-gensyms (buffers-before buffers-after buffer-diff)
+ (with-gensyms (views-before views-after view-diff)
(once-only (group keep)
- `(let ((,buffers-before (buffers *application-frame*))
+ `(let ((,views-before (views *application-frame*))
(,group ,group))
- (ensure-group-buffers ,group)
- (let* ((,buffers-after (buffers *application-frame*))
- (,buffer-diff (set-difference ,buffers-after
- ,buffers-before))
- (,buffers (group-buffers ,group)))
+ (ensure-group-views ,group)
+ (let* ((,views-after (views *application-frame*))
+ (,view-diff (set-difference ,views-after
+ ,views-before))
+ (,views (group-views ,group)))
(unwind-protect (progn , at body)
(unless ,keep
- (loop for buffer in ,buffer-diff
- do (save-buffer buffer)
- do (kill-buffer buffer)))))))))
+ (loop for view in ,view-diff
+ do (save-view view)
+ do (kill-view view)))))))))
(defmacro define-group (name (group-arg &rest args) &body body)
"Define a persistent group named `name'. `Body' should return a
@@ -317,13 +317,13 @@
(define-group "Current Directory Files" (group)
(declare (ignore group))
- (directory (make-pathname :directory (pathname-directory (filepath (current-buffer)))
+ (directory (make-pathname :directory (pathname-directory (filepath (current-view)))
:name :wild
:type :wild)))
(define-group "Directory Files" (group (directory (accept 'pathname
:prompt "Directory"
- :default (directory-of-buffer (current-buffer))
+ :default (directory-of-buffer (buffer (current-view)))
:insert-default t)))
(declare (ignore group))
(directory (make-pathname :directory (pathname-directory directory)
@@ -332,7 +332,7 @@
(define-group "Directory Lisp Files" (group (directory (accept 'pathname
:prompt "Directory"
- :default (directory-of-buffer (current-buffer))
+ :default (directory-of-buffer (buffer (current-view)))
:insert-default t)))
(declare (ignore group))
(directory (make-pathname :directory (pathname-directory directory)
@@ -380,9 +380,34 @@
;;;
;;; Now hook it all up.
+(defclass group-target-specification (view-list-target-specification)
+ ((%group :initarg :group
+ :reader group
+ :initform (error "A group must be provided for a group target specification")))
+ (:documentation "The target-specification class used for groups
+in Climacs."))
+
+(defmethod activate-target-specification ((spec group-target-specification))
+ (ensure-group-views (group spec))
+ (setf (views spec) (group-views (group spec)))
+ (call-next-method))
+
+(defmethod next-target :around ((spec group-target-specification))
+ (handler-bind ((view-already-displayed
+ #'(lambda (c)
+ (declare (ignore c))
+ (invoke-restart 'remove-other-use))))
+ (call-next-method)))
+
+(defmethod previous-target :around ((spec group-target-specification))
+ (handler-bind ((view-already-displayed
+ #'(lambda (c)
+ (declare (ignore c))
+ (invoke-restart 'remove-other-use))))
+ (call-next-method)))
+
(setf *climacs-target-creator*
#'(lambda (drei)
- (ensure-group-buffers (get-active-group))
- (make-instance 'buffer-list-target-specification
- :buffers (group-buffers (get-active-group))
- :drei-instance drei)))
+ (make-instance 'group-target-specification
+ :group (get-active-group)
+ :drei-instance drei)))
--- /project/climacs/cvsroot/climacs/gui.lisp 2007/11/20 12:59:54 1.239
+++ /project/climacs/cvsroot/climacs/gui.lisp 2007/12/08 08:55:06 1.240
@@ -42,7 +42,7 @@
(defvar *climacs-target-creator* nil
"A function for creating targets for commands potentially
-acting over multiple buffers.")
+acting over multiple views.")
(defclass climacs-buffer (drei-buffer)
((%external-format :initform *default-external-format*
@@ -54,23 +54,75 @@
(defclass climacs-pane (drei-pane esa-pane-mixin)
()
(:default-initargs
- :buffer (make-instance 'climacs-buffer)
- :command-table (find-command-table 'global-climacs-table)
- :width 900 :height 400))
-
-;; Ensure that only one pane can be active.
-(defmethod (setf active) :after ((new-val (eql t)) (climacs-pane climacs-pane))
- (mapcar #'(lambda (pane)
- (unless (eq climacs-pane pane)
- (setf (active pane) nil)))
- (windows (pane-frame climacs-pane))))
-
-(defmethod (setf buffer) :before ((buffer climacs-buffer) (pane climacs-pane))
- (with-accessors ((buffers buffers)) *application-frame*
- (unless (member buffer buffers)
- (error "Attempting to switch to a buffer not known to Climacs"))
- (setf buffers (delete buffer buffers))
- (push buffer buffers)
+ :view (make-instance 'textual-drei-syntax-view
+ :buffer (make-instance 'climacs-buffer))
+ :command-table (find-command-table 'global-climacs-table)
+ :width 900 :height 400))
+
+(define-condition view-setting-error (error)
+ ((%view :accessor view
+ :initarg :view
+ :initform (error "The view used in the error-causing operation must be supplied")
+ :documentation "The view that is attempted set"))
+ (:documentation "This error is signalled when something goes
+wrong while setting the view of a Climacs pane."))
+
+(define-condition unknown-view (view-setting-error)
+ ()
+ (:report (lambda (condition stream)
+ (format
+ stream "Attempting to set view of a window to view object ~A, which is not known to Climacs"
+ (view condition))))
+ (:documentation "This error is signalled whenever a window is
+attempted to be set to a view that is not recognized by the
+Climacs instance the window belongs to."))
+
+(define-condition view-already-displayed (view-setting-error)
+ ((%window :accessor window
+ :initarg :window
+ :initform (error "The window already displaying the view must be provided")
+ :documentation "The window that already displays the view"))
+ (:report (lambda (condition stream)
+ (format
+ stream "Attempting to set view of a window to view object ~A, which is already on display in another window"
+ (view condition))))
+ (:documentation "This error is signalled whenever a window is
+attempted to be set to a view already on display in some other
+window"))
+
+(defmethod (setf view) :around ((view drei-view) (pane climacs-pane))
+ (let ((window-displaying-view
+ (find-if #'(lambda (other-pane)
+ (and (not (eq other-pane pane))
+ (eq (view other-pane) view)))
+ (windows (pane-frame pane)))))
+ (cond ((not (member view (views (pane-frame pane))))
+ (restart-case (error 'unknown-view :view view)
+ (add-to-view-list ()
+ :report "Add the view object to Climacs"
+ (push view (views (pane-frame pane)))
+ (setf (view pane) view))))
+ (window-displaying-view
+ (restart-case
+ (error 'view-already-displayed :view view :window window-displaying-view)
+ (remove-other-use ()
+ :report "Make the other window try to display some other view"
+ (setf (view window-displaying-view) (any-preferably-undisplayed-view))
+ (setf (view pane) view))
+ (remove-other-pane ()
+ :report "Remove the other window displaying the view"
+ (delete-window window-displaying-view)
+ (setf (view pane) view))
+ (clone-view ()
+ :report "Make a clone of the view and use that instead"
+ (setf (view pane) (clone-view-for-climacs
+ (pane-frame window-displaying-view) view)))
+ (cancel ()
+ :report "Cancel the setting of the windows view and just return")))
+ (t (call-next-method)))))
+
+(defmethod (setf view) :before ((view drei-view) (pane climacs-pane))
+ (with-accessors ((views views)) (pane-frame pane)
(full-redisplay pane)))
(defmethod command-table ((drei climacs-pane))
@@ -121,7 +173,7 @@
()
(:default-initargs
:height 20 :max-height 20 :min-height 20
- :default-view +drei-textual-view+
+ :default-view +textual-view+
:background *mini-bg-color*
:foreground *mini-fg-color*
:width 900))
@@ -174,7 +226,7 @@
(define-application-frame climacs (esa-frame-mixin
standard-application-frame)
- ((%buffers :initform '() :accessor buffers)
+ ((%views :initform '() :accessor views)
(%groups :initform (make-hash-table :test #'equal) :accessor groups)
(%active-group :initform nil :accessor active-group)
(%kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring)
@@ -197,12 +249,12 @@
(:menu-bar nil)
(:panes
(climacs-window
- (let* ((climacs-pane (make-pane 'climacs-pane
- :active t))
+ (let* ((*esa-instance* *application-frame*)
+ (climacs-pane (make-pane 'climacs-pane :active t))
(info-pane (make-pane 'climacs-info-pane
:master-pane climacs-pane)))
(setf (windows *application-frame*) (list climacs-pane)
- (buffers *application-frame*) (list (buffer climacs-pane)))
+ (views *application-frame*) (list (view climacs-pane)))
(vertically ()
(if *with-scrollbars*
(scrolling ()
@@ -223,19 +275,112 @@
command-unparser
partial-command-parser
prompt)
- :bindings ((*previous-command* (previous-command (current-window)))
- (*default-target-creator* *climacs-target-creator*)))
+ :bindings ((*default-target-creator* *climacs-target-creator*)
+ (*drei-instance* (esa-current-window frame))
+ (*previous-command* (previous-command *drei-instance*))))
(defmethod frame-standard-input ((frame climacs))
(get-frame-pane frame 'minibuffer))
+(defmethod buffers ((climacs climacs))
+ (remove-duplicates
+ (mapcar #'buffer (remove-if-not
+ #'(lambda (view)
+ (typep view 'drei-buffer-view))
+ (views climacs)))))
+
(defmethod esa-current-buffer ((application-frame climacs))
- "Return the current buffer."
- (buffer (esa-current-window application-frame)))
+ (buffer (current-view (esa-current-window application-frame))))
-(defun any-buffer ()
- "Return some buffer, any buffer, as long as it is a buffer!"
- (first (buffers *application-frame*)))
+(defmethod (setf esa-current-buffer) ((new-buffer climacs-buffer)
+ (application-frame climacs))
+ (setf (buffer (current-view (esa-current-window application-frame)))
+ new-buffer))
+
+(defmethod (setf views) :around (new-value (frame climacs))
+ ;; If any windows show a view that no longer exists in the
+ ;; view-list, make them show something else. The view-list might be
+ ;; destructively updated, so copy it for safekeeping.
+ (with-accessors ((views views)) frame
+ (let* ((old-views (copy-list views))
+ (removed-views (set-difference
+ old-views (call-next-method) :test #'eq)))
+
+ (dolist (window (windows frame))
+ (when (member (view window) removed-views :test #'eq)
+ (handler-case (setf (view window)
+ (any-preferably-undisplayed-view))
+ (view-already-displayed ()
+ (delete-window window)))))
+ ;; If the active view was removed, we have to designate a new
+ ;; active view.
+ (if (find-if #'active removed-views)
+ (activate-view frame (any-displayed-view))
+ ;; Else, we just have to make sure that the active view is
+ ;; still number one in the list.
+ (let ((active-view (find-if #'active views)))
+ (unless (eq active-view (first views))
+ (setf views (cons active-view (delete active-view views)))))))))
+
+(defmethod (setf views) :after ((new-value null) (frame climacs))
+ ;; You think you can remove all views? I laught at your silly
+ ;; attempt!
+ (setf (views frame) (list (make-new-view-for-climacs
+ frame 'textual-drei-syntax-view))))
+
+(defmethod (setf windows) :after (new-value (frame climacs))
+ ;; It may be that the window holding the active view has been
+ ;; removed, if so, we must activate another view.
+ (activate-view frame (any-displayed-view)))
+
+(defun make-view-subscript-generator (climacs)
+ #'(lambda (name)
+ (1+ (reduce #'max (remove name (views climacs)
+ :test-not #'string= :key #'name)
+ :initial-value 0
+ :key #'subscript))))
+
+(defun clone-view-for-climacs (climacs view &rest initargs)
+ "Clone `view' and add it to `climacs's list of views."
+ (let ((new-view (apply #'clone-view view
+ :subscript-generator (make-view-subscript-generator climacs)
+ :active nil :syntax (make-syntax-for-view view (class-of (syntax view)))
+ initargs)))
+ (push new-view (views climacs))
+ new-view))
+
+(defun make-new-view-for-climacs (climacs view-class &rest initargs)
+ "Instiantiate an object of type `view-class' and add it to
+`climacs's list of views."
+ (let ((new-view (apply #'make-instance view-class
+ :subscript-generator (make-view-subscript-generator climacs)
+ initargs)))
+ (push new-view (views climacs))
+ new-view))
+
+(defun any-view ()
+ "Return some view, any view."
+ (first (views *esa-instance*)))
+
+(defun any-displayed-view ()
+ "Return some view on display."
+ (view (first (windows *application-frame*))))
+
+(defun any-preferably-undisplayed-view ()
+ "Return some view, any view, preferable one that is not
+currently displayed in any window."
+ (or (find-if #'(lambda (view)
+ (not (member view (windows *esa-instance*) :key #'view)))
+ (views *esa-instance*))
+ (any-view)))
+
+(defun any-undisplayed-view ()
+ "Return some view, any view, as long as it is not currently
+displayed in any window. If necessary, clone a view on display."
+ (or (find-if #'(lambda (view)
+ (not (member view (windows *esa-instance*) :key #'view)))
+ (views *esa-instance*))
+ (clone-view-for-climacs *esa-instance* (any-view))))
(define-presentation-type read-only ())
(define-presentation-method highlight-presentation
@@ -248,30 +393,30 @@
(defun display-info (frame pane)
(let* ((master-pane (master-pane pane))
- (buffer (buffer master-pane))
- (size (size buffer))
- (top (top master-pane))
- (bot (bot master-pane))
- (point (point master-pane)))
+ (view (view master-pane))
+ (size (size (buffer view)))
+ (top (top view))
+ (bot (bot view))
+ (point (point view)))
(princ " " pane)
- (with-output-as-presentation (pane buffer 'read-only)
+ (with-output-as-presentation (pane view 'read-only)
(princ (cond
- ((read-only-p buffer) "%")
- ((needs-saving buffer) "*")
+ ((read-only-p (buffer view)) "%")
+ ((needs-saving (buffer view)) "*")
(t "-"))
pane))
- (with-output-as-presentation (pane buffer 'modified)
+ (with-output-as-presentation (pane view 'modified)
(princ (cond
- ((needs-saving buffer) "*")
- ((read-only-p buffer) "%")
+ ((needs-saving (buffer view)) "*")
+ ((read-only-p (buffer view)) "%")
(t "-"))
pane))
(princ " " pane)
(with-text-face (pane :bold)
- (with-output-as-presentation (pane buffer 'buffer)
- (format pane "~A" (name buffer)))
+ (with-output-as-presentation (pane view 'view)
+ (format pane "~A" (subscripted-name view)))
;; FIXME: bare 25.
- (format pane "~V at T" (max (- 25 (length (name buffer))) 1)))
+ (format pane "~V at T" (max (- 25 (length (subscripted-name view))) 1)))
(format pane " ~A "
(cond ((and (mark= size bot)
(mark= 0 top))
@@ -284,16 +429,16 @@
(round (* 100 (/ (offset top)
size)))))))
(when *show-info-pane-mark-position*
- (format pane "(~A,~A) "
- (1+ (line-number point))
- (column-number point)))
+ (format pane "(~A,~A) "
+ (1+ (line-number point))
+ (column-number point)))
(with-text-family (pane :sans-serif)
(princ #\( pane)
- (display-syntax-name (syntax buffer) pane :pane (master-pane pane))
+ (display-syntax-name (syntax view) pane :view view)
(format pane "~{~:[~*~; ~A~]~}" (list
- (slot-value master-pane 'overwrite-mode)
+ (overwrite-mode view)
"Ovwrt"
- (auto-fill-mode master-pane)
+ (auto-fill-mode view)
"Fill"
(isearch-mode master-pane)
"Isearch"))
@@ -309,24 +454,11 @@
(display-drei drei))
(defmethod execute-frame-command :around ((frame climacs) command)
- (let ((*drei-instance* (esa-current-window frame)))
- (if (eq frame *application-frame*)
- (progn
- (handling-drei-conditions
- (with-undo ((buffers frame))
- (call-next-method)))
- (loop for buffer in (buffers frame)
- do (when (modified-p buffer)
- (clear-modify buffer))))
- (call-next-method))))
-
-(defmethod execute-frame-command :after ((frame climacs) command)
- (when (eq frame *application-frame*)
- (loop for buffer in (buffers frame)
- do (when (syntax buffer)
- (update-syntax buffer (syntax buffer)))
- do (when (modified-p buffer)
- (setf (needs-saving buffer) t)))))
+ (if (eq frame *esa-instance*)
+ (handling-drei-conditions
+ (with-undo ((buffers frame))
+ (call-next-method)))
+ (call-next-method)))
(define-command (com-full-redisplay :name t :command-table base-table) ()
"Redisplay the contents of the current window.
@@ -337,6 +469,14 @@
'base-table
'((#\l :control)))
+(defun activate-view (climacs active-view)
+ "Set `view' to be the active view for `climacs'."
+ ;; Ensure that only one pane can be active.
+ (dolist (view (views climacs))
+ (unless (eq active-view view)
+ (setf (active view) nil)))
+ (setf (active active-view) t))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Pane functions
@@ -404,33 +544,36 @@
:master-pane climacs-pane))))
(values vbox climacs-pane)))
-(defgeneric setup-split-pane (orig-pane new-pane)
+(defgeneric setup-split-pane (orig-pane new-pane clone-view)
(:documentation "Perform split-setup operations `new-pane',
which is supposed to be a pane that has been freshly split from
-`orig-pane'."))
-
-(defmethod setup-split-pane ((orig-pane climacs-pane) (new-pane climacs-pane))
- (setf (offset (point (buffer orig-pane))) (offset (point orig-pane))
- (buffer new-pane) (buffer orig-pane)
- (auto-fill-mode new-pane) (auto-fill-mode orig-pane)
- (auto-fill-column new-pane) (auto-fill-column orig-pane)))
-
-(defmethod setup-split-pane ((orig-pane typeout-pane) (new-pane climacs-pane))
- (setf (buffer new-pane) (any-buffer)))
+`orig-pane'. If `clone-view' is true, set the view of the new
+pane to a clone of the view in `orig-pane', provided that
+`orig-pane' has a view."))
+
+(defmethod setup-split-pane ((orig-pane climacs-pane) (new-pane climacs-pane) clone-view)
+ (setf (offset (point (buffer (view orig-pane)))) (offset (point (view orig-pane)))
+ (view new-pane) (if clone-view
+ (clone-view-for-climacs (pane-frame orig-pane) (view orig-pane))
+ (any-preferably-undisplayed-view))))
+
+(defmethod setup-split-pane ((orig-pane typeout-pane) (new-pane climacs-pane) clone-view)
[86 lines skipped]
--- /project/climacs/cvsroot/climacs/java-syntax-commands.lisp 2007/11/20 12:59:54 1.2
+++ /project/climacs/cvsroot/climacs/java-syntax-commands.lisp 2007/12/08 08:55:06 1.3
@@ -58,26 +58,18 @@
()
"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* ((token (form-around (current-syntax) (offset (point))))
+ (fill-column (auto-fill-column (current-view))))
(when (typep token 'string-form)
- (with-accessors ((offset1 start-offset)
+ (with-accessors ((offset1 start-offset)
(offset2 end-offset)) token
- (fill-region (make-instance 'standard-right-sticky-mark
- :buffer implementation
- :offset offset1)
- (make-instance 'standard-right-sticky-mark
- :buffer implementation
- :offset offset2)
+ (fill-region (make-buffer-mark (current-buffer) offset1 :right)
+ (make-buffer-mark (current-buffer) offset2 :right)
#'(lambda (mark)
- (syntax-line-indentation mark tab-width syntax))
+ (syntax-line-indentation
+ mark (tab-space-count (current-view)) syntax))
fill-column
- tab-width
+ (tab-space-count (current-view))
syntax
t)))))
--- /project/climacs/cvsroot/climacs/java-syntax.lisp 2007/06/04 22:34:44 1.4
+++ /project/climacs/cvsroot/climacs/java-syntax.lisp 2007/12/08 08:55:06 1.5
@@ -762,9 +762,10 @@
collect (form-string syntax component) into components
finally (setf (package-of syntax) components)))))
-;;; TODO: conditionalise this
-(defmethod update-syntax :after (buffer (syntax java-syntax))
- (update-package-name buffer syntax))
+(defmethod update-syntax :after ((syntax java-syntax) prefix-size suffix-size
+ &optional begin end)
+ (declare (ignore begin end))
+ (update-package-name (buffer syntax) syntax))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -775,130 +776,72 @@
`syntax'."
(buffer-substring (buffer syntax) (start-offset form) (end-offset form)))
-(defvar *white-space-start* nil)
+(define-standard-faces java-syntax
+ (make-face :error +red+)
+ (make-face :string +rosy-brown+ (make-text-style nil :italic nil))
+ (make-face :operator +orchid+)
+ (make-face :basic-type +dark-blue+)
+ (make-face :modifier +dark-green+)
+ (make-face :comment +maroon+)
+ (make-face :number +gray50+))
-(defvar *current-line* 0)
-
-(defparameter *current-faces*
- `((:error ,+red+ nil)
- (:string ,+rosy-brown+ ,(make-text-style nil :italic nil))
- (:operator ,+orchid+ nil)
- (:basic-type ,+dark-blue+ nil)
- (:modifier ,+dark-green+ nil)
- (:comment ,+maroon+ nil)
- (:number ,+gray50+ nil)))
-
-(defun face-colour (type)
- (first (cdr (assoc type *current-faces*))))
-
-(defun face-style (type)
- (second (cdr (assoc type *current-faces*))))
-
-(defmacro with-face ((face &optional (stream-symbol 'stream)) &body body)
- `(with-drawing-options (,stream-symbol :ink (face-colour ,face)
- :text-style (face-style ,face))
- , at body))
-
-(defun handle-whitespace (pane buffer start end)
- (let ((space-width (space-width pane))
- (tab-width (tab-width pane)))
- (with-sheet-medium (medium pane)
- (with-accessors ((cursor-positions cursor-positions)) (syntax buffer)
- (loop while (< start end)
- do (case (buffer-object buffer start)
- (#\Newline (record-line-vertical-offset pane (syntax buffer) (incf *current-line*))
- (terpri pane)
- (stream-increment-cursor-position
- pane (first (aref cursor-positions 0)) 0))
- ((#\Page #\Return #\Space) (stream-increment-cursor-position
- pane space-width 0))
- (#\Tab (when (plusp tab-width)
- (let ((x (stream-cursor-position pane)))
- (stream-increment-cursor-position
- pane (- tab-width (mod x tab-width)) 0)))))
- (incf start))))))
-
-(defgeneric display-parse-tree (parse-symbol stream drei syntax)
- (:documentation "Display the given parse-symbol on the supplied
- stream, assuming `drei' to be the relevant Drei instance and
- `syntax' being the syntax object responsible for the parse
- symbol."))
-
-(defmethod display-parse-tree ((parse-symbol (eql nil)) stream (drei drei)
+(defmethod display-parse-tree ((parse-symbol (eql nil)) stream (view textual-drei-syntax-view)
(syntax java-syntax))
nil)
-(defmethod display-parse-tree :around (parse-symbol stream (drei drei)
- (syntax java-syntax))
- (with-slots (top bot) drei
- (when (and (start-offset parse-symbol)
- (mark< (start-offset parse-symbol) bot)
- (mark> (end-offset parse-symbol) top))
- (call-next-method))))
-
-(defmethod display-parse-tree (parse-symbol stream (drei drei)
- (syntax java-syntax))
- (with-slots (top bot) drei
- (loop for child in (children parse-symbol)
- when (and (start-offset child)
- (mark> (end-offset child) top))
- do (if (mark< (start-offset child) bot)
- (display-parse-tree child stream drei syntax)
- (return)))))
-
-(defmethod display-parse-tree ((parse-symbol error-symbol) stream (drei drei)
+(defmethod display-parse-tree ((parse-symbol error-symbol) stream (view textual-drei-syntax-view)
(syntax java-syntax))
(let ((children (children parse-symbol)))
(loop until (or (null (cdr children))
(typep (parser-state (cadr children)) 'error-state))
- do (display-parse-tree (pop children) stream drei syntax))
+ do (display-parse-tree (pop children) stream view syntax))
(if (and (null (cdr children))
(not (typep (parser-state parse-symbol) 'error-state)))
- (display-parse-tree (car children) stream drei syntax)
+ (display-parse-tree (car children) stream view syntax)
(with-face (:error)
(loop for child in children
- do (display-parse-tree child stream drei syntax))))))
+ do (display-parse-tree child stream view syntax))))))
-(defmethod display-parse-tree ((parse-symbol error-lexeme) stream (drei drei) (syntax java-syntax))
+(defmethod display-parse-tree ((parse-symbol error-lexeme) stream (view textual-drei-syntax-view) (syntax java-syntax))
(with-face (:error)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol integer-literal-lexeme)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:number)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol floating-point-literal-lexeme)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:number)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol basic-type)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:basic-type)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol modifier)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:modifier)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol operator)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:operator)
(call-next-method)))
-(defmethod display-parse-tree ((parser-symbol java-lexeme) stream (drei drei)
+(defmethod display-parse-tree ((parser-symbol java-lexeme) stream (view textual-drei-syntax-view)
(syntax java-syntax))
(flet ((cache-test (t1 t2)
(and (eq t1 t2)
@@ -908,7 +851,7 @@
(text-style-face
(medium-text-style (sheet-medium stream)))))))
(updating-output
- (stream :unique-id (list drei parser-symbol)
+ (stream :unique-id (list view parser-symbol)
:id-test #'equal
:cache-value parser-symbol
:cache-test #'cache-test)
@@ -917,17 +860,9 @@
face (text-style-face (medium-text-style (sheet-medium stream))))
(write-string (form-string syntax parser-symbol) stream)))))
-(defmethod display-parse-tree :before ((parse-symbol java-lexeme)
- stream
- (drei drei)
- (syntax java-syntax))
- (handle-whitespace stream (buffer drei)
- *white-space-start* (start-offset parse-symbol))
- (setf *white-space-start* (end-offset parse-symbol)))
-
(defmethod display-parse-tree ((parse-symbol character-literal-lexeme)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:string)
(call-next-method)))
@@ -935,84 +870,67 @@
(defmethod display-parse-tree ((parse-symbol
incomplete-character-literal-lexeme)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:string)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol boolean-literal-lexeme)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:operator)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol null-literal-lexeme)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:operator)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol complete-string-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(let ((children (children parse-symbol)))
(if (third children)
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)
+ (display-parse-tree (pop children) stream view syntax)
(loop until (null (cdr children))
- do (display-parse-tree (pop children) stream drei syntax))
- (display-parse-tree (pop children) stream drei syntax))
+ do (display-parse-tree (pop children) stream view syntax))
+ (display-parse-tree (pop children) stream view syntax))
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)
- (display-parse-tree (pop children) stream drei syntax)))))
+ (display-parse-tree (pop children) stream view syntax)
+ (display-parse-tree (pop children) stream view syntax)))))
(defmethod display-parse-tree ((parse-symbol incomplete-string-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(let ((children (children parse-symbol)))
(if (second children)
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)
+ (display-parse-tree (pop children) stream view syntax)
(loop until (null children)
- do (display-parse-tree (pop children) stream drei syntax)))
+ do (display-parse-tree (pop children) stream view syntax)))
(with-face (:string)
- (display-parse-tree (pop children) stream drei syntax)))))
+ (display-parse-tree (pop children) stream view syntax)))))
(defmethod display-parse-tree ((parse-symbol line-comment-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:comment)
(call-next-method)))
(defmethod display-parse-tree ((parse-symbol long-comment-form)
stream
- (drei drei)
+ (view textual-drei-syntax-view)
(syntax java-syntax))
(with-face (:comment)
(call-next-method)))
-(defmethod display-drei-contents ((stream clim-stream-pane)
- (drei drei)
- (syntax java-syntax))
- (with-slots (top bot) drei
- (with-accessors ((cursor-positions cursor-positions)) syntax
- ;; There must always be room for at least one element of line
- ;; information.
- (setf cursor-positions (make-array (1+
- (number-of-lines-in-region top bot))
- :initial-element nil)
- *current-line* 0
- (aref cursor-positions 0) (multiple-value-list
- (stream-cursor-position stream))))
- (setf *white-space-start* (offset top)))
- (with-slots (stack-top) syntax
- (display-parse-tree stack-top stream drei syntax)))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; exploit the parse
--- /project/climacs/cvsroot/climacs/misc-commands.lisp 2007/11/20 12:59:54 1.28
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2007/12/08 08:55:06 1.29
@@ -33,7 +33,7 @@
The modified flag is automatically set when the contents
of the buffer are changed. This flag is consulted, for instance,
when deciding whether to prompt you to save the buffer before killing it."
- (setf (needs-saving (buffer (current-window))) nil))
+ (setf (needs-saving (current-buffer)) nil))
(set-key 'com-not-modified
'buffer-table
@@ -75,7 +75,7 @@
:prompt "Name of syntax"))
"Prompts for a syntax to set for the current buffer.
Setting a syntax will cause the buffer to be reparsed using the new syntax."
- (set-syntax (current-buffer) syntax))
+ (set-syntax (current-view) syntax))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -83,10 +83,10 @@
(define-command (com-define-group :name t :command-table global-climacs-table)
((name 'string :prompt "Name")
- (buffers '(sequence drei-buffer) :prompt "Buffers"))
+ (views '(sequence view) :prompt "Views"))
(when (or (not (get-group name))
(accept 'boolean :prompt "Group already exists. Overwrite existing group?"))
- (add-group name buffers))
+ (add-group name views))
(select-group (get-group name)))
(set-key `(com-define-group ,*unsupplied-argument-marker* ,*unsupplied-argument-marker*)
--- /project/climacs/cvsroot/climacs/packages.lisp 2007/11/16 09:29:47 1.126
+++ /project/climacs/cvsroot/climacs/packages.lisp 2007/12/08 08:55:06 1.127
@@ -40,13 +40,24 @@
#:climacs-info-pane
#:typeout-pane
#:kill-ring
-
+
+ ;; View-stuff
+ #:views
+ #:view-setting-error #:view
+ #:unknown-view
+ #:view-already-displayed #:window
+ #:remove-other-use #:remove-other-pane #:clone-view #:cancel
+ #:any-view #:any-undisplayed-view
+ #:clone-view-for-climacs
+ #:make-new-view-for-climacs
+
;; GUI functions follow.
- #:any-buffer
+
#:point
#:syntax
#:mark
#:buffers
+
#:active-group
#:groups
#:display-window
@@ -55,6 +66,7 @@
#:delete-window
#:other-window
#:buffer-pane-p
+
;; Some configuration variables
#:*bg-color*
@@ -85,11 +97,11 @@
#:no-upper-p
#:case-relevant-test
- #:switch-to-buffer
+ #:switch-to-view
#:make-new-buffer
#:make-new-named-buffer
#:erase-buffer
- #:kill-buffer
+ #:kill-view
#:filepath-filename
#:update-attribute-line
@@ -113,11 +125,11 @@
#:get-group
#:get-active-group
#:deselect-group
- #:with-group-buffers
+ #:with-group-views
#:define-group
#:group-not-found
- #:group-buffers
- #:ensure-group-buffers
+ #:group-views
+ #:ensure-group-views
#:select-group
#:display-group-contents)
(:documentation "Package for editor functionality that is
@@ -127,7 +139,7 @@
application, but are not solely GUI-specific."))
(defpackage :climacs-commands
- (:use :clim-lisp :clim :drei-base :drei-buffer
+ (:use :clim-lisp :clim :esa-utils :drei-base :drei-buffer
:drei-syntax :drei-motion :drei-editing
:climacs-gui :esa :drei-kill-ring :drei
:drei-abbrev :drei-undo :climacs-core :drei-core)
--- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/11/12 16:06:06 1.16
+++ /project/climacs/cvsroot/climacs/search-commands.lisp 2007/12/08 08:55:06 1.17
@@ -58,12 +58,13 @@
(multiple-query-replace strings)))
(define-command (com-multiple-query-replace-from-buffer :name t :command-table search-table)
- ((buffer 'buffer :prompt "Buffer with Query Repace strings"))
- (unless (member buffer (buffers *application-frame*))
+ ((view 'view :prompt "View with Query Repace strings"))
+ (unless (member view (views *esa-instance*))
(beep)
- (display-message "~A not an existing buffer" (name buffer))
+ (display-message "~A not an existing buffer" (name view))
(return-from com-multiple-query-replace-from-buffer nil))
- (let* ((contents (buffer-substring buffer 0 (1- (size buffer))))
+ (let* ((buffer (buffer view))
+ (contents (buffer-substring buffer 0 (1- (size buffer))))
(strings (loop with length = (length contents)
with index = 0
with start = 0
@@ -102,22 +103,21 @@
(re (format nil "~{~A~^|~}" search-strings)))
(declare (special occurrences re))
(when strings
- (let* ((pane (current-window))
- (point (point pane))
+ (let* ((point (point))
(found (multiple-query-replace-find-next-match point re search-strings)))
(when found
- (setf (query-replace-state pane)
+ (setf (query-replace-state (current-window))
(make-instance 'query-replace-state
- :string1 found
- :string2 (cdr (assoc found strings :test #'string=)))
- (query-replace-mode pane)
+ :string1 found
+ :string2 (cdr (assoc found strings :test #'string=)))
+ (query-replace-mode (current-window))
t)
(display-message "Replace ~A with ~A: "
- (string1 (query-replace-state pane))
- (string2 (query-replace-state pane)))
+ (string1 (query-replace-state (current-window)))
+ (string2 (query-replace-state (current-window))))
(simple-command-loop 'multiple-query-replace-drei-table
- (query-replace-mode pane)
- ((setf (query-replace-mode pane) nil))))))
+ (query-replace-mode (current-window))
+ ((setf (query-replace-mode (current-window)) nil))))))
(display-message "Replaced ~D occurrence~:P" occurrences)))
(define-command (com-multiple-query-replace-replace
@@ -125,9 +125,8 @@
:command-table multiple-query-replace-drei-table)
()
(declare (special strings occurrences re))
- (let* ((pane (current-window))
- (point (point pane))
- (state (query-replace-state pane))
+ (let* ((point (point (current-view)))
+ (state (query-replace-state (current-window)))
(string1 (string1 state))
(string1-length (length string1)))
(backward-object point string1-length)
@@ -137,14 +136,14 @@
point
re
(mapcar #'car strings))))
- (cond ((null found) (setf (query-replace-mode pane) nil))
- (t (setf (query-replace-state pane)
+ (cond ((null found) (setf (query-replace-mode (current-window)) nil))
+ (t (setf (query-replace-state (current-window))
(make-instance 'query-replace-state
:string1 found
:string2 (cdr (assoc found strings :test #'string=))))
(display-message "Replace ~A with ~A: "
- (string1 (query-replace-state pane))
- (string2 (query-replace-state pane))))))))
+ (string1 (query-replace-state (current-window)))
+ (string2 (query-replace-state (current-window)))))))))
(define-command (com-multiple-query-replace-replace-and-quit
@@ -152,25 +151,23 @@
:command-table multiple-query-replace-drei-table)
()
(declare (special strings occurrences))
- (let* ((pane (current-window))
- (point (point pane))
- (state (query-replace-state pane))
+ (let* ((point (point))
+ (state (query-replace-state (current-window)))
(string1 (string1 state))
(string1-length (length string1)))
(backward-object point string1-length)
(replace-one-string point string1-length (string2 state) (no-upper-p string1))
(incf occurrences)
- (setf (query-replace-mode pane) nil)))
+ (setf (query-replace-mode (current-window)) nil)))
(define-command (com-multiple-query-replace-replace-all
:name t
:command-table multiple-query-replace-drei-table)
()
(declare (special strings occurrences re))
- (let* ((pane (current-window))
- (point (point pane))
+ (let* ((point (point))
(found nil))
- (loop for state = (query-replace-state pane)
+ (loop for state = (query-replace-state (current-window))
for string1 = (string1 state)
for string1-length = (length string1)
do (backward-object point string1-length)
@@ -184,31 +181,30 @@
re
(mapcar #'car strings)))
while found
- do (setf (query-replace-state pane)
+ do (setf (query-replace-state (current-window))
(make-instance 'query-replace-state
:string1 found
:string2 (cdr (assoc found strings :test #'string=))))
- finally (setf (query-replace-state pane) nil))))
+ finally (setf (query-replace-state (current-window)) nil))))
(define-command (com-multiple-query-replace-skip
:name t
:command-table multiple-query-replace-drei-table)
()
(declare (special strings re))
- (let* ((pane (current-window))
- (point (point pane))
+ (let* ((point (point))
(found (multiple-query-replace-find-next-match
point
re
(mapcar #'car strings))))
- (cond ((null found) (setf (query-replace-mode pane) nil))
- (t (setf (query-replace-state pane)
+ (cond ((null found) (setf (query-replace-mode (current-window)) nil))
+ (t (setf (query-replace-state (current-window))
(make-instance 'query-replace-state
:string1 found
:string2 (cdr (assoc found strings :test #'string=))))
(display-message "Replace ~A with ~A: "
- (string1 (query-replace-state pane))
- (string2 (query-replace-state pane)))))))
+ (string1 (query-replace-state (current-window)))
+ (string2 (query-replace-state (current-window))))))))
(defun multiple-query-replace-set-key (gesture command)
(add-command-to-command-table command 'multiple-query-replace-drei-table
--- /project/climacs/cvsroot/climacs/text-syntax.lisp 2007/06/04 21:52:06 1.13
+++ /project/climacs/cvsroot/climacs/text-syntax.lisp 2007/12/08 08:55:06 1.14
@@ -52,7 +52,7 @@
;;; Right stickies at non whitespace characters preceeded by space and punctuation.
;;;
-(in-package :climacs-text-syntax) ;;; Put this in a separate package once it works
+(in-package :climacs-text-syntax)
(defun index-of-mark-after-offset (flexichain offset)
"Searches for the mark after `offset' in the marks stored in `flexichain'."
@@ -72,9 +72,14 @@
(:name "Text")
(:pathname-types "text" "txt" "README"))
-(defmethod update-syntax (buffer (syntax text-syntax))
- (let* ((high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer)))
- (low-offset (max (- (offset (low-mark buffer)) 3) 0)))
+(defmethod update-syntax ((syntax text-syntax) prefix-size suffix-size
+ &optional begin end)
+ (declare (ignore begin end))
+ (let* ((buffer (buffer syntax))
+ (high-mark-offset (- (size buffer) suffix-size))
+ (low-mark-offset prefix-size)
+ (high-offset (min (+ high-mark-offset 3) (size buffer)))
+ (low-offset (max (- low-mark-offset 3) 0)))
(with-slots (paragraphs sentence-beginnings sentence-endings) syntax
(let ((pos1 (index-of-mark-after-offset paragraphs low-offset))
(pos-sentence-beginnings (index-of-mark-after-offset sentence-beginnings low-offset))
@@ -106,7 +111,7 @@
(and (member current-object '(#\Newline #\Space #\Tab))
(or (= offset 1)
(not (member before-prev-object '(#\Newline #\Space #\Tab)))))))
- (let ((m (clone-mark (low-mark buffer) :left)))
+ (let ((m (make-buffer-mark buffer low-mark-offset :left)))
(setf (offset m) offset)
(insert* sentence-endings pos-sentence-endings m))
(incf pos-sentence-endings))
@@ -117,7 +122,7 @@
(member prev-object '(#\Newline #\Space #\Tab)))
(or (<= offset 1)
(member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab))))
- (let ((m (clone-mark (low-mark buffer) :right)))
+ (let ((m (make-buffer-mark buffer low-mark-offset :right)))
(setf (offset m) offset)
(insert* sentence-beginnings pos-sentence-beginnings m))
(incf pos-sentence-beginnings))
@@ -131,7 +136,7 @@
(and (eql prev-object #\Newline)
(or (= offset 1)
(eql before-prev-object #\Newline)))))
- (let ((m (clone-mark (low-mark buffer) :left)))
+ (let ((m (make-buffer-mark buffer low-mark-offset :left)))
(setf (offset m) offset)
(insert* paragraphs pos1 m))
(incf pos1))
@@ -142,7 +147,7 @@
(and (eql current-object #\Newline)
(or (= offset (1- buffer-size))
(eql next-object #\Newline)))))
- (let ((m (clone-mark (low-mark buffer) :right)))
+ (let ((m (make-buffer-mark buffer low-mark-offset :right)))
(setf (offset m) offset)
(insert* paragraphs pos1 m))
(incf pos1))
--- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/11/12 16:06:06 1.11
+++ /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/08 08:55:06 1.12
@@ -32,17 +32,33 @@
;;;
;;; Commands for splitting windows
-(define-command (com-split-window-vertically :name t :command-table window-table) ()
- (split-window t))
+(defun split-window-maybe-cloning (vertically-p clone-current-view-p)
+ "Split `(current-window)', vertically if `vertically-p' is true,
+horizontally otherwise. If `clone-current-view-p' is true, use a
+clone of `(current-view)' for the new window."
+ (handler-bind ((view-already-displayed
+ #'(lambda (condition)
+ (declare (ignore condition))
+ ;; If this happens, `clone-current-view-p' is false.
+ (display-message "Can't split: no view available for new window")
+ (return-from split-window-maybe-cloning nil))))
+ (split-window vertically-p clone-current-view-p)))
+
+(define-command (com-split-window-vertically :name t
+ :command-table window-table)
+ ((clone-current-view 'boolean :default nil))
+ (split-window-maybe-cloning t clone-current-view))
-(set-key 'com-split-window-vertically
+(set-key `(com-split-window-vertically ,*numeric-argument-p*)
'window-table
'((#\x :control) (#\2)))
-(define-command (com-split-window-horizontally :name t :command-table window-table) ()
- (split-window))
+(define-command (com-split-window-horizontally :name t
+ :command-table window-table)
+ ((clone-current-view 'boolean :default nil))
+ (split-window-maybe-cloning nil clone-current-view))
-(set-key 'com-split-window-horizontally
+(set-key `(com-split-window-horizontally ,*numeric-argument-p*)
'window-table
'((#\x :control) (#\3)))
@@ -54,28 +70,28 @@
'((#\x :control) (#\o)))
(defun click-to-offset (window x y)
- (with-slots (top bot) window
- (let ((new-x (floor x (stream-character-width window #\m)))
- (new-y (floor y (stream-line-height window)))
- (buffer (buffer window)))
- (loop for scan from (offset top)
- with lines = 0
- until (= scan (offset bot))
- until (= lines new-y)
- when (eql (buffer-object buffer scan) #\Newline)
- do (incf lines)
- finally (loop for columns from 0
- until (= scan (offset bot))
- until (eql (buffer-object buffer scan) #\Newline)
- until (= columns new-x)
- do (incf scan))
- (return scan)))))
+ (with-accessors ((top top) (bot bot)) (view window)
+ (let ((new-x (floor x (stream-character-width window #\m)))
+ (new-y (floor y (stream-line-height window)))
+ (buffer (buffer (view window))))
+ (loop for scan from (offset top)
+ with lines = 0
+ until (= scan (offset bot))
+ until (= lines new-y)
+ when (eql (buffer-object buffer scan) #\Newline)
+ do (incf lines)
+ finally (loop for columns from 0
+ until (= scan (offset bot))
+ until (eql (buffer-object buffer scan) #\Newline)
+ until (= columns new-x)
+ do (incf scan))
+ (return scan)))))
(define-command (com-switch-to-this-window :name nil :command-table window-table)
((window 'pane) (x 'integer) (y 'integer))
(other-window window)
(when (buffer-pane-p window)
- (setf (offset (point window))
+ (setf (offset (point (view window)))
(click-to-offset window x y))))
(define-presentation-to-command-translator blank-area-to-switch-to-this-window
@@ -136,7 +152,7 @@
(define-command (com-scroll-other-window :name t :command-table window-table) ()
(let ((other-window (second (windows *application-frame*))))
(when other-window
- (page-down other-window))))
+ (page-down (view other-window)))))
(set-key 'com-scroll-other-window
'window-table
@@ -145,7 +161,7 @@
(define-command (com-scroll-other-window-up :name t :command-table window-table) ()
(let ((other-window (second (windows *application-frame*))))
(when other-window
- (page-up other-window))))
+ (page-up (view other-window)))))
(set-key 'com-scroll-other-window-up
'window-table
More information about the Climacs-cvs
mailing list