Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv721

Modified Files: search-commands.lisp prolog2paiprolog.lisp pane.lisp packages.lisp misc-commands.lisp io.lisp gui.lisp file-commands.lisp core.lisp climacs.asd base.lisp Log Message: Changed Climacs to use the ESA-IO and ESA-BUFFER functionality instead of duplicating essentially the same code across multiple projects. This is rather invasive as some of the ESA functions have a subtly different signature.

--- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/27 10:39:32 1.12 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/08/20 13:06:38 1.13 @@ -168,7 +168,7 @@ (isearch-from-mark pane mark string forwardp))))

(define-command (com-isearch-append-word :name t :command-table isearch-climacs-table) () - (let ((syntax (syntax (current-buffer)))) + (let ((syntax (syntax (current-buffer *application-frame*)))) (isearch-append-text #'(lambda (mark) (forward-word mark syntax)))))

--- /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2005/11/23 17:39:28 1.1 +++ /project/climacs/cvsroot/climacs/prolog2paiprolog.lisp 2006/08/20 13:06:38 1.2 @@ -44,7 +44,7 @@ (let ((buffer (make-instance 'prolog-buffer))) (when (probe-file filepath) (with-open-file (stream filepath :direction :input) - (input-from-stream stream buffer 0))) + (save-buffer-to-stream stream buffer))) (setf (filepath buffer) filepath (offset (low-mark buffer)) 0 (offset (high-mark buffer)) (size buffer)) --- /project/climacs/cvsroot/climacs/pane.lisp 2006/08/20 10:29:17 1.48 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/08/20 13:06:38 1.49 @@ -237,11 +237,6 @@

(defparameter +climacs-textual-view+ (make-instance 'climacs-textual-view))

-(defclass file-mixin () - ((filepath :initform nil :accessor filepath) - (file-saved-p :initform nil :accessor file-saved-p) - (file-write-time :initform nil :accessor file-write-time))) - ;(defgeneric indent-tabs-mode (climacs-buffer))

(defclass extended-standard-buffer (read-only-mixin standard-buffer undo-mixin abbrev-mixin) () @@ -250,7 +245,7 @@ (defclass extended-binseq2-buffer (read-only-mixin binseq2-buffer p-undo-mixin abbrev-mixin) () (:documentation "Extensions accessible via marks."))

-(defclass climacs-buffer (delegating-buffer file-mixin name-mixin) +(defclass climacs-buffer (delegating-buffer esa-buffer-mixin) ((needs-saving :initform nil :accessor needs-saving) (syntax :accessor syntax) (point :initform nil :initarg :point :accessor point) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/08/11 21:59:05 1.111 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/08/20 13:06:38 1.112 @@ -76,7 +76,7 @@ (:documentation "An implementation of a kill ring."))

(defpackage :climacs-base - (:use :clim-lisp :climacs-buffer :climacs-kill-ring) + (:use :clim-lisp :climacs-buffer :climacs-kill-ring :esa-buffer) (:export #:as-offsets #:do-buffer-region #:do-buffer-region-lines @@ -91,7 +91,6 @@ #:just-n-spaces #:buffer-whitespacep #:buffer-region-case - #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-looking-at #:looking-at #:buffer-search-forward #:buffer-search-backward @@ -171,7 +170,7 @@

(defpackage :climacs-pane (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev - :climacs-syntax :flexichain :undo) + :climacs-syntax :flexichain :undo :esa-buffer :esa-io) (:export #:climacs-buffer #:needs-saving #:filepath #:file-saved-p #:file-write-time #:read-only-p #:buffer-read-only @@ -316,7 +315,7 @@ (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :climacs-motion :climacs-kill-ring :climacs-pane :clim-extensions - :undo :esa :climacs-editing :climacs-motion) + :undo :esa :climacs-editing :climacs-motion :esa-buffer :esa-io) ;;(:import-from :lisp-string) (:export #:climacs ; Frame.

@@ -370,7 +369,7 @@ (defpackage :climacs-core (:use :clim-lisp :climacs-base :climacs-buffer :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring - :climacs-editing :climacs-gui :clim :climacs-abbrev :esa) + :climacs-editing :climacs-gui :clim :climacs-abbrev :esa :esa-buffer :esa-io) (:export #:display-string #:object-equal #:object= @@ -397,7 +396,8 @@ #:set-syntax

#:switch-to-buffer - #:make-buffer + #:make-new-buffer + #:make-new-named-buffer #:erase-buffer #:kill-buffer

@@ -405,11 +405,15 @@ #:update-attribute-line #:evaluate-attribute-line #:directory-pathname-p - #:find-file + #:find-file #:find-file-read-only #:directory-of-buffer - #:set-visited-file-name + #:set-visited-filename #:check-file-times - #:save-buffer) + #:save-buffer + + #:input-from-stream + #:save-buffer-to-stream + #:make-buffer-from-stream) (:documentation "Package for editor functionality that is syntax-aware, but yet not specific to certain syntaxes. Contains stuff like indentation, filling and other @@ -439,7 +443,7 @@

(defpackage :climacs-prolog-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base - :climacs-syntax :flexichain :climacs-pane) + :climacs-syntax :flexichain :climacs-pane :climacs-core) (:shadow #:atom #:close #:exp #:integer #:open #:variable))

(defpackage :climacs-cl-syntax --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/27 19:55:26 1.21 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/08/20 13:06:39 1.22 @@ -255,8 +255,8 @@ (let* ((pane (current-window)) (point (point pane))) (insert-object point #\Newline) - (update-syntax (current-buffer) - (syntax (current-buffer))) + (update-syntax (current-buffer *application-frame*) + (syntax (current-buffer *application-frame*))) (indent-current-line pane point)))

(set-key 'com-newline-and-indent @@ -453,7 +453,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-buffer *application-frame*) syntax))

;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands --- /project/climacs/cvsroot/climacs/io.lisp 2006/03/03 19:38:57 1.4 +++ /project/climacs/cvsroot/climacs/io.lisp 2006/08/20 13:06:39 1.5 @@ -1,7 +1,9 @@ -;;; -*- Mode: Lisp; Package: CLIMACS-BUFFER -*- +;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*-

;;; (c) copyright 2004 by ;;; Robert Strandh (strandh@labri.fr) +;;; (c) copyright 2006 by +;;; Troels Henriksen (athas@sigkill.dk)

;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -20,20 +22,23 @@

;;; Input/Output of buffers to and from streams.

-(in-package :climacs-base) +(in-package :climacs-core) + +(defmethod save-buffer-to-stream ((buffer climacs-buffer) stream) + (let ((seq (buffer-sequence buffer 0 (size buffer)))) + (write-sequence seq stream)))

(defun input-from-stream (stream buffer offset) - (loop with vec = (make-array 10000 :element-type 'character) - for count = (#+mcclim read-sequence #-mcclim cl:read-sequence - vec stream) - while (plusp count) - do (if (= count (length vec)) - (insert-buffer-sequence buffer offset vec) - (insert-buffer-sequence buffer offset - (subseq vec 0 count))) - (incf offset count))) - -(defun output-to-stream (stream buffer offset1 offset2) - (loop for offset from offset1 below offset2 - when (characterp (buffer-object buffer offset)) - do (write-char (buffer-object buffer offset) stream))) + (let* ((seq (make-string (file-length stream))) + (count (#+mcclim read-sequence #-mcclim cl:read-sequence + seq stream))) + (if (= count (length seq)) + (insert-buffer-sequence buffer offset + (if (= count (length seq)) + seq + (subseq seq 0 count)))))) + +(defmethod make-buffer-from-stream (stream (application-frame climacs)) + (let* ((buffer (make-new-buffer application-frame))) + (input-from-stream stream buffer 0) + buffer)) --- /project/climacs/cvsroot/climacs/gui.lisp 2006/08/11 21:59:05 1.227 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/08/20 13:06:39 1.228 @@ -133,6 +133,7 @@ (kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring)) (:command-table (global-climacs-table :inherit-from (global-esa-table + esa-io-table keyboard-macro-table climacs-help-table base-table @@ -201,9 +202,9 @@ "Return the current panes point." (point (current-window)))

-(defun current-buffer () +(defmethod current-buffer ((application-frame climacs)) "Return the current buffer." - (buffer (current-window))) + (buffer (car (windows application-frame))))

(define-presentation-type read-only ()) (define-presentation-method highlight-presentation --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/08/01 16:06:37 1.23 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/08/20 13:06:39 1.24 @@ -24,7 +24,9 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA.

-;;; File (and buffer) commands for the Climacs editor. +;;; File (and buffer) commands for the Climacs editor. Note that many +;;; basic commands (such as Find File) are defined in ESA and made +;;; available to Climacs via the ESA-IO-TABLE command table.

(in-package :climacs-commands)

@@ -151,52 +153,6 @@ (update-attribute-line (buffer (current-window))) (evaluate-attribute-line (buffer (current-window))))

-(define-command (com-find-file :name t :command-table buffer-table) - ((filepath 'pathname - :prompt "Find File" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t)) - "Prompt for a filename then edit that file. -If a buffer is already visiting that file, switch to that buffer. Does not create a file if the filename given does not name an existing file." - (find-file filepath)) - -(set-key `(com-find-file ,*unsupplied-argument-marker*) - 'buffer-table - '((#\x :control) (#\f :control))) - -(define-command (com-find-file-read-only :name t :command-table buffer-table) - ((filepath 'pathname :Prompt "Find file read only" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t)) - "Prompt for a filename then open that file readonly. -If a buffer is already visiting that file, switch to that buffer. If the filename given does not name an existing file, signal an error." - (find-file filepath t)) - -(set-key `(com-find-file-read-only ,*unsupplied-argument-marker*) - 'buffer-table - '((#\x :control) (#\r :control))) - -(define-command (com-read-only :name t :command-table buffer-table) () - "Toggle the readonly status of the current buffer. -When a buffer is readonly, attempts to change the contents of the buffer signal an error." - (let ((buffer (buffer (current-window)))) - (setf (read-only-p buffer) (not (read-only-p buffer))))) - -(set-key 'com-read-only - 'buffer-table - '((#\x :control) (#\q :control))) - -(define-command (com-set-visited-file-name :name t :command-table buffer-table) - ((filename 'pathname :prompt "New file name" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t)) - "Prompt for a new filename for the current buffer. -The next time the buffer is saved it will be saved to a file with that filename." - (set-visited-file-name filename (buffer (current-window)))) - (define-command (com-insert-file :name t :command-table buffer-table) ((filename 'pathname :prompt "Insert File" :default (directory-of-buffer (buffer (current-window))) @@ -243,42 +199,6 @@ (display-message "No file ~A" filepath) (beep))))))

-(define-command (com-save-buffer :name t :command-table buffer-table) () - "Write the contents of the buffer to a file. -If there is filename associated with the buffer, write to that file, replacing its contents. If not, prompt for a filename." - (let ((buffer (buffer (current-window)))) - (if (or (null (filepath buffer)) - (needs-saving buffer)) - (save-buffer buffer) - (display-message "No changes need to be saved from ~a" (name buffer))))) - -(set-key 'com-save-buffer - 'buffer-table - '((#\x :control) (#\s :control))) - -(define-command (com-write-buffer :name t :command-table buffer-table) - ((filepath 'pathname :prompt "Write Buffer to File" - :default (directory-of-buffer (buffer (current-window))) - :default-type 'pathname - :insert-default t)) - "Prompt for a filename and write the current buffer to it. -Changes the file visted by the buffer to the given file." - (let ((buffer (buffer (current-window)))) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory name." filepath)) - (t - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (output-to-stream stream buffer 0 (size buffer))) - (setf (filepath buffer) filepath - (name buffer) (filepath-filename filepath) - (needs-saving buffer) nil) - (display-message "Wrote: ~a" (filepath buffer)))))) - -(set-key `(com-write-buffer ,*unsupplied-argument-marker*) - 'buffer-table - '((#\x :control) (#\w :control))) - (defun load-file (file-name) (cond ((directory-pathname-p file-name) (display-message "~A is a directory name." file-name) @@ -334,7 +254,7 @@ '((#\x :control) (#\k)))

(define-command (com-toggle-read-only :name t :command-table base-table) - ((buffer 'buffer :default (current-buffer))) + ((buffer 'buffer :default (current-buffer *application-frame*))) (setf (read-only-p buffer) (not (read-only-p buffer))))

(define-presentation-to-command-translator toggle-read-only @@ -344,7 +264,7 @@ (list object))

(define-command (com-toggle-modified :name t :command-table base-table) - ((buffer 'buffer :default (current-buffer))) + ((buffer 'buffer :default (current-buffer *application-frame*))) (setf (needs-saving buffer) (not (needs-saving buffer))))

(define-presentation-to-command-translator toggle-modified --- /project/climacs/cvsroot/climacs/core.lisp 2006/08/11 18:49:48 1.4 +++ /project/climacs/cvsroot/climacs/core.lisp 2006/08/20 13:06:39 1.5 @@ -336,10 +336,14 @@ ;;; ;;; Buffer handling

-(defun make-buffer (&optional name) +(defmethod make-new-buffer ((application-frame climacs)) (let ((buffer (make-instance 'climacs-buffer))) + (push buffer (buffers application-frame)) + buffer)) + +(defun make-new-named-buffer (&optional name) + (let ((buffer (make-new-buffer *application-frame*))) (when name (setf (name buffer) name)) - (push buffer (buffers *application-frame*)) buffer))

(defgeneric erase-buffer (buffer)) @@ -399,7 +403,7 @@ (let ((buffer (find name (buffers *application-frame*) :key #'name :test #'string=))) (switch-to-buffer (or buffer - (make-buffer name))))) + (make-new-named-buffer name)))))

;;placeholder (defmethod switch-to-buffer ((symbol (eql 'nil))) @@ -422,11 +426,11 @@ (error () (progn (beep) (display-message "Invalid answer") (return-from kill-buffer nil))))) - (save-buffer buffer)) + (save-buffer buffer *application-frame*)) (setf buffers (remove buffer buffers)) ;; Always need one buffer. (when (null buffers) - (make-buffer "*scratch*")) + (make-new-named-buffer "*scratch*")) (setf (buffer (current-window)) (car buffers)) (full-redisplay (current-window)) (buffer (current-window)))) @@ -594,7 +598,7 @@ (and (or (null name) (eql name :unspecific)) (or (null type) (eql type :unspecific)))))

-(defun find-file (filepath &optional readonlyp) +(defun find-file-impl (filepath &optional readonlyp) (cond ((null filepath) (display-message "No file name given.") (beep)) @@ -603,9 +607,9 @@ (beep)) (t (flet ((usable-pathname (pathname) - (if (probe-file pathname) - (truename pathname) - pathname))) + (if (probe-file pathname) + (truename pathname) + pathname))) (let ((existing-buffer (find filepath (buffers *application-frame*) :key #'filepath :test #'(lambda (fp1 fp2) @@ -619,36 +623,36 @@ (unless (probe-file filepath) (beep) (display-message "No such file: ~A" filepath) - (return-from find-file nil))) - (let ((buffer (make-buffer)) + (return-from find-file-impl nil))) + (let ((buffer (if (probe-file filepath) + (with-open-file (stream filepath :direction :input) + (make-buffer-from-stream stream *application-frame*)) + (make-new-buffer *application-frame*))) (pane (current-window))) ;; Clear the pane's cache; otherwise residue from the ;; previously displayed buffer may under certain ;; circumstances be displayed. (clear-cache pane) - (setf (syntax buffer) nil) - (setf (offset (point (buffer pane))) (offset (point pane))) - (setf (buffer (current-window)) buffer) - (setf (syntax buffer) - (make-instance (syntax-class-name-for-filepath filepath) - :buffer buffer)) - ;; Don't want to create the file if it doesn't exist. - (when (probe-file filepath) - (with-open-file (stream filepath :direction :input) - (input-from-stream stream buffer 0)) - (setf (file-write-time buffer) (file-write-date filepath)) - ;; A file! That means we may have a local options - ;; line to parse. - (evaluate-attribute-line buffer)) + (setf (offset (point (buffer pane))) (offset (point pane)) + (buffer (current-window)) 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) - (needs-saving buffer) nil (read-only-p buffer) readonlyp) (beginning-of-buffer (point pane)) (update-syntax buffer (syntax buffer)) (clear-modify buffer) buffer))))))))

+(defmethod find-file (filepath (application-frame climacs)) + (find-file-impl filepath nil)) + +(defmethod find-file-read-only (filepath (application-frame climacs)) + (find-file-impl filepath t)) + (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 @@ -659,34 +663,13 @@ (or (filepath buffer) (user-homedir-pathname)))))

-(defun set-visited-file-name (filename buffer) - (setf (filepath buffer) filename +(defmethod set-visited-filename (filepath buffer (application-frame climacs)) + (setf (filepath buffer) filepath (file-saved-p buffer) nil (file-write-time buffer) nil - (name buffer) (filepath-filename filename) + (name buffer) (filepath-filename filepath) (needs-saving buffer) t))

-(defun extract-version-number (pathname) - "Extracts the emacs-style version-number from a pathname." - (let* ((type (pathname-type pathname)) - (length (length type))) - (when (and (> length 2) (char= (char type (1- length)) #~)) - (let ((tilde (position #~ type :from-end t :end (- length 2)))) - (when tilde - (parse-integer type :start (1+ tilde) :junk-allowed t)))))) - -(defun version-number (pathname) - "Return the number of the highest versioned backup of PATHNAME -or 0 if there is no versioned backup. Looks for name.type~X~, -returns highest X." - (let* ((wildpath (merge-pathnames (make-pathname :type :wild) pathname)) - (possibilities (directory wildpath))) - (loop for possibility in possibilities - for version = (extract-version-number possibility) - if (numberp version) - maximize version into max - finally (return max)))) - (defun check-file-times (buffer filepath question answer) "Return NIL if filepath newer than buffer and user doesn't want to overwrite." @@ -701,32 +684,6 @@ nil)) t)))

-(defun save-buffer (buffer) - (let ((filepath (or (filepath buffer) - (accept 'pathname :prompt "Save Buffer to File")))) - (cond - ((directory-pathname-p filepath) - (display-message "~A is a directory." filepath) - (beep)) - (t - (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from save-buffer)) - (when (and (probe-file filepath) (not (file-saved-p buffer))) - (let ((backup-name (pathname-name filepath)) - (backup-type (format nil "~A~~~D~~" - (pathname-type filepath) - (1+ (version-number filepath))))) - (rename-file filepath (make-pathname :name backup-name - :type backup-type))) - (setf (file-saved-p buffer) t)) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (output-to-stream stream buffer 0 (size buffer))) - (setf (filepath buffer) filepath - (file-write-time buffer) (file-write-date filepath) - (name buffer) (filepath-filename filepath)) - (display-message "Wrote: ~a" filepath) - (setf (needs-saving buffer) nil))))) - (defmethod frame-exit :around ((frame climacs) #-mcclim &key) (loop for buffer in (buffers frame) when (and (needs-saving buffer) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/27 10:39:32 1.50 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/08/20 13:06:39 1.51 @@ -63,7 +63,6 @@ :depends-on ("packages" "buffer" "Persistent"))

(:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring")) - (:file "io" :depends-on ("packages" "buffer")) (:file "abbrev" :depends-on ("packages" "buffer" "base")) (:file "syntax" :depends-on ("packages" "buffer" "base")) (:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax" "motion")) @@ -86,14 +85,16 @@ "pane")) (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" "window-commands" "gui")) - (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands" - "misc-commands" "window-commands" "file-commands" "core")) + (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "motion-commands" + "editing-commands" "misc-commands")) #.(if (find-swank) '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) (values)) (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" - "kill-ring" "io" "text-syntax" + "kill-ring" "text-syntax" "abbrev" "editing" "motion")) + (:file "io" :depends-on ("packages" "gui")) (:file "core" :depends-on ("gui")) (:file "climacs" :depends-on ("gui" "core")) ;; (:file "buffer-commands" :depends-on ("gui")) --- /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 16:33:16 1.57 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/08/20 13:06:39 1.58 @@ -297,8 +297,6 @@ ;;; ;;; Named objects

-(defgeneric name (obj)) - (defclass name-mixin () ((name :initarg :name :accessor name)))