[climacs-cvs] CVS climacs

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"))))