[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Tue Jul 25 11:38:05 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv1535
Modified Files:
slidemacs-gui.lisp search-commands.lisp packages.lisp
motion.lisp misc-commands.lisp lisp-syntax.lisp gui.lisp
file-commands.lisp core.lisp climacs.asd
Log Message:
More refactoring of stuff out from CLIMACS-GUI to CLIMACS-CORE and
CLIMACS-COMMANDS. More reusable functions have been moved from the
*-commands.lisp files to core.lisp.
--- /project/climacs/cvsroot/climacs/slidemacs-gui.lisp 2006/03/03 19:38:57 1.22
+++ /project/climacs/cvsroot/climacs/slidemacs-gui.lisp 2006/07/25 11:38:05 1.23
@@ -530,11 +530,11 @@
(full-redisplay (climacs-gui::current-window)))
(define-command (com-first-talking-point :name t :command-table slidemacs-table) ()
- (climacs-gui::com-beginning-of-buffer)
+ (climacs-commands::com-beginning-of-buffer)
(com-next-talking-point))
(define-command (com-last-talking-point :name t :command-table slidemacs-table) ()
- (climacs-gui::com-end-of-buffer)
+ (climacs-commands::com-end-of-buffer)
(com-previous-talking-point))
(define-command (com-flip-slidemacs-syntax :name t :command-table slidemacs-table) ()
--- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 16:33:16 1.10
+++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/25 11:38:05 1.11
@@ -28,37 +28,6 @@
(in-package :climacs-commands)
-(defun display-string (string)
- (with-output-to-string (result)
- (loop for char across string
- do (cond ((graphic-char-p char) (princ char result))
- ((char= char #\Space) (princ char result))
- (t (prin1 char result))))))
-
-(defun object-equal (x y)
- "Case insensitive equality that doesn't require characters"
- (if (characterp x)
- (and (characterp y) (char-equal x y))
- (eql x y)))
-
-(defun object= (x y)
- "Case sensitive equality that doesn't require characters"
- (if (characterp x)
- (and (characterp y) (char= x y))
- (eql x y)))
-
-(defun no-upper-p (string)
- "Does STRING contain no uppercase characters"
- (notany #'upper-case-p string))
-
-(defun case-relevant-test (string)
- "Returns a test function based on the search-string STRING.
-If STRING contains no uppercase characters the test is case-insensitive,
-otherwise it is case-sensitive."
- (if (no-upper-p string)
- #'object-equal
- #'object=))
-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; String search
--- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 16:33:16 1.107
+++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/25 11:38:05 1.108
@@ -329,16 +329,14 @@
#:point
#:syntax
#:mark
+ #:buffers
#:insert-character
- #:switch-to-buffer
- #:make-buffer
- #:erase-buffer
- #:buffer-pane-p
#:display-window
#:split-window
#:typeout-window
#:delete-window
#:other-window
+ #:buffer-pane-p
;; Some configuration variables
#:*bg-color*
@@ -368,8 +366,14 @@
(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)
- (:export #:goto-position
+ :climacs-editing :climacs-gui :clim :climacs-abbrev :esa)
+ (:export #:display-string
+ #:object-equal
+ #:object=
+ #:no-upper-p
+ #:case-relevant-test
+
+ #:goto-position
#:goto-line
#:possibly-fill-line
@@ -384,7 +388,23 @@
#:indent-region
#:fill-line #:fill-region
- #:indent-line #:delete-indentation)
+ #:indent-line #:delete-indentation
+
+ #:set-syntax
+
+ #:switch-to-buffer
+ #:make-buffer
+ #:erase-buffer
+ #:kill-buffer
+
+ #:filepath-filename
+ #:evaluate-attributes-line
+ #:directory-pathname-p
+ #:find-file
+ #:directory-of-buffer
+ #:set-visited-file-name
+ #:check-file-times
+ #:save-buffer)
(:documentation "Package for editor functionality that is
syntax-aware, but yet not specific to certain
syntaxes. Contains stuff like indentation, filling and other
@@ -424,7 +444,8 @@
(defpackage :climacs-lisp-syntax
(:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base
- :climacs-syntax :flexichain :climacs-pane :climacs-gui :climacs-motion :climacs-editing)
+ :climacs-syntax :flexichain :climacs-pane :climacs-gui
+ :climacs-motion :climacs-editing :climacs-core)
(:export #:lisp-string
#:edit-definition))
--- /project/climacs/cvsroot/climacs/motion.lisp 2006/06/12 19:10:58 1.1
+++ /project/climacs/cvsroot/climacs/motion.lisp 2006/07/25 11:38:05 1.2
@@ -88,7 +88,7 @@
(defun beep-limit-action (mark original-offset remaining unit syntax)
(declare (ignore mark original-offset remaining unit syntax))
- (beep)
+ (clim:beep)
nil)
(defun revert-limit-action (mark original-offset remaining unit syntax)
--- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 16:33:16 1.18
+++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/25 11:38:05 1.19
@@ -445,24 +445,6 @@
'marking-table
'((#\x :control) (#\x :control)))
-(defgeneric set-syntax (buffer syntax))
-
-(defmethod set-syntax ((buffer climacs-buffer) (syntax syntax))
- (setf (syntax buffer) syntax))
-
-;;FIXME - what should this specialise on?
-(defmethod set-syntax ((buffer climacs-buffer) syntax)
- (set-syntax buffer (make-instance syntax :buffer buffer)))
-
-(defmethod set-syntax ((buffer climacs-buffer) (syntax string))
- (let ((syntax-class (syntax-from-name syntax)))
- (cond (syntax-class
- (set-syntax buffer (make-instance syntax-class
- :buffer buffer)))
- (t
- (beep)
- (display-message "No such syntax: ~A." syntax)))))
-
(define-command (com-set-syntax :name t :command-table buffer-table)
((syntax 'syntax
:prompt "Name of syntax"))
--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/24 20:52:23 1.99
+++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/25 11:38:05 1.100
@@ -52,7 +52,7 @@
(make-command-table 'lisp-table
:errorp nil
- :inherit-from '(climacs-gui::global-climacs-table))
+ :inherit-from '(global-climacs-table))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -97,6 +97,9 @@
(or (slot-value syntax 'base)
*read-base*)))
+(defmethod (setf base) (base (syntax lisp-syntax))
+ (setf (slot-value syntax 'base) base))
+
(define-option-for-syntax lisp-syntax "Package" (syntax package-name)
(let ((specified-package (find-package package-name)))
(setf (option-specified-package syntax) (or specified-package package-name))))
@@ -104,7 +107,9 @@
(define-option-for-syntax lisp-syntax "Base" (syntax base)
(let ((integer-base (parse-integer base :junk-allowed t)))
(when integer-base
- (setf (base syntax) integer-base))))
+ (if (typep integer-base '(integer 2 36))
+ (setf (base syntax) integer-base)
+ (esa:display-message "Invalid base specified: outside the interval 2 to 36.")))))
(defmethod initialize-instance :after ((syntax lisp-syntax) &rest args)
(declare (ignore args))
@@ -3010,7 +3015,7 @@
(def-print-for-menu note-compiler-note "Note" +brown+)
(defun show-notes (notes buffer-name definition)
- (let ((stream (climacs-gui::typeout-window
+ (let ((stream (typeout-window
(format nil "~10TCompiler Notes: ~A ~A" buffer-name definition))))
(loop for note in notes
do (with-output-as-presentation (stream note 'compiler-note)
@@ -3028,33 +3033,27 @@
(defmethod goto-location ((location buffer-location))
(let ((buffer (find (buffer-name location)
- (climacs-gui::buffers *application-frame*)
+ (buffers *application-frame*)
:test #'string= :key #'name)))
(unless buffer
(esa:display-message "No buffer ~A" (buffer-name location))
(beep)
(return-from goto-location))
- (climacs-gui::switch-to-buffer buffer)
+ (switch-to-buffer buffer)
(goto-position (source-position location))))
(defmethod goto-location ((location file-location))
(let ((buffer (find (file-name location)
- (climacs-gui::buffers *application-frame*)
+ (buffers *application-frame*)
:test #'string= :key #'(lambda (buffer)
(let ((path (filepath buffer)))
(when path
(namestring path)))))))
(if buffer
- (climacs-gui::switch-to-buffer buffer)
- (climacs-gui::find-file (file-name location)))
+ (switch-to-buffer buffer)
+ (climacs-commands::find-file (file-name location)))
(goto-position (source-position location))))
-(defgeneric goto-position (position))
-
-(defmethod goto-position ((position char-position))
- (climacs-gui::goto-position (climacs-gui::point (climacs-gui::current-window))
- (char-position position)))
-
;;; Macroexpansion and evaluation
(defun macroexpand-token (syntax token &optional (all nil))
@@ -3067,12 +3066,12 @@
all))
(expansion-string (with-output-to-string (s)
(pprint expansion s))))
- (let ((buffer (climacs-gui::switch-to-buffer "*Macroexpansion*")))
- (climacs-gui::set-syntax buffer "Lisp"))
- (let ((point (point (climacs-gui::current-window)))
+ (let ((buffer (switch-to-buffer "*Macroexpansion*")))
+ (set-syntax buffer "Lisp"))
+ (let ((point (point (current-window)))
(header-string (one-line-ify (subseq string 0
(min 40 (length string))))))
- (climacs-gui::end-of-buffer point)
+ (end-of-buffer point)
(unless (beginning-of-buffer-p point)
(insert-object point #\Newline))
(insert-sequence point
@@ -3130,7 +3129,7 @@
(defun compile-file-interactively (buffer &optional load-p)
(when (and (needs-saving buffer)
(accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer))))
- (climacs-gui::save-buffer buffer))
+ (save-buffer buffer))
(with-syntax-package (syntax buffer) 0 (package)
(let ((*read-base* (base (syntax buffer))))
(multiple-value-bind (result notes)
@@ -3745,9 +3744,9 @@
(let* ((offset+buffer (pop *find-definition-stack*))
(offset (first offset+buffer))
(buffer (second offset+buffer)))
- (if (find buffer (climacs-gui::buffers *application-frame*))
- (progn (climacs-gui::switch-to-buffer buffer)
- (climacs-gui::goto-position (point (climacs-gui::current-window)) offset))
+ (if (find buffer (buffers *application-frame*))
+ (progn (switch-to-buffer buffer)
+ (goto-position (point (current-window)) offset))
(pop-find-definition-stack)))))
;; KLUDGE: We need to put more info in the definition objects to begin
@@ -3780,7 +3779,7 @@
(goto-definition symbol definitions))))))
(defun goto-definition (name definitions)
- (let* ((pane (climacs-gui:current-window))
+ (let* ((pane (current-window))
(buffer (buffer pane))
(point (point pane))
(offset (offset point)))
@@ -3820,7 +3819,7 @@
(with-drawing-options (stream :ink +dark-blue+
:text-style (make-text-style :fixed nil nil))
(princ (dspec item) stream))))
- (let ((stream (climacs-gui::typeout-window
+ (let ((stream (typeout-window
(format nil "~10T~A ~A" type symbol))))
(loop for xref in xrefs
do (with-output-as-presentation (stream xref 'xref)
@@ -3938,7 +3937,7 @@
(defun clear-completions ()
(when *completion-pane*
- (climacs-gui::delete-window *completion-pane*)
+ (delete-window *completion-pane*)
(setf *completion-pane* nil)))
(defun show-completions-by-fn (fn symbol package)
@@ -3949,7 +3948,7 @@
(cond ((<=(length set) 1)
(clear-completions))
(t (let ((stream (or *completion-pane*
- (climacs-gui::typeout-window "Simple Completions"))))
+ (typeout-window "Simple Completions"))))
(setf *completion-pane* stream)
(window-clear stream)
(format stream "~{~A~%~}" set))))
@@ -3982,7 +3981,7 @@
(cond ((<= (length set) 1)
(clear-completions))
(t (let ((stream (or *completion-pane*
- (climacs-gui::typeout-window "Simple Completions"))))
+ (typeout-window "Simple Completions"))))
(setf *completion-pane* stream)
(window-clear stream)
(loop for completed-string in set
--- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 16:33:16 1.224
+++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/25 11:38:05 1.225
@@ -214,24 +214,6 @@
((type modified) record stream state)
nil)
-(define-command (com-toggle-read-only :name t :command-table base-table)
- ((buffer 'buffer))
- (setf (read-only-p buffer) (not (read-only-p buffer))))
-(define-presentation-to-command-translator toggle-read-only
- (read-only com-toggle-read-only base-table
- :gesture :menu)
- (object)
- (list object))
-
-(define-command (com-toggle-modified :name t :command-table base-table)
- ((buffer 'buffer))
- (setf (needs-saving buffer) (not (needs-saving buffer))))
-(define-presentation-to-command-translator toggle-modified
- (modified com-toggle-modified base-table
- :gesture :menu)
- (object)
- (list object))
-
(defun display-info (frame pane)
(let* ((master-pane (master-pane pane))
(buffer (buffer master-pane))
@@ -352,27 +334,6 @@
'base-table
'((#\l :control)))
-(defun load-file (file-name)
- (cond ((directory-pathname-p file-name)
- (display-message "~A is a directory name." file-name)
- (beep))
- (t
- (cond ((probe-file file-name)
- (load file-name))
- (t
- (display-message "No such file: ~A" file-name)
- (beep))))))
-
-(define-command (com-load-file :name t :command-table base-table) ()
- "Prompt for a filename and CL:LOAD that file.
-Signals and error if the file does not exist."
- (let ((filepath (accept 'pathname :prompt "Load File")))
- (load-file filepath)))
-
-(set-key 'com-load-file
- 'base-table
- '((#\c :control) (#\l :control)))
-
(define-command com-self-insert ((count 'integer))
(loop repeat count do (insert-character *current-gesture*)))
@@ -387,7 +348,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
-;;; Pane/buffer functions
+;;; Pane functions
(defun replace-constellation (constellation additional-constellation vertical-p)
(let* ((parent (sheet-parent constellation))
@@ -530,12 +491,6 @@
(list first second other)
(list first other)))))))
-(defun make-buffer (&optional name)
- (let ((buffer (make-instance 'climacs-buffer)))
- (when name (setf (name buffer) name))
- (push buffer (buffers *application-frame*))
- buffer))
-
(defun other-window (&optional pane)
(if (and pane (find pane (windows *application-frame*)))
(setf (windows *application-frame*)
@@ -550,132 +505,6 @@
(other-window)
(setf *standard-output* (car (windows *application-frame*)))))
-(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 climacs-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)
- (declare (ignore acceptably for-context-type))
- (princ (name object) stream))
-
-(define-presentation-method accept
- ((type buffer) 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
- :value-key #'identity))
- :partial-completers '(#\Space)
- :allow-any-input t)
- (cond (success
- (values object type))
- ((and (zerop (length string)) defaultp)
- (values default default-type))
- (t (values string 'string)))))
-
-(defgeneric switch-to-buffer (buffer))
-
-(defmethod switch-to-buffer ((buffer climacs-buffer))
- (let* ((buffers (buffers *application-frame*))
- (position (position buffer buffers))
- (pane (current-window)))
- (when position
- (setf buffers (delete buffer buffers)))
- (push buffer (buffers *application-frame*))
- (setf (offset (point (buffer pane))) (offset (point pane)))
- (setf (buffer pane) buffer)
- (full-redisplay pane)
- buffer))
-
-(defmethod switch-to-buffer ((name string))
- (let ((buffer (find name (buffers *application-frame*)
- :key #'name :test #'string=)))
- (switch-to-buffer (or buffer
- (make-buffer name)))))
-
-;;placeholder
-(defmethod switch-to-buffer ((symbol (eql 'nil)))
- (let ((default (second (buffers *application-frame*))))
- (when default
- (switch-to-buffer default))))
-
-;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR,
-;; ;;; 2005-10-31.
-;; (defmethod (setf buffer) :around (buffer (pane extended-pane))
-;; (call-next-method)
-;; (note-pane-syntax-changed pane (syntax buffer)))
-
-(define-command (com-switch-to-buffer :name t :command-table pane-table) ()
- "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."
- (let* ((default (second (buffers *application-frame*)))
- (buffer (if default
- (accept 'buffer
- :prompt "Switch to buffer"
- :default default)
- (accept 'buffer
- :prompt "Switch to buffer"))))
- (switch-to-buffer buffer)))
-
-(set-key 'com-switch-to-buffer
- 'pane-table
- '((#\x :control) (#\b)))
-
-(defgeneric kill-buffer (buffer))
-
-(defmethod kill-buffer ((buffer climacs-buffer))
- (with-slots (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)))))
- (com-save-buffer))
- (setf buffers (remove buffer buffers))
- ;; Always need one buffer.
- (when (null buffers)
- (make-buffer "*scratch*"))
- (setf (buffer (current-window)) (car buffers))
- (full-redisplay (current-window))
- (buffer (current-window))))
-
-(defmethod kill-buffer ((name string))
- (let ((buffer (find name (buffers *application-frame*)
- :key #'name :test #'string=)))
- (when buffer (kill-buffer buffer))))
-
-(defmethod kill-buffer ((symbol (eql 'nil)))
- (kill-buffer (buffer (current-window))))
-
-(define-command (com-kill-buffer :name t :command-table pane-table)
- ((buffer 'buffer
- :prompt "Kill buffer"
- :default (buffer (current-window))
- :default-type '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))
-
-(set-key `(com-kill-buffer ,*unsupplied-argument-marker*)
- 'pane-table
- '((#\x :control) (#\k)))
-
;;; For the ESA help functions.
(defmethod help-stream ((frame climacs) title)
--- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/07/24 13:24:40 1.21
+++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/07/25 11:38:05 1.22
@@ -24,7 +24,7 @@
;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;;; Boston, MA 02111-1307 USA.
-;;; File commands for the Climacs editor.
+;;; File (and buffer) commands for the Climacs editor.
(in-package :climacs-commands)
@@ -113,99 +113,6 @@
(values default default-type))
(t (values string 'string)))))
-(defun filepath-filename (pathname)
- (if (null (pathname-type pathname))
- (pathname-name pathname)
- (concatenate 'string (pathname-name pathname)
- "." (pathname-type pathname))))
-
-(defun syntax-class-name-for-filepath (filepath)
- (or (climacs-syntax::syntax-description-class-name
- (find (or (pathname-type filepath)
- (pathname-name filepath))
- climacs-syntax::*syntaxes*
- :test (lambda (x y)
- (member x y :test #'string-equal))
- :key #'climacs-syntax::syntax-description-pathname-types))
- 'basic-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."
- ;; 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,
- ;; only the first will be acted upon.
- (let ((specified-syntax
- (syntax-from-name
- (second (find-if #'(lambda (name)
- (or (string-equal name "SYNTAX")
- (string-equal name "MODE")))
- options
- :key #'first)))))
- (when specified-syntax
- (setf (syntax buffer)
- (make-instance specified-syntax
- :buffer buffer))))
- ;; 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)))
-
-(defun split-attribute (string char)
- (let (pairs)
- (loop with start = 0
- for ch across string
- for i from 0
- when (eql ch char)
- do (push (string-trim '(#\Space #\Tab) (subseq string start i))
- pairs)
- (setf start (1+ i))
- finally (unless (>= start i)
- (push (string-trim '(#\Space #\Tab) (subseq string start))
- pairs)))
- (nreverse pairs)))
-
-(defun split-attribute-line (line)
- (mapcar (lambda (pair) (split-attribute pair #\:))
- (split-attribute line #\;)))
-
-(defun get-attribute-line (buffer)
- (let ((scan (beginning-of-buffer (clone-mark (point buffer)))))
- ;; skip the leading whitespace
- (loop until (end-of-buffer-p scan)
- until (not (whitespacep (syntax buffer) (object-after scan)))
- do (forward-object scan))
- ;; stop looking if we're already 1,000 objects into the buffer
- (unless (> (offset scan) 1000)
- (let ((start-found
- (loop with newlines = 0
- when (end-of-buffer-p scan)
- do (return nil)
- when (eql (object-after scan) #\Newline)
- do (incf newlines)
- when (> newlines 1)
- do (return nil)
- do (forward-object scan)
- until (looking-at scan "-*-")
- finally (return t))))
- (when start-found
- (let ((line (buffer-substring buffer
- (offset scan)
- (offset (end-of-line (clone-mark scan))))))
- (when (>= (length line) 6)
- (let ((end (search "-*-" line :from-end t :start2 3)))
- (when end
- (string-trim '(#\Space #\Tab) (subseq line 3 end)))))))))))
-
-(defun evaluate-attributes-line (buffer)
- (evaluate-attributes
- buffer
- (split-attribute-line (get-attribute-line buffer))))
-
(define-command (com-reparse-attribute-list :name t :command-table buffer-table) ()
"Reparse the current buffer's attribute list.
An attribute list is a line of keyword-value pairs, each keyword separated
@@ -220,82 +127,6 @@
;; -*- Syntax: Lisp; Base: 10 -*- "
(evaluate-attributes-line (buffer (current-window))))
-;; Adapted from cl-fad/PCL
-(defun directory-pathname-p (pathspec)
- "Returns NIL if PATHSPEC does not designate a directory."
- (let ((name (pathname-name pathspec))
- (type (pathname-type pathspec)))
- (and (or (null name) (eql name :unspecific))
- (or (null type) (eql type :unspecific)))))
-
-(defun find-file (filepath &optional readonlyp)
- (cond ((null filepath)
- (display-message "No file name given.")
- (beep))
- ((directory-pathname-p filepath)
- (display-message "~A is a directory name." filepath)
- (beep))
- (t
- (flet ((usable-pathname (pathname)
- (if (probe-file pathname)
- (truename pathname)
- pathname)))
- (let ((existing-buffer (find filepath (buffers *application-frame*)
- :key #'filepath
- :test #'(lambda (fp1 fp2)
- (and fp1 fp2
- (equal (usable-pathname fp1)
- (usable-pathname fp2)))))))
- (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
- (switch-to-buffer existing-buffer)
- (progn
- (when readonlyp
- (unless (probe-file filepath)
- (beep)
- (display-message "No such file: ~A" filepath)
- (return-from find-file nil)))
- (let ((buffer (make-buffer))
- (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)
- ;; 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-attributes-line buffer))
- ;; If the local options line didn't set a syntax, do
- ;; it now.
- (when (null (syntax buffer))
- (setf (syntax buffer)
- (make-instance (syntax-class-name-for-filepath filepath)
- :buffer 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))))))))
-
-(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."
- (make-pathname
- :directory
- (pathname-directory
- (or (filepath buffer)
- (user-homedir-pathname)))))
-
(define-command (com-find-file :name t :command-table buffer-table)
((filepath 'pathname
:prompt "Find File"
@@ -333,13 +164,6 @@
'buffer-table
'((#\x :control) (#\q :control)))
-(defun set-visited-file-name (filename buffer)
- (setf (filepath buffer) filename
- (file-saved-p buffer) nil
- (file-write-time buffer) nil
- (name buffer) (filepath-filename filename)
- (needs-saving buffer) t))
-
(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)))
@@ -395,66 +219,6 @@
(display-message "No file ~A" filepath)
(beep))))))
-(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"
- (let ((f-w-d (file-write-date filepath))
- (f-w-t (file-write-time buffer)))
- (if (and f-w-d f-w-t (> f-w-d f-w-t))
- (if (accept 'boolean
- :prompt (format nil "File has changed on disk. ~a anyway?"
- question))
- t
- (progn (display-message "~a not ~a" filepath answer)
- 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)))))
-
(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."
@@ -468,24 +232,6 @@
'buffer-table
'((#\x :control) (#\s :control)))
-(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?")
- (error () (progn (beep)
- (display-message "Invalid answer")
- (return-from frame-exit nil)))))
- (call-next-method)))
-
(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)))
@@ -509,3 +255,76 @@
'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)
+ (beep))
+ (t
+ (cond ((probe-file file-name)
+ (load file-name))
+ (t
+ (display-message "No such file: ~A" file-name)
+ (beep))))))
+
+(define-command (com-load-file :name t :command-table base-table) ()
+ "Prompt for a filename and CL:LOAD that file.
+Signals and error if the file does not exist."
+ (let ((filepath (accept 'pathname :prompt "Load File")))
+ (load-file filepath)))
+
+(set-key 'com-load-file
+ 'base-table
+ '((#\c :control) (#\l :control)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Buffer commands
+
+(define-command (com-switch-to-buffer :name t :command-table pane-table) ()
+ "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."
+ (let* ((default (second (buffers *application-frame*)))
+ (buffer (if default
+ (accept 'buffer
+ :prompt "Switch to buffer"
+ :default default)
+ (accept 'buffer
+ :prompt "Switch to buffer"))))
+ (switch-to-buffer buffer)))
+
+(set-key 'com-switch-to-buffer
+ 'pane-table
+ '((#\x :control) (#\b)))
+
+(define-command (com-kill-buffer :name t :command-table pane-table)
+ ((buffer 'buffer
+ :prompt "Kill buffer"
+ :default (buffer (current-window))
+ :default-type '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))
+
+(set-key `(com-kill-buffer ,*unsupplied-argument-marker*)
+ 'pane-table
+ '((#\x :control) (#\k)))
+
+(define-command (com-toggle-read-only :name t :command-table base-table)
+ ((buffer 'buffer :default (current-buffer)))
+ (setf (read-only-p buffer) (not (read-only-p buffer))))
+
+(define-presentation-to-command-translator toggle-read-only
+ (read-only com-toggle-read-only base-table
+ :gesture :menu)
+ (object)
+ (list object))
+
+(define-command (com-toggle-modified :name t :command-table base-table)
+ ((buffer 'buffer :default (current-buffer)))
+ (setf (needs-saving buffer) (not (needs-saving buffer))))
+
+(define-presentation-to-command-translator toggle-modified
+ (modified com-toggle-modified base-table
+ :gesture :menu)
+ (object)
+ (list object))
\ No newline at end of file
--- /project/climacs/cvsroot/climacs/core.lisp 2006/07/24 14:18:59 1.1
+++ /project/climacs/cvsroot/climacs/core.lisp 2006/07/25 11:38:05 1.2
@@ -17,6 +17,37 @@
;;;
;;; Misc stuff
+(defun display-string (string)
+ (with-output-to-string (result)
+ (loop for char across string
+ do (cond ((graphic-char-p char) (princ char result))
+ ((char= char #\Space) (princ char result))
+ (t (prin1 char result))))))
+
+(defun object-equal (x y)
+ "Case insensitive equality that doesn't require characters"
+ (if (characterp x)
+ (and (characterp y) (char-equal x y))
+ (eql x y)))
+
+(defun object= (x y)
+ "Case sensitive equality that doesn't require characters"
+ (if (characterp x)
+ (and (characterp y) (char= x y))
+ (eql x y)))
+
+(defun no-upper-p (string)
+ "Does STRING contain no uppercase characters"
+ (notany #'upper-case-p string))
+
+(defun case-relevant-test (string)
+ "Returns a test function based on the search-string STRING.
+If STRING contains no uppercase characters the test is case-insensitive,
+otherwise it is case-sensitive."
+ (if (no-upper-p string)
+ #'object-equal
+ #'object=))
+
(defun possibly-fill-line ()
(let* ((pane (current-window))
(buffer (buffer pane)))
@@ -278,3 +309,391 @@
(when (and (not (beginning-of-buffer-p mark))
(constituentp (object-before mark)))
(insert-object mark #\Space))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Syntax handling
+
+(defgeneric set-syntax (buffer syntax))
+
+(defmethod set-syntax ((buffer climacs-buffer) (syntax syntax))
+ (setf (syntax buffer) syntax))
+
+;;FIXME - what should this specialise on?
+(defmethod set-syntax ((buffer climacs-buffer) syntax)
+ (set-syntax buffer (make-instance syntax :buffer buffer)))
+
+(defmethod set-syntax ((buffer climacs-buffer) (syntax string))
+ (let ((syntax-class (syntax-from-name syntax)))
+ (cond (syntax-class
+ (set-syntax buffer (make-instance syntax-class
+ :buffer buffer)))
+ (t
+ (beep)
+ (display-message "No such syntax: ~A." syntax)))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; Buffer handling
+
+(defun make-buffer (&optional name)
+ (let ((buffer (make-instance 'climacs-buffer)))
+ (when name (setf (name buffer) 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 climacs-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)
+ (declare (ignore acceptably for-context-type))
+ (princ (name object) stream))
+
+(define-presentation-method accept
+ ((type buffer) 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
+ :value-key #'identity))
+ :partial-completers '(#\Space)
+ :allow-any-input t)
+ (cond (success
+ (values object type))
+ ((and (zerop (length string)) defaultp)
+ (values default default-type))
+ (t (values string 'string)))))
+
+(defgeneric switch-to-buffer (buffer))
+
+(defmethod switch-to-buffer ((buffer climacs-buffer))
+ (let* ((buffers (buffers *application-frame*))
+ (position (position buffer buffers))
+ (pane (current-window)))
+ (when position
+ (setf buffers (delete buffer buffers)))
+ (push buffer (buffers *application-frame*))
+ (setf (offset (point (buffer pane))) (offset (point pane)))
+ (setf (buffer pane) buffer)
+ (full-redisplay pane)
+ buffer))
+
+(defmethod switch-to-buffer ((name string))
+ (let ((buffer (find name (buffers *application-frame*)
+ :key #'name :test #'string=)))
+ (switch-to-buffer (or buffer
+ (make-buffer name)))))
+
+;;placeholder
+(defmethod switch-to-buffer ((symbol (eql 'nil)))
+ (let ((default (second (buffers *application-frame*))))
+ (when default
+ (switch-to-buffer default))))
+
+;; ;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR,
+;; ;;; 2005-10-31.
+;; (defmethod (setf buffer) :around (buffer (pane extended-pane))
+;; (call-next-method)
+;; (note-pane-syntax-changed pane (syntax buffer)))
+
+(defgeneric kill-buffer (buffer))
+
+(defmethod kill-buffer ((buffer climacs-buffer))
+ (with-slots (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-buffer "*scratch*"))
+ (setf (buffer (current-window)) (car buffers))
+ (full-redisplay (current-window))
+ (buffer (current-window))))
+
+(defmethod kill-buffer ((name string))
+ (let ((buffer (find name (buffers *application-frame*)
+ :key #'name :test #'string=)))
+ (when buffer (kill-buffer buffer))))
+
+(defmethod kill-buffer ((symbol (eql 'nil)))
+ (kill-buffer (buffer (current-window))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; File handling
+
+(defun filepath-filename (pathname)
+ (if (null (pathname-type pathname))
+ (pathname-name pathname)
+ (concatenate 'string (pathname-name pathname)
+ "." (pathname-type pathname))))
+
+(defun syntax-class-name-for-filepath (filepath)
+ (or (climacs-syntax::syntax-description-class-name
+ (find (or (pathname-type filepath)
+ (pathname-name filepath))
+ climacs-syntax::*syntaxes*
+ :test (lambda (x y)
+ (member x y :test #'string-equal))
+ :key #'climacs-syntax::syntax-description-pathname-types))
+ 'basic-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."
+ ;; 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,
+ ;; only the first will be acted upon.
+ (let ((specified-syntax
+ (syntax-from-name
+ (second (find-if #'(lambda (name)
+ (or (string-equal name "SYNTAX")
+ (string-equal name "MODE")))
+ options
+ :key #'first)))))
+ (when specified-syntax
+ (setf (syntax buffer)
+ (make-instance specified-syntax
+ :buffer buffer))))
+ ;; 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)))
+
+(defun split-attribute (string char)
+ (let (pairs)
+ (loop with start = 0
+ for ch across string
+ for i from 0
+ when (eql ch char)
+ do (push (string-trim '(#\Space #\Tab) (subseq string start i))
+ pairs)
+ (setf start (1+ i))
+ finally (unless (>= start i)
+ (push (string-trim '(#\Space #\Tab) (subseq string start))
+ pairs)))
+ (nreverse pairs)))
+
+(defun split-attribute-line (line)
+ (mapcar (lambda (pair) (split-attribute pair #\:))
+ (split-attribute line #\;)))
+
+(defun get-attribute-line (buffer)
+ (let ((scan (beginning-of-buffer (clone-mark (point buffer)))))
+ ;; skip the leading whitespace
+ (loop until (end-of-buffer-p scan)
+ until (not (whitespacep (syntax buffer) (object-after scan)))
+ do (forward-object scan))
+ ;; stop looking if we're already 1,000 objects into the buffer
+ (unless (> (offset scan) 1000)
+ (let ((start-found
+ (loop with newlines = 0
+ when (end-of-buffer-p scan)
+ do (return nil)
+ when (eql (object-after scan) #\Newline)
+ do (incf newlines)
+ when (> newlines 1)
+ do (return nil)
+ do (forward-object scan)
+ until (looking-at scan "-*-")
+ finally (return t))))
+ (when start-found
+ (let ((line (buffer-substring buffer
+ (offset scan)
+ (offset (end-of-line (clone-mark scan))))))
+ (when (>= (length line) 6)
+ (let ((end (search "-*-" line :from-end t :start2 3)))
+ (when end
+ (string-trim '(#\Space #\Tab) (subseq line 3 end)))))))))))
+
+(defun evaluate-attributes-line (buffer)
+ (evaluate-attributes
+ buffer
+ (split-attribute-line (get-attribute-line buffer))))
+
+;; Adapted from cl-fad/PCL
+(defun directory-pathname-p (pathspec)
+ "Returns NIL if PATHSPEC does not designate a directory."
+ (let ((name (pathname-name pathspec))
+ (type (pathname-type pathspec)))
+ (and (or (null name) (eql name :unspecific))
+ (or (null type) (eql type :unspecific)))))
+
+(defun find-file (filepath &optional readonlyp)
+ (cond ((null filepath)
+ (display-message "No file name given.")
+ (beep))
+ ((directory-pathname-p filepath)
+ (display-message "~A is a directory name." filepath)
+ (beep))
+ (t
+ (flet ((usable-pathname (pathname)
+ (if (probe-file pathname)
+ (truename pathname)
+ pathname)))
+ (let ((existing-buffer (find filepath (buffers *application-frame*)
+ :key #'filepath
+ :test #'(lambda (fp1 fp2)
+ (and fp1 fp2
+ (equal (usable-pathname fp1)
+ (usable-pathname fp2)))))))
+ (if (and existing-buffer (if readonlyp (read-only-p existing-buffer) t))
+ (switch-to-buffer existing-buffer)
+ (progn
+ (when readonlyp
+ (unless (probe-file filepath)
+ (beep)
+ (display-message "No such file: ~A" filepath)
+ (return-from find-file nil)))
+ (let ((buffer (make-buffer))
+ (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)
+ ;; 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-attributes-line buffer))
+ ;; If the local options line didn't set a syntax, do
+ ;; it now.
+ (when (null (syntax buffer))
+ (setf (syntax buffer)
+ (make-instance (syntax-class-name-for-filepath filepath)
+ :buffer 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))))))))
+
+(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."
+ (make-pathname
+ :directory
+ (pathname-directory
+ (or (filepath buffer)
+ (user-homedir-pathname)))))
+
+(defun set-visited-file-name (filename buffer)
+ (setf (filepath buffer) filename
+ (file-saved-p buffer) nil
+ (file-write-time buffer) nil
+ (name buffer) (filepath-filename filename)
+ (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."
+ (let ((f-w-d (file-write-date filepath))
+ (f-w-t (file-write-time buffer)))
+ (if (and f-w-d f-w-t (> f-w-d f-w-t))
+ (if (accept 'boolean
+ :prompt (format nil "File has changed on disk. ~a anyway?"
+ question))
+ t
+ (progn (display-message "~a not ~a" filepath answer)
+ 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)))
[33 lines skipped]
--- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/24 13:24:40 1.48
+++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/25 11:38:05 1.49
@@ -97,14 +97,14 @@
(:file "core" :depends-on ("gui"))
(:file "climacs" :depends-on ("gui" "core"))
;; (:file "buffer-commands" :depends-on ("gui"))
- (:file "developer-commands" :depends-on ("gui" "lisp-syntax"))
- (:file "motion-commands" :depends-on ("gui"))
- (:file "editing-commands" :depends-on ("gui"))
- (:file "file-commands" :depends-on ("gui"))
- (:file "misc-commands" :depends-on ("gui"))
- (:file "search-commands" :depends-on ("gui"))
- (:file "window-commands" :depends-on ("gui"))
- (:file "unicode-commands" :depends-on ("gui"))
+ (:file "developer-commands" :depends-on ("gui" "lisp-syntax" "core"))
+ (:file "motion-commands" :depends-on ("gui" "core"))
+ (:file "editing-commands" :depends-on ("gui" "core"))
+ (:file "file-commands" :depends-on ("gui" "core"))
+ (:file "misc-commands" :depends-on ("gui" "core"))
+ (:file "search-commands" :depends-on ("gui" "core"))
+ (:file "window-commands" :depends-on ("gui" "core"))
+ (:file "unicode-commands" :depends-on ("gui" "core"))
(:file "slidemacs" :depends-on ("packages" "buffer" "syntax" "base" "pane" ))
(:file "slidemacs-gui" :depends-on ("packages" "slidemacs" "pane" "buffer" "syntax" "gui"))))
More information about the Climacs-cvs
mailing list