From thenriksen at common-lisp.net Tue Dec 4 07:45:35 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 4 Dec 2007 02:45:35 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071204074535.8A4075E006@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv8454 Modified Files: core.lisp Log Message: File-finding should work again now. --- /project/climacs/cvsroot/climacs/core.lisp 2007/11/20 12:59:54 1.14 +++ /project/climacs/cvsroot/climacs/core.lisp 2007/12/04 07:45:35 1.15 @@ -324,7 +324,7 @@ (make-new-buffer))) (pane (current-window))) (setf (offset (point (buffer pane))) (offset (point pane)) - (current-buffer) buffer + (buffer pane) buffer (syntax buffer) (make-instance (syntax-class-name-for-filepath filepath) :buffer buffer) (file-write-time buffer) (file-write-date filepath)) From thenriksen at common-lisp.net Sat Dec 8 08:55:07 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 8 Dec 2007 03:55:07 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071208085507.AD14F5B07F@common-lisp.net> 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 From thenriksen at common-lisp.net Mon Dec 10 21:31:09 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 10 Dec 2007 16:31:09 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071210213109.CE01B70DF@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv24612 Modified Files: gui.lisp window-commands.lisp Log Message: Make Climacs support nonstandard views somewhat. Easier than I expected, so bugs probably still abound. There's not really much UI candy to make nonstandard views very useful currently, consider this to be proof of concept support. --- /project/climacs/cvsroot/climacs/gui.lisp 2007/12/08 08:55:06 1.240 +++ /project/climacs/cvsroot/climacs/gui.lisp 2007/12/10 21:31:09 1.241 @@ -56,9 +56,11 @@ (:default-initargs :view (make-instance 'textual-drei-syntax-view :buffer (make-instance 'climacs-buffer)) - :command-table (find-command-table 'global-climacs-table) :width 900 :height 400)) +(defmethod command-table ((pane climacs-pane)) + (command-table (pane-frame pane))) + (define-condition view-setting-error (error) ((%view :accessor view :initarg :view @@ -125,9 +127,6 @@ (with-accessors ((views views)) (pane-frame pane) (full-redisplay pane))) -(defmethod command-table ((drei climacs-pane)) - (command-table (pane-frame drei))) - (defclass typeout-pane (application-pane esa-pane-mixin) ((%active :accessor active :initform nil @@ -181,10 +180,13 @@ ;;; Basic command tables follow. The global command table, ;;; `global-climacs-table', inherits from these, so they should not ;;; contain any overly syntax-specific commands. The idea is that it -;;; should be safe for any syntax to inherit its command-table from -;;; `global-climacs-table' (so the usual movement, search and -;;; navigation-commands are available), without risking adding alien -;;; commands that require the buffer to be in a specific syntax. +;;; should always be safe to invoke commands from these tables, +;;; without risking adding alien commands that require the current +;;; window to contain a specific type of view or syntax. In general, +;;; the Climacs frame has a special command table of type +;;; `climacs-command-table' (that's not its name) that selectively +;;; inherits from view-specific tables and the `global-climacs-table' +;;; based on the current window and view. ;;; Basic functionality (make-command-table 'base-table :errorp nil) @@ -216,12 +218,24 @@ development-table climacs-help-table)) +(make-command-table 'global-climacs-table + :errorp nil + :inherit-from '(base-table + pane-table + window-table + development-table + climacs-help-table + global-esa-table + esa-io-table)) + (defclass climacs-command-table (standard-command-table) ()) (defmethod command-table-inherit-from ((table climacs-command-table)) - (append (when (current-syntax) (list (command-table (current-syntax)))) + (append (view-command-tables (current-view)) '(global-climacs-table) + (when (use-editor-commands-p (current-view)) + '(editor-table)) (call-next-method))) (define-application-frame climacs (esa-frame-mixin @@ -232,20 +246,8 @@ (%kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring) (%command-table :initform (make-instance 'climacs-command-table :name 'climacs-dispatching-table) - :accessor find-applicable-command-table)) - (:command-table (global-climacs-table - :inherit-from (esa-io-table - keyboard-macro-table - climacs-help-table - base-table - buffer-table - case-table - development-table - info-table - pane-table - window-table - editor-table - global-esa-table))) + :accessor find-applicable-command-table + :accessor frame-command-table)) (:menu-bar nil) (:panes (climacs-window @@ -391,13 +393,52 @@ ((type modified) record stream state) nil) +(defgeneric display-view-info-to-info-pane (info-pane master-pane view) + (:documentation "Display interesting information about +`view' (which is in `master-pane') to `info-pane'.")) + +(defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane) + (master-pane climacs-pane) + (view drei-syntax-view)) + (with-text-family (info-pane :sans-serif) + (display-syntax-name (syntax view) info-pane :view view))) + +(defmethod display-view-info-to-info-pane ((info-pane climacs-info-pane) + (master-pane climacs-pane) + (view textual-drei-syntax-view)) + (let ((point (point view)) + (bot (bot view)) + (top (top view)) + (size (size (buffer view)))) + (format info-pane " ~A " + (cond ((and (mark= size bot) + (mark= 0 top)) + "") + ((mark= size bot) + "Bot") + ((mark= 0 top) + "Top") + (t (format nil "~a%" + (round (* 100 (/ (offset top) + size))))))) + (when *show-info-pane-mark-position* + (format info-pane "(~A,~A) " + (1+ (line-number point)) + (column-number point))) + (princ #\( info-pane) + (call-next-method) + (format info-pane "~{~:[~*~; ~A~]~}" (list + (overwrite-mode view) + "Ovwrt" + (auto-fill-mode view) + "Fill" + (isearch-mode master-pane) + "Isearch")) + (princ #\) info-pane))) + (defun display-info (frame pane) (let* ((master-pane (master-pane pane)) - (view (view master-pane)) - (size (size (buffer view))) - (top (top view)) - (bot (bot view)) - (point (point view))) + (view (view master-pane))) (princ " " pane) (with-output-as-presentation (pane view 'read-only) (princ (cond @@ -417,32 +458,7 @@ (format pane "~A" (subscripted-name view))) ;; FIXME: bare 25. (format pane "~V at T" (max (- 25 (length (subscripted-name view))) 1))) - (format pane " ~A " - (cond ((and (mark= size bot) - (mark= 0 top)) - "") - ((mark= size bot) - "Bot") - ((mark= 0 top) - "Top") - (t (format nil "~a%" - (round (* 100 (/ (offset top) - size))))))) - (when *show-info-pane-mark-position* - (format pane "(~A,~A) " - (1+ (line-number point)) - (column-number point))) - (with-text-family (pane :sans-serif) - (princ #\( pane) - (display-syntax-name (syntax view) pane :view view) - (format pane "~{~:[~*~; ~A~]~}" (list - (overwrite-mode view) - "Ovwrt" - (auto-fill-mode view) - "Fill" - (isearch-mode master-pane) - "Isearch")) - (princ #\) pane)) + (display-view-info-to-info-pane pane master-pane view) (with-text-family (pane :sans-serif) (princ (if (recordingp frame) "Def" --- /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/08 08:55:06 1.12 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/10 21:31:09 1.13 @@ -90,7 +90,8 @@ (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) + (when (and (buffer-pane-p window) + (typep (view window) 'point-mark-view)) (setf (offset (point (view window))) (click-to-offset window x y)))) From thenriksen at common-lisp.net Tue Dec 11 18:46:53 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 11 Dec 2007 13:46:53 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071211184653.C2A0831062@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13351 Modified Files: climacs-lisp-syntax.lisp climacs-lisp-syntax-commands.lisp Log Message: I broke the Swank-using code, now unbroke it. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2007/12/08 08:55:06 1.6 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2007/12/11 18:46:53 1.7 @@ -286,7 +286,7 @@ (form-to-object syntax token :read t :package (package-at-mark syntax mark)) - syntax m) + view m) (show-note-counts notes (second result)) (when (not (null notes)) (show-notes notes (name view) --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2007/12/08 08:55:06 1.6 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax-commands.lisp 2007/12/11 18:46:53 1.7 @@ -78,12 +78,12 @@ () "Compile and load the current file. -Compiler notes will be displayed in a seperate buffer." - (compile-file-interactively (current-buffer) t)) +Compiler notes will be displayed in a seperate view." + (compile-file-interactively (current-view) t)) (define-command (com-compile-file :name t :command-table climacs-lisp-table) () - "Compile the file open in the current buffer. + "Compile the file open in the current view. This command does not load the file after it has been compiled." (compile-file-interactively (current-view) nil)) From thenriksen at common-lisp.net Tue Dec 11 23:19:46 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 11 Dec 2007 18:19:46 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071211231946.1B3132B127@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5034 Modified Files: core.lisp gui.lisp Log Message: Made typeout windows work again. Now Climacs doesn't primarily deal with the "active view" any more (that was a mistake on my part, typeout windows do not have views, hence this would never work) but the "active window". Not a user-visible change, but fixes typeout windows. --- /project/climacs/cvsroot/climacs/core.lisp 2007/12/08 08:55:06 1.16 +++ /project/climacs/cvsroot/climacs/core.lisp 2007/12/11 23:19:45 1.17 @@ -388,4 +388,4 @@ (error () (progn (beep) (display-message "Invalid answer") (return-from frame-exit nil))))) - (call-next-method))) \ No newline at end of file + (call-next-method))) --- /project/climacs/cvsroot/climacs/gui.lisp 2007/12/10 21:31:09 1.241 +++ /project/climacs/cvsroot/climacs/gui.lisp 2007/12/11 23:19:45 1.242 @@ -97,7 +97,8 @@ (find-if #'(lambda (other-pane) (and (not (eq other-pane pane)) (eq (view other-pane) view))) - (windows (pane-frame pane))))) + (windows (pane-frame pane)))) + (old-view-active (active (view pane)))) (cond ((not (member view (views (pane-frame pane)))) (restart-case (error 'unknown-view :view view) (add-to-view-list () @@ -121,7 +122,9 @@ (pane-frame window-displaying-view) view))) (cancel () :report "Cancel the setting of the windows view and just return"))) - (t (call-next-method))))) + (t (call-next-method))) + (when old-view-active + (ensure-only-view-active (pane-frame pane) view)))) (defmethod (setf view) :before ((view drei-view) (pane climacs-pane)) (with-accessors ((views views)) (pane-frame pane) @@ -299,30 +302,43 @@ (setf (buffer (current-view (esa-current-window application-frame))) new-buffer)) +(defmethod (setf windows) :after (new-val (climacs climacs)) + ;; Ensures that we don't end up with two views that both believe + ;; they are active. + (activate-window (esa-current-window climacs))) + +(defun current-window-p (window) + "Return true if `window' is the current window of its Climacs +instance." + (eq window (esa-current-window (pane-frame window)))) + +(defun ensure-only-view-active (climacs view) + "Ensure that `view' is the only view of `climacs' that is +active." + (dolist (other-view (views climacs)) + (unless (eq other-view view) + (setf (active other-view) nil))) + (setf (active view) t)) + (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. + ;; destructively updated, so copy it for safekeeping. Also make sure + ;; only one view thinks that it's active. (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) + (when (and (typep window 'climacs-pane) + (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))))))))) + (delete-window window))))))) + (ensure-only-view-active + frame (when (typep (esa-current-window frame) 'climacs-pane) + (view (esa-current-window frame))))) (defmethod (setf views) :after ((new-value null) (frame climacs)) ;; You think you can remove all views? I laught at your silly @@ -330,11 +346,6 @@ (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) @@ -346,8 +357,8 @@ "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))) + :active nil initargs))) + (setf (syntax new-view) (make-syntax-for-view new-view (class-of (syntax view)))) (push new-view (views climacs)) new-view)) @@ -366,7 +377,7 @@ (defun any-displayed-view () "Return some view on display." - (view (first (windows *application-frame*)))) + (view (esa-current-window *application-frame*))) (defun any-preferably-undisplayed-view () "Return some view, any view, preferable one that is not @@ -485,13 +496,21 @@ 'base-table '((#\l :control))) -(defun activate-view (climacs active-view) - "Set `view' to be the active view for `climacs'." +(defun activate-window (window) + "Set `window' to be the active window for its Climacs +instance. `Window' must already be recognized by the Climacs +instance." ;; 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)) + (let ((climacs (pane-frame window))) + (unless (current-window-p window) + (when (typep (esa-current-window climacs) 'climacs-pane) + (setf (active (esa-current-window climacs)) nil)) + (unless (member window (windows climacs)) + (error "Cannot set unknown window to be active window")) + (setf (windows climacs) + (cons window (remove window (windows climacs))))) + (when (typep window 'climacs-pane) + (ensure-only-view-active climacs (view window))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -589,7 +608,7 @@ (replace-constellation constellation-root vbox vertically-p) (full-redisplay current-window) (full-redisplay new-pane) - (activate-view (pane-frame pane) pane) + (activate-window pane) new-pane)))) (defun make-typeout-constellation (&optional label) @@ -653,9 +672,9 @@ (remove pane (windows *esa-instance*)))) (setf (windows *esa-instance*) (append (rest (windows *esa-instance*)) - (list (first (windows *esa-instance*)))))) - (activate-view *esa-instance* (view (first (windows *esa-instance*)))) - (setf *standard-output* (first (windows *esa-instance*)))) + (list (esa-current-window *esa-instance*))))) + (activate-window (esa-current-window *esa-instance*)) + (setf *standard-output* (esa-current-window *esa-instance*))) ;;; For the ESA help functions. From thenriksen at common-lisp.net Tue Dec 11 23:42:15 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 11 Dec 2007 18:42:15 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071211234215.1485A5D164@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv9810 Modified Files: gui.lisp Log Message: Made Climacs respect typeout panes a little more. There's no reason to be sour just because the pane you happen to grab doesn't have a view. --- /project/climacs/cvsroot/climacs/gui.lisp 2007/12/11 23:19:45 1.242 +++ /project/climacs/cvsroot/climacs/gui.lisp 2007/12/11 23:42:15 1.243 @@ -96,6 +96,7 @@ (let ((window-displaying-view (find-if #'(lambda (other-pane) (and (not (eq other-pane pane)) + (typep other-pane 'climacs-pane) (eq (view other-pane) view))) (windows (pane-frame pane)))) (old-view-active (active (view pane)))) @@ -235,9 +236,11 @@ ()) (defmethod command-table-inherit-from ((table climacs-command-table)) - (append (view-command-tables (current-view)) + (append (when (typep (current-window) 'climacs-pane) + (view-command-tables (current-view))) '(global-climacs-table) - (when (use-editor-commands-p (current-view)) + (when (and (typep (current-window) 'climacs-pane) + (use-editor-commands-p (current-view))) '(editor-table)) (call-next-method))) @@ -312,13 +315,15 @@ instance." (eq window (esa-current-window (pane-frame window)))) -(defun ensure-only-view-active (climacs view) +(defun ensure-only-view-active (climacs &optional view) "Ensure that `view' is the only view of `climacs' that is +active. `View' may be NIL, in which case no view is set as active." (dolist (other-view (views climacs)) (unless (eq other-view view) (setf (active other-view) nil))) - (setf (active view) t)) + (unless (null view) + (setf (active view) t))) (defmethod (setf views) :around (new-value (frame climacs)) ;; If any windows show a view that no longer exists in the @@ -379,20 +384,28 @@ "Return some view on display." (view (esa-current-window *application-frame*))) +(defun view-on-display (climacs view) + "Return true if `view' is on display in a window of `climacs', +false otherwise." + (member view (remove-if-not #'(lambda (window) + (typep window 'climacs-pane)) + (windows climacs)) + :key #'view)) + (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*)) + (or (find-if-not #'(lambda (view) + (not (view-on-display *esa-instance* 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*)) + (or (find-if-not #'(lambda (view) + (view-on-display *esa-instance* view)) + (views *esa-instance*)) (clone-view-for-climacs *esa-instance* (any-view)))) (define-presentation-type read-only ()) @@ -509,8 +522,9 @@ (error "Cannot set unknown window to be active window")) (setf (windows climacs) (cons window (remove window (windows climacs))))) - (when (typep window 'climacs-pane) - (ensure-only-view-active climacs (view window))))) + (ensure-only-view-active + climacs (when (typep window 'climacs-pane) + (view window))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Wed Dec 12 23:44:42 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 12 Dec 2007 18:44:42 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071212234442.47AEA4F01B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28020 Modified Files: core.lisp Log Message: Tell newly loaded files that they do not need to be saved. --- /project/climacs/cvsroot/climacs/core.lisp 2007/12/11 23:19:45 1.17 +++ /project/climacs/cvsroot/climacs/core.lisp 2007/12/12 23:44:42 1.18 @@ -330,7 +330,8 @@ (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)) + (file-write-time buffer) (file-write-date filepath) + (needs-saving buffer) nil) (evaluate-attribute-line view) (setf (filepath buffer) filepath (read-only-p buffer) readonlyp) From thenriksen at common-lisp.net Thu Dec 13 08:57:08 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 13 Dec 2007 03:57:08 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071213085708.6E6E14F028@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv24293 Modified Files: gui.lisp Log Message: Added "typeout stream" idea that redirects *standard-output* to a typeout window. Also include commands defined in buffer-table. --- /project/climacs/cvsroot/climacs/gui.lisp 2007/12/11 23:42:15 1.243 +++ /project/climacs/cvsroot/climacs/gui.lisp 2007/12/13 08:57:08 1.244 @@ -225,6 +225,7 @@ (make-command-table 'global-climacs-table :errorp nil :inherit-from '(base-table + buffer-table pane-table window-table development-table @@ -253,14 +254,20 @@ (%command-table :initform (make-instance 'climacs-command-table :name 'climacs-dispatching-table) :accessor find-applicable-command-table - :accessor frame-command-table)) + :accessor frame-command-table) + (%output-stream :accessor output-stream + :initform nil + :initarg :output-stream)) (:menu-bar nil) (:panes (climacs-window (let* ((*esa-instance* *application-frame*) (climacs-pane (make-pane 'climacs-pane :active t)) (info-pane (make-pane 'climacs-info-pane - :master-pane climacs-pane))) + :master-pane climacs-pane))) + (unless (output-stream *esa-instance*) + (setf (output-stream *esa-instance*) + (make-typeout-stream *application-frame* "*standard-output*"))) (setf (windows *application-frame*) (list climacs-pane) (views *application-frame*) (list (view climacs-pane))) (vertically () @@ -285,7 +292,9 @@ prompt) :bindings ((*default-target-creator* *climacs-target-creator*) (*drei-instance* (esa-current-window frame)) - (*previous-command* (previous-command *drei-instance*)))) + (*previous-command* (previous-command *drei-instance*)) + (*standard-output* (or (output-stream frame) + *terminal-io*)))) (defmethod frame-standard-input ((frame climacs)) (get-frame-pane frame 'minibuffer)) @@ -625,10 +634,12 @@ (activate-window pane) new-pane)))) -(defun make-typeout-constellation (&optional label) +(defun make-typeout-constellation (&key label pane) (let* ((typeout-pane - (make-pane 'typeout-pane :foreground *foreground-color* :background *background-color* - :width 900 :height 400 :display-time nil :name label)) + (or pane + (make-pane 'typeout-pane :foreground *foreground-color* + :background *background-color* + :width 900 :height 400 :display-time nil :name label))) (label (make-pane 'label-pane :label label)) (vbox @@ -643,7 +654,7 @@ (with-look-and-feel-realization ((frame-manager *esa-instance*) *esa-instance*) (or (find label (windows *esa-instance*) :key #'pane-name) - (multiple-value-bind (vbox new-pane) (make-typeout-constellation label) + (multiple-value-bind (vbox new-pane) (make-typeout-constellation :label label) (let* ((current-window pane) (constellation-root (find-parent current-window))) (push new-pane (windows *esa-instance*)) @@ -667,7 +678,6 @@ (third (third children))) (setf (windows *esa-instance*) (delete window (windows *esa-instance*))) - (setf *standard-output* (car (windows *esa-instance*))) (sheet-disown-child box other) (sheet-adopt-child parent other) (sheet-disown-child parent box) @@ -687,10 +697,103 @@ (setf (windows *esa-instance*) (append (rest (windows *esa-instance*)) (list (esa-current-window *esa-instance*))))) - (activate-window (esa-current-window *esa-instance*)) - (setf *standard-output* (esa-current-window *esa-instance*))) + (activate-window (esa-current-window *esa-instance*))) ;;; For the ESA help functions. (defmethod help-stream ((frame climacs) title) (typeout-window (format nil "~10T~A" title))) + +;;; An implementation of the Gray streams protocol that uses a Climacs +;;; typeout pane to draw the output. + +(defclass typeout-stream (fundamental-character-output-stream) + ((%typeout-pane :accessor typeout-pane + :initform nil + :initarg :typeout-pane + :documentation "The typeout pane that output +will be performed on.") + (%climacs :reader climacs-instance + :initform (error "Must provide a Climacs instance for typeout streams") + :initarg :climacs) + (%label :reader label + :initform (error "A typeout stream must have a label") + :initarg :label)) + (:documentation "An output stream that performs output on +a (single) Climacs typeout pane. If the typeout pane is deleted +manually by the user, the stream will recreate it the next time +output is performed.")) + +(defmethod initialize-instance :after ((stream typeout-stream) &rest args) + (declare (ignore args)) + (setf (typeout-pane stream) + (with-look-and-feel-realization ((frame-manager (climacs-instance stream)) + (climacs-instance stream)) + (make-pane 'typeout-pane :foreground *foreground-color* + :background *background-color* + :width 900 :height 400 :display-time nil :name (label stream))))) + +(defgeneric ensure-typeout-pane-for-stream (stream) + (:documentation "Ensure that `stream' has a typeout pane that +it can display output to, and that this pane is on display.")) + +(defmethod ensure-typeout-pane-for-stream ((stream typeout-stream)) + (with-look-and-feel-realization ((frame-manager (climacs-instance stream)) + (climacs-instance stream)) + (unless (member (typeout-pane stream) (windows (climacs-instance stream))) + (setf (sheet-parent (typeout-pane stream)) nil) + (multiple-value-bind (vbox new-pane) (make-typeout-constellation :pane (typeout-pane stream) + :label (label stream)) + (let* ((current-window (current-window)) + (constellation-root (find-parent current-window))) + (push new-pane (windows *esa-instance*)) + (other-window) + (replace-constellation constellation-root vbox t) + (full-redisplay current-window)))))) + +(defmethod stream-write-char ((stream typeout-stream) char) + (ensure-typeout-pane-for-stream stream) + (stream-write-char (typeout-pane stream) char)) + +(defmethod stream-line-column ((stream typeout-stream)) + (ensure-typeout-pane-for-stream stream) + (stream-line-column (typeout-pane stream))) + +(defmethod stream-start-line-p ((stream typeout-stream)) + (ensure-typeout-pane-for-stream stream) + (stream-start-line-p (typeout-pane stream))) + +(defmethod stream-write-string ((stream typeout-stream) string &optional (start 0) end) + (ensure-typeout-pane-for-stream stream) + (stream-write-string (typeout-pane stream) string start end)) + +(defmethod stream-terpri ((stream typeout-stream)) + (ensure-typeout-pane-for-stream stream) + (stream-terpri (typeout-pane stream))) + +(defmethod stream-fresh-line ((stream typeout-stream)) + (ensure-typeout-pane-for-stream stream) + (stream-fresh-line (typeout-pane stream))) + +(defmethod stream-finish-output ((stream typeout-stream)) + (ensure-typeout-pane-for-stream stream) + (stream-finish-output (typeout-pane stream))) + +(defmethod stream-force-output ((stream typeout-stream)) + (ensure-typeout-pane-for-stream stream) + (stream-force-output (typeout-pane stream))) + +(defmethod stream-clear-output ((stream typeout-stream)) + (ensure-typeout-pane-for-stream stream) + (stream-clear-output (typeout-pane stream))) + +(defmethod stream-advance-to-column ((stream typeout-stream) (column integer)) + (ensure-typeout-pane-for-stream stream) + (stream-advance-to-column (typeout-pane stream) column)) + +(defmethod interactive-stream-p ((stream typeout-stream)) + (ensure-typeout-pane-for-stream stream) + (interactive-stream-p (typeout-pane stream))) + +(defun make-typeout-stream (climacs label) + (make-instance 'typeout-stream :climacs climacs :label label)) From thenriksen at common-lisp.net Thu Dec 13 19:09:39 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 13 Dec 2007 14:09:39 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071213190939.EF9732E1C9@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28879 Modified Files: core.lisp Log Message: Fixed memory creep issue. --- /project/climacs/cvsroot/climacs/core.lisp 2007/12/12 23:44:42 1.18 +++ /project/climacs/cvsroot/climacs/core.lisp 2007/12/13 19:09:39 1.19 @@ -87,6 +87,11 @@ (filepath (buffer view)) (needs-saving (buffer view)))) +(defun dummy-buffer () + "Create a dummy buffer object for use when killing views, to +prevent increasing memory usage." + (make-instance 'drei-buffer)) + (defgeneric kill-view (view) (:documentation "Remove `view' from the Climacs specified in `*esa-instance*'. If `view' is currently displayed in a window, @@ -106,6 +111,11 @@ (return-from kill-view nil))))) (save-buffer (buffer view))) (setf views (remove view views)) + ;; If we don't change the buffer of the view, a reference to the + ;; view will be kept in the buffer, and the view will thus not be + ;; garbage-collected. So create a circular reference structure + ;; that can be garbage-collected instead. + (setf (buffer view) (dummy-buffer)) (full-redisplay (current-window)) (current-view))) From thenriksen at common-lisp.net Thu Dec 13 19:28:16 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 13 Dec 2007 14:28:16 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071213192816.8B5BC2F04E@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv328 Modified Files: core.lisp Log Message: Set the name of a buffer to the name of the file. In general, "buffer names" are pretty informally handled everywhere. At least they're no longer all called *scratch*, though. --- /project/climacs/cvsroot/climacs/core.lisp 2007/12/13 19:09:39 1.19 +++ /project/climacs/cvsroot/climacs/core.lisp 2007/12/13 19:28:16 1.20 @@ -341,7 +341,8 @@ (current-view) view (syntax view) (make-syntax-for-view view (syntax-class-name-for-filepath filepath)) (file-write-time buffer) (file-write-date filepath) - (needs-saving buffer) nil) + (needs-saving buffer) nil + (name buffer) (filepath-filename filepath)) (evaluate-attribute-line view) (setf (filepath buffer) filepath (read-only-p buffer) readonlyp) From rstrandh at common-lisp.net Sat Dec 15 07:22:51 2007 From: rstrandh at common-lisp.net (rstrandh) Date: Sat, 15 Dec 2007 02:22:51 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071215072251.CAED2250F0@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv27849 Modified Files: gui.lisp Log Message: Fixed a double negative. --- /project/climacs/cvsroot/climacs/gui.lisp 2007/12/13 08:57:08 1.244 +++ /project/climacs/cvsroot/climacs/gui.lisp 2007/12/15 07:22:50 1.245 @@ -405,7 +405,7 @@ "Return some view, any view, preferable one that is not currently displayed in any window." (or (find-if-not #'(lambda (view) - (not (view-on-display *esa-instance* view))) + (view-on-display *esa-instance* view)) (views *esa-instance*)) (any-view))) From thenriksen at common-lisp.net Sat Dec 15 10:17:12 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 15 Dec 2007 05:17:12 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071215101712.18DB2620D7@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25934 Modified Files: window-commands.lisp text-syntax.lisp search-commands.lisp misc-commands.lisp Log Message: Added my copyright statement to a bunch of files. --- /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/10 21:31:09 1.13 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/15 10:17:11 1.14 @@ -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 --- /project/climacs/cvsroot/climacs/text-syntax.lisp 2007/12/08 08:55:06 1.14 +++ /project/climacs/cvsroot/climacs/text-syntax.lisp 2007/12/15 10:17:11 1.15 @@ -4,6 +4,8 @@ ;;; Robert Strandh (strandh at labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) +;;; (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 --- /project/climacs/cvsroot/climacs/search-commands.lisp 2007/12/08 08:55:06 1.17 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2007/12/15 10:17:11 1.18 @@ -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 --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2007/12/08 08:55:06 1.29 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2007/12/15 10:17:11 1.30 @@ -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 From thenriksen at common-lisp.net Wed Dec 19 11:02:22 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 19 Dec 2007 06:02:22 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071219110222.C546D32033@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29549 Modified Files: window-commands.lisp Log Message: *numeric-argument-marker* is now equivalent to *numeric-argument-p*, so use that instead. --- /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/15 10:17:11 1.14 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/19 11:02:22 1.15 @@ -51,7 +51,7 @@ ((clone-current-view 'boolean :default nil)) (split-window-maybe-cloning t clone-current-view)) -(set-key `(com-split-window-vertically ,*numeric-argument-p*) +(set-key `(com-split-window-vertically ,*numeric-argument-marker*) 'window-table '((#\x :control) (#\2))) @@ -60,7 +60,7 @@ ((clone-current-view 'boolean :default nil)) (split-window-maybe-cloning nil clone-current-view)) -(set-key `(com-split-window-horizontally ,*numeric-argument-p*) +(set-key `(com-split-window-horizontally ,*numeric-argument-marker*) 'window-table '((#\x :control) (#\3))) From thenriksen at common-lisp.net Fri Dec 21 11:22:50 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 21 Dec 2007 06:22:50 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071221112250.ADA2D17071@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv19718 Modified Files: java-syntax-commands.lisp Log Message: Fixed undeclared variable error for a Java syntax command. --- /project/climacs/cvsroot/climacs/java-syntax-commands.lisp 2007/12/08 08:55:06 1.3 +++ /project/climacs/cvsroot/climacs/java-syntax-commands.lisp 2007/12/21 11:22:50 1.4 @@ -67,10 +67,10 @@ (make-buffer-mark (current-buffer) offset2 :right) #'(lambda (mark) (syntax-line-indentation - mark (tab-space-count (current-view)) syntax)) + mark (tab-space-count (current-view)) (current-syntax))) fill-column (tab-space-count (current-view)) - syntax + (current-syntax) t))))) (define-command (com-indent-expression :name t :command-table java-table) @@ -131,4 +131,4 @@ (set-key `(com-transpose-expressions) 'java-table - '((#\t :control :meta))) \ No newline at end of file + '((#\t :control :meta))) From thenriksen at common-lisp.net Thu Dec 27 16:27:25 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 27 Dec 2007 11:27:25 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071227162725.5B5E6111D1@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28151 Modified Files: climacs-lisp-syntax.lisp Log Message: Fixed goto-location function in Lisp syntax. --- /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2007/12/11 18:46:53 1.7 +++ /project/climacs/cvsroot/climacs/climacs-lisp-syntax.lisp 2007/12/27 16:27:25 1.8 @@ -237,13 +237,14 @@ (let ((view (find (file-name location) (views *application-frame*) :test #'string= :key #'(lambda (view) - (let ((path (filepath view))) - (when path - (namestring path))))))) + (when (typep view 'drei-buffer-view) + (let ((path (filepath (buffer view)))) + (when path + (namestring path)))))))) (if view (climacs-core:switch-to-view (current-window) view) (find-file (file-name location))) - (goto-position (point (current-window)) + (goto-position (point (current-view)) (char-position (source-position location))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From thenriksen at common-lisp.net Thu Dec 27 16:27:47 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 27 Dec 2007 11:27:47 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071227162747.AC45E1B01F@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28241 Modified Files: gui.lisp Log Message: A pane is now only a buffer pane if its view is a buffer-view. --- /project/climacs/cvsroot/climacs/gui.lisp 2007/12/15 07:22:50 1.245 +++ /project/climacs/cvsroot/climacs/gui.lisp 2007/12/27 16:27:47 1.246 @@ -152,7 +152,7 @@ nil) (defmethod buffer-pane-p ((pane climacs-pane)) - t) + (typep (view pane) 'drei-buffer-view)) (defmethod in-focus-p ((pane climacs-pane)) (eq pane (first (windows *application-frame*)))) From thenriksen at common-lisp.net Thu Dec 27 16:28:08 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 27 Dec 2007 11:28:08 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071227162808.60B302823D@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28279 Modified Files: window-commands.lisp Log Message: Fixed left- and right-clicking on Climacs panes (I think). --- /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/19 11:02:22 1.15 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2007/12/27 16:28:08 1.16 @@ -113,7 +113,7 @@ ((window 'pane) (x 'integer) (y 'integer)) (when (and (buffer-pane-p window) (eq window (current-window))) - (setf (offset (mark window)) + (setf (offset (mark (view window))) (click-to-offset window x y)) (drei-commands::com-exchange-point-and-mark) (drei-commands::com-copy-region))) @@ -129,7 +129,7 @@ ((window 'pane) (x 'integer) (y 'integer)) (when (buffer-pane-p window) (other-window window) - (setf (offset (point window)) + (setf (offset (point (view window))) (click-to-offset window x y)) (drei-commands::com-yank))) From thenriksen at common-lisp.net Thu Dec 27 16:34:09 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 27 Dec 2007 11:34:09 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071227163409.0C4904D0C3@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28778 Modified Files: gui.lisp Log Message: The current buffer is now NIL if no the current window is not a buffer-pane. --- /project/climacs/cvsroot/climacs/gui.lisp 2007/12/27 16:27:47 1.246 +++ /project/climacs/cvsroot/climacs/gui.lisp 2007/12/27 16:34:08 1.247 @@ -307,7 +307,8 @@ (views climacs))))) (defmethod esa-current-buffer ((application-frame climacs)) - (buffer (current-view (esa-current-window application-frame)))) + (when (buffer-pane-p (esa-current-window application-frame)) + (buffer (current-view (esa-current-window application-frame))))) (defmethod (setf esa-current-buffer) ((new-buffer climacs-buffer) (application-frame climacs)) From thenriksen at common-lisp.net Fri Dec 28 15:39:49 2007 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 28 Dec 2007 10:39:49 -0500 (EST) Subject: [climacs-cvs] CVS climacs Message-ID: <20071228153949.2E77C4D0CB@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12985 Modified Files: core.lisp Log Message: Fixed finding of files while the current window is a typeout pane. --- /project/climacs/cvsroot/climacs/core.lisp 2007/12/13 19:28:16 1.20 +++ /project/climacs/cvsroot/climacs/core.lisp 2007/12/28 15:39:49 1.21 @@ -331,22 +331,27 @@ (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))) + (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))) + (unless (buffer-pane-p (current-window)) + (other-window (or (find-if #'(lambda (window) + (typep window 'climacs-pane)) + (windows *esa-instance*)) + (split-window t)))) (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) (needs-saving buffer) nil (name buffer) (filepath-filename filepath)) + (setf (current-view (current-window)) view) (evaluate-attribute-line view) (setf (filepath buffer) filepath (read-only-p buffer) readonlyp) - (beginning-of-buffer (point)) + (beginning-of-buffer (point view)) buffer))))))) (defmethod frame-find-file ((application-frame climacs) filepath)