July 2006 - climacs-cvs@common-lisp.net - mailman3.common-lisp.net

[climacs-cvs] CVS climacs
by thenriksen 25 Jul '06

25 Jul '06

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

1 0

[climacs-cvs] CVS climacs
by thenriksen 24 Jul '06

24 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv16618 Modified Files: lisp-syntax.lisp Log Message: Ironed out some more bugs in the implementation of intelligent completion for keyword parameters - &rest arguments are handled and indirect arglists fetched now. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/24 08:20:27 1.98 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/24 20:52:23 1.99 @@ -3840,11 +3840,13 @@ sense to use at the position `arg-indices' relative to the operator that has the argument list `arglist'." (let* ((key-position (position '&key arglist)) + (rest-position (position '&rest arglist)) (cleaned-arglist (remove-if #'arglist-keyword-p arglist)) (index (first arg-indices)) - (difference (- (length arglist) - (length cleaned-arglist)))) + (difference (+ (- (length arglist) + (length cleaned-arglist)) + (if rest-position 1 0)))) (cond ((and (null key-position) (rest arg-indices) (> (length cleaned-arglist) @@ -3857,11 +3859,12 @@ (>= (+ index difference) key-position) - (not (evenp (- index key-position difference)))) + (evenp (- index (- key-position + (1- difference))))) (mapcar #'unlisted (subseq cleaned-arglist - (- key-position - difference - -1))))))) + (+ (- key-position + difference) + (if rest-position 2 1)))))))) (defun completions-from-keywords (syntax token) "Assume that `token' is a (partial) keyword argument @@ -3871,10 +3874,11 @@ doesn't take keyword arguments)." (with-code-insight (start-offset token) syntax (:preceding-operand-indices poi - :operator operator) + :operator operator + :operands operands) (when (valid-operator-p operator) (let* ((relevant-keywords - (relevant-keywords (arglist-for-form operator) + (relevant-keywords (arglist-for-form operator operands) poi)) (completions (simple-completions (get-usable-image syntax)

1 0

[climacs-cvs] CVS climacs/Doc
by thenriksen 24 Jul '06

24 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv26762/Doc Modified Files: climacs-user.texi Log Message: Climacs entry point in in the CLIMACS package, add mention of :new-process argument. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:55:45 1.12 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/24 17:58:32 1.13 @@ -207,7 +207,13 @@ @emph{expression} at the prompt of a @cl{} @emph{listener} such as: @lisp -CL-USER> (climacs-gui:climacs) +CL-USER> (climacs:climacs) +@end lisp + +@climacs{} also has an option to start in a new thread: + +@lisp +CL-USER> (climacs:climacs :new-process t) @end lisp You exit from @climacs{} by typing @kbd{C-x C-c} (@command{Quit}).

1 0

[climacs-cvs] CVS climacs
by thenriksen 24 Jul '06

24 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv13591 Modified Files: window-commands.lisp search-commands.lisp packages.lisp misc-commands.lisp kill-ring.lisp gui.lisp base.lisp Log Message: * Moved some functions from window-commands.lisp to gui.lisp (and the CLIMACs-GUI package) and export them. * The kill ring is no longer a global, special symbol, thus fixing a bunch of problems regarding sharing of kill rings between instances of Climacs (and remembering the kill ring across invocations). * Various yank-commands no longer signal an error when the kill ring is empty. This is done by handling the flexichain:at-end-error condition, which is suboptimal - user code should not need to be aware of the implementation of the kill ring. Will be fixed at some point. CVS problems made it too hard to divide this up into several patches, sorry. --- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/07/24 13:24:40 1.9 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2006/07/24 16:33:16 1.10 @@ -32,123 +32,6 @@ ;;; ;;; Commands for splitting windows -(defun replace-constellation (constellation additional-constellation vertical-p) - (let* ((parent (sheet-parent constellation)) - (children (sheet-children parent)) - (first (first children)) - (second (second children)) - (third (third children)) - (first-split-p (= (length (sheet-children parent)) 2)) - (parent-region (sheet-region parent)) - (parent-height (rectangle-height parent-region)) - (parent-width (rectangle-width parent-region)) - (filler (when first-split-p (make-pane 'basic-pane))) ;Prevents resizing. - (adjust #+mcclim (make-pane 'clim-extensions:box-adjuster-gadget))) - (assert (member constellation children)) - - (when first-split-p (setf (sheet-region filler) (sheet-region parent)) - (sheet-adopt-child parent filler)) - - (sheet-disown-child parent constellation) - - (if vertical-p - (resize-sheet constellation parent-width (/ parent-height 2)) - (resize-sheet constellation (/ parent-width 2) parent-height)) - - (let ((new (if vertical-p - (vertically () - constellation adjust additional-constellation) - (horizontally () - constellation adjust additional-constellation)))) - (sheet-adopt-child parent new) - - (when first-split-p (sheet-disown-child parent filler)) - (reorder-sheets parent - (if (eq constellation first) - (if third - (list new second third) - (list new second)) - (if third - (list first second new) - (list first new))))))) - -(defun find-parent (sheet) - (loop for parent = (sheet-parent sheet) - then (sheet-parent parent) - until (typep parent 'vrack-pane) - finally (return parent))) - -(defclass typeout-pane (application-pane esa-pane-mixin) ()) - -(defun make-typeout-constellation (&optional label) - (let* ((typeout-pane - (make-pane 'typeout-pane :foreground *fg-color* :background *bg-color* - :width 900 :height 400 :display-time nil)) - (label - (make-pane 'label-pane :label label)) - (vbox - (vertically () - (scrolling (:scroll-bar :vertical) typeout-pane) label))) - (values vbox typeout-pane))) - -(defun typeout-window (&optional (label "Typeout") (pane (current-window))) - (with-look-and-feel-realization - ((frame-manager *application-frame*) *application-frame*) - (multiple-value-bind (vbox new-pane) (make-typeout-constellation label) - (let* ((current-window pane) - (constellation-root (find-parent current-window))) - (push new-pane (windows *application-frame*)) - (other-window) - (replace-constellation constellation-root vbox t) - (full-redisplay current-window) - new-pane)))) - -(defun make-pane-constellation (&optional (with-scrollbars *with-scrollbars*)) - "make a vbox containing a scroller pane as its first child and an -info pane as its second child. The scroller pane contains a viewport -which contains an extended pane. Return the vbox and the extended pane -as two values. -If with-scrollbars nil, omit the scroller." - (let* ((extended-pane - (make-pane 'extended-pane - :width 900 :height 400 - :name 'window - :end-of-line-action :scroll - :incremental-redisplay t - :background *bg-color* - :foreground *fg-color* - :display-function 'display-window - :command-table 'global-climacs-table)) - (vbox - (vertically () - (if with-scrollbars - (scrolling () - extended-pane) - extended-pane) - (make-pane 'climacs-info-pane - :background *info-bg-color* - :foreground *info-fg-color* - :master-pane extended-pane - :width 900)))) - (values vbox extended-pane))) - -(defun split-window (&optional (vertically-p nil) (pane (current-window))) - (with-look-and-feel-realization - ((frame-manager *application-frame*) *application-frame*) - (multiple-value-bind (vbox new-pane) (make-pane-constellation) - (let* ((current-window pane) - (constellation-root (find-parent current-window))) - (setf (offset (point (buffer current-window))) (offset (point current-window)) - (buffer new-pane) (buffer current-window) - (auto-fill-mode new-pane) (auto-fill-mode current-window) - (auto-fill-column new-pane) (auto-fill-column current-window)) - (push new-pane (windows *application-frame*)) - (setf *standard-output* new-pane) - (replace-constellation constellation-root vbox vertically-p) - (full-redisplay current-window) - (full-redisplay new-pane) - new-pane)))) - (define-command (com-split-window-vertically :name t :command-table window-table) () (split-window t)) @@ -163,20 +46,6 @@ 'window-table '((#\x :control) (#\3))) -(defun other-window (&optional pane) - (if (and pane (find pane (windows *application-frame*))) - (setf (windows *application-frame*) - (append (list pane) - (remove pane (windows *application-frame*)))) - (setf (windows *application-frame*) - (append (cdr (windows *application-frame*)) - (list (car (windows *application-frame*)))))) - ;; Try to avoid setting the point in a typeout pane. FIXME: This is a kludge. - (if (and (subtypep 'typeout-pane (type-of (car (windows *application-frame*)))) - (> (length (windows *application-frame*)) 1)) - (other-window) - (setf *standard-output* (car (windows *application-frame*))))) - (define-command (com-other-window :name t :command-table window-table) () (other-window)) @@ -282,33 +151,6 @@ 'window-table '((#\V :control :meta :shift))) -(defun delete-window (&optional (window (current-window))) - (unless (null (cdr (windows *application-frame*))) - (let* ((constellation (find-parent window)) - (box (sheet-parent constellation)) - (box-children (sheet-children box)) - (other (if (eq constellation (first box-children)) - (third box-children) - (first box-children))) - (parent (sheet-parent box)) - (children (sheet-children parent)) - (first (first children)) - (second (second children)) - (third (third children))) - (setf (windows *application-frame*) - (remove window (windows *application-frame*))) - (setf *standard-output* (car (windows *application-frame*))) - (sheet-disown-child box other) - (sheet-adopt-child parent other) - (sheet-disown-child parent box) - (reorder-sheets parent (if (eq box first) - (if third - (list other second third) - (list other second)) - (if third - (list first second other) - (list first other))))))) - (define-command (com-delete-window :name t :command-table window-table) () (delete-window)) --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 13:24:40 1.9 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 16:33:16 1.10 @@ -209,7 +209,9 @@ (define-command (com-isearch-append-kill :name t :command-table isearch-climacs-table) () (let* ((pane (current-window)) (states (isearch-states pane)) - (yank (kill-ring-yank *kill-ring*)) + (yank (handler-case (kill-ring-yank *kill-ring*) + (flexichain:at-end-error () + ""))) (string (concatenate 'string (search-string (first states)) yank)) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 13:24:40 1.106 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 16:33:16 1.107 @@ -70,7 +70,8 @@ #:append-next-p #:reset-yank-position #:rotate-yank-position #:kill-ring-yank #:kill-ring-standard-push #:kill-ring-concatenating-push - #:kill-ring-reverse-concatenating-push) + #:kill-ring-reverse-concatenating-push + #:*kill-ring*) (:documentation "An implementation of a kill ring.")) (defpackage :climacs-base @@ -99,8 +100,7 @@ #:downcase-buffer-region #:downcase-region #:upcase-buffer-region #:upcase-region #:capitalize-buffer-region #:capitalize-region - #:tabify-region #:untabify-region - #:*kill-ring*) + #:tabify-region #:untabify-region) (:documentation "Basic functionality built on top of the buffer protocol. Here is where we define slightly higher level functions, that can be directly implemented in terms of the @@ -318,6 +318,8 @@ #:extended-pane #:climacs-info-pane + #:typeout-pane + #:kill-ring ;; GUI functions follow. #:current-window @@ -333,6 +335,10 @@ #:erase-buffer #:buffer-pane-p #:display-window + #:split-window + #:typeout-window + #:delete-window + #:other-window ;; Some configuration variables #:*bg-color* --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 13:24:40 1.17 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 16:33:16 1.18 @@ -476,7 +476,9 @@ ;; Copies an element from a kill-ring to a buffer at the given offset (define-command (com-yank :name t :command-table editing-table) () "Insert the objects most recently added to the kill ring at point." - (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*))) + (handler-case (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*)) + (flexichain:at-end-error () + (display-message "Kill ring is empty")))) (set-key 'com-yank 'editing-table @@ -510,15 +512,17 @@ Must be given immediately following a Yank or Rotate Yank command. The replacement objects are those before the previously yanked objects in the kill ring." - (let* ((pane (current-window)) - (point (point pane)) - (last-yank (kill-ring-yank *kill-ring*))) - (if (eq (previous-command pane) - 'com-rotate-yank) - (progn - (delete-range point (* -1 (length last-yank))) - (rotate-yank-position *kill-ring*))) - (insert-sequence point (kill-ring-yank *kill-ring*)))) + (handler-case (let* ((pane (current-window)) + (point (point pane)) + (last-yank (kill-ring-yank *kill-ring*))) + (if (eq (previous-command pane) + 'com-rotate-yank) + (progn + (delete-range point (* -1 (length last-yank))) + (rotate-yank-position *kill-ring*))) + (insert-sequence point (kill-ring-yank *kill-ring*))) + (flexichain:at-end-error () + (display-message "Kill ring is empty")))) (set-key 'com-rotate-yank 'editing-table --- /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/03/03 19:38:57 1.9 +++ /project/climacs/cvsroot/climacs/kill-ring.lisp 2006/07/24 16:33:16 1.10 @@ -150,4 +150,8 @@ (defmethod kill-ring-yank ((kr kill-ring) &optional (reset nil)) (if reset (reset-yank-position kr)) - (element> (kill-ring-cursor kr))) \ No newline at end of file + (element> (kill-ring-cursor kr))) + +(defparameter *kill-ring* nil + "This special variable is bound to the kill ring of the running + Climacs, whenever a command is executed.") \ No newline at end of file --- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 13:24:40 1.223 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 16:33:16 1.224 @@ -37,6 +37,9 @@ (dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) (overwrite-mode :initform nil :accessor overwrite-mode))) +(defclass typeout-pane (application-pane esa-pane-mixin) + ()) + (defgeneric buffer-pane-p (pane) (:documentation "Returns T when a pane contains a buffer.")) @@ -124,10 +127,10 @@ (defvar *mini-bg-color* +white+) (defvar *mini-fg-color* +black+) - (define-application-frame climacs (standard-application-frame esa-frame-mixin) - ((buffers :initform '() :accessor buffers)) + ((buffers :initform '() :accessor buffers) + (kill-ring :initform (make-instance 'kill-ring :max-size 7) :accessor kill-ring)) (:command-table (global-climacs-table :inherit-from (global-esa-table keyboard-macro-table @@ -184,7 +187,9 @@ (vertically (:scroll-bars nil) climacs-window minibuffer))) - (:top-level (esa-top-level :prompt "M-x "))) + (:top-level ((lambda (frame) + (let ((*kill-ring* (kill-ring frame))) + (esa-top-level frame :prompt "M-x ")))))) (defmethod frame-standard-input ((frame climacs)) (get-frame-pane frame 'minibuffer)) @@ -380,8 +385,150 @@ 'self-insert-table '((#\Newline))) -;;;;;;;;;;;;;;;;;;; -;;; Pane commands +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Pane/buffer functions + +(defun replace-constellation (constellation additional-constellation vertical-p) + (let* ((parent (sheet-parent constellation)) + (children (sheet-children parent)) + (first (first children)) + (second (second children)) + (third (third children)) + (first-split-p (= (length (sheet-children parent)) 2)) + (parent-region (sheet-region parent)) + (parent-height (rectangle-height parent-region)) + (parent-width (rectangle-width parent-region)) + (filler (when first-split-p (make-pane 'basic-pane))) ;Prevents resizing. + (adjust #+mcclim (make-pane 'clim-extensions:box-adjuster-gadget))) + (assert (member constellation children)) + + (when first-split-p (setf (sheet-region filler) (sheet-region parent)) + (sheet-adopt-child parent filler)) + + (sheet-disown-child parent constellation) + + (if vertical-p + (resize-sheet constellation parent-width (/ parent-height 2)) + (resize-sheet constellation (/ parent-width 2) parent-height)) + + (let ((new (if vertical-p + (vertically () + constellation adjust additional-constellation) + (horizontally () + constellation adjust additional-constellation)))) + (sheet-adopt-child parent new) + + (when first-split-p (sheet-disown-child parent filler)) + (reorder-sheets parent + (if (eq constellation first) + (if third + (list new second third) + (list new second)) + (if third + (list first second new) + (list first new))))))) +(defun find-parent (sheet) + (loop for parent = (sheet-parent sheet) + then (sheet-parent parent) + until (typep parent 'vrack-pane) + finally (return parent))) + +(defun make-pane-constellation (&optional (with-scrollbars *with-scrollbars*)) + "make a vbox containing a scroller pane as its first child and an +info pane as its second child. The scroller pane contains a viewport +which contains an extended pane. Return the vbox and the extended pane +as two values. +If with-scrollbars nil, omit the scroller." + (let* ((extended-pane + (make-pane 'extended-pane + :width 900 :height 400 + :name 'window + :end-of-line-action :scroll + :incremental-redisplay t + :background *bg-color* + :foreground *fg-color* + :display-function 'display-window + :command-table 'global-climacs-table)) + (vbox + (vertically () + (if with-scrollbars + (scrolling () + extended-pane) + extended-pane) + (make-pane 'climacs-info-pane + :background *info-bg-color* + :foreground *info-fg-color* + :master-pane extended-pane + :width 900)))) + (values vbox extended-pane))) + +(defun split-window (&optional (vertically-p nil) (pane (current-window))) + (with-look-and-feel-realization + ((frame-manager *application-frame*) *application-frame*) + (multiple-value-bind (vbox new-pane) (make-pane-constellation) + (let* ((current-window pane) + (constellation-root (find-parent current-window))) + (setf (offset (point (buffer current-window))) (offset (point current-window)) + (buffer new-pane) (buffer current-window) + (auto-fill-mode new-pane) (auto-fill-mode current-window) + (auto-fill-column new-pane) (auto-fill-column current-window)) + (push new-pane (windows *application-frame*)) + (setf *standard-output* new-pane) + (replace-constellation constellation-root vbox vertically-p) + (full-redisplay current-window) + (full-redisplay new-pane) + new-pane)))) + +(defun make-typeout-constellation (&optional label) + (let* ((typeout-pane + (make-pane 'typeout-pane :foreground *fg-color* :background *bg-color* + :width 900 :height 400 :display-time nil)) + (label + (make-pane 'label-pane :label label)) + (vbox + (vertically () + (scrolling (:scroll-bar :vertical) typeout-pane) label))) + (values vbox typeout-pane))) + +(defun typeout-window (&optional (label "Typeout") (pane (current-window))) + (with-look-and-feel-realization + ((frame-manager *application-frame*) *application-frame*) + (multiple-value-bind (vbox new-pane) (make-typeout-constellation label) + (let* ((current-window pane) + (constellation-root (find-parent current-window))) + (push new-pane (windows *application-frame*)) + (other-window) + (replace-constellation constellation-root vbox t) + (full-redisplay current-window) + new-pane)))) + +(defun delete-window (&optional (window (current-window))) + (unless (null (cdr (windows *application-frame*))) + (let* ((constellation (find-parent window)) + (box (sheet-parent constellation)) + (box-children (sheet-children box)) + (other (if (eq constellation (first box-children)) + (third box-children) + (first box-children))) + (parent (sheet-parent box)) + (children (sheet-children parent)) + (first (first children)) + (second (second children)) + (third (third children))) + (setf (windows *application-frame*) + (remove window (windows *application-frame*))) + (setf *standard-output* (car (windows *application-frame*))) + (sheet-disown-child box other) + (sheet-adopt-child parent other) + (sheet-disown-child parent box) + (reorder-sheets parent (if (eq box first) + (if third + (list other second third) + (list other second)) + (if third + (list first second other) + (list first other))))))) (defun make-buffer (&optional name) (let ((buffer (make-instance 'climacs-buffer))) @@ -389,6 +536,20 @@ (push buffer (buffers *application-frame*)) buffer)) +(defun other-window (&optional pane) + (if (and pane (find pane (windows *application-frame*))) + (setf (windows *application-frame*) + (append (list pane) + (remove pane (windows *application-frame*)))) + (setf (windows *application-frame*) + (append (cdr (windows *application-frame*)) + (list (car (windows *application-frame*)))))) + ;; Try to avoid setting the point in a typeout pane. FIXME: This is a kludge. + (if (and (subtypep 'typeout-pane (type-of (car (windows *application-frame*)))) + (> (length (windows *application-frame*)) 1)) + (other-window) + (setf *standard-output* (car (windows *application-frame*))))) + (defgeneric erase-buffer (buffer)) (defmethod erase-buffer ((buffer string)) --- /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 13:24:40 1.56 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 16:33:16 1.57 @@ -663,9 +663,3 @@ (when (> offset1 offset2) (rotatef offset1 offset2)) (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Kill ring - -(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))

1 0

[climacs-cvs] CVS climacs
by thenriksen 24 Jul '06

24 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28595 Added Files: core.lisp Log Message: Added core.lisp - needed for my previous patch. Oops. --- /project/climacs/cvsroot/climacs/core.lisp 2006/07/24 14:18:59 NONE +++ /project/climacs/cvsroot/climacs/core.lisp 2006/07/24 14:18:59 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-CORE -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson(a)fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic(a)yahoo.com) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas(a)sigkill.dk) (in-package :climacs-core) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Misc stuff (defun possibly-fill-line () (let* ((pane (current-window)) (buffer (buffer pane))) (when (auto-fill-mode pane) (let* ((fill-column (auto-fill-column pane)) (point (point pane)) (offset (offset point)) (tab-width (tab-space-count (stream-default-view pane))) (syntax (syntax buffer))) (when (>= (buffer-display-column buffer offset tab-width) (1- fill-column)) (fill-line point (lambda (mark) (syntax-line-indentation mark tab-width syntax)) fill-column tab-width (syntax buffer))))))) (defun insert-character (char) (let* ((window (current-window)) (point (point window))) (unless (constituentp char) (possibly-expand-abbrev point)) (when (whitespacep (syntax (buffer window)) char) (possibly-fill-line)) (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point))) (progn (delete-range point) (insert-object point char)) (insert-object point char)))) (defun back-to-indentation (mark syntax) (beginning-of-line mark) (loop until (end-of-line-p mark) while (whitespacep syntax (object-after mark)) do (forward-object mark))) (defun delete-horizontal-space (mark syntax &optional (backward-only-p nil)) (let ((mark2 (clone-mark mark))) (loop until (beginning-of-line-p mark) while (whitespacep syntax (object-before mark)) do (backward-object mark)) (unless backward-only-p (loop until (end-of-line-p mark2) while (whitespacep syntax (object-after mark2)) do (forward-object mark2))) (delete-region mark mark2))) (defun goto-position (mark pos) (setf (offset mark) pos)) (defun goto-line (mark line-number) (loop with m = (clone-mark (low-mark (buffer mark)) :right) initially (beginning-of-buffer m) do (end-of-line m) until (end-of-buffer-p m) repeat (1- line-number) do (incf (offset m)) (end-of-line m) finally (beginning-of-line m) (setf (offset mark) (offset m)))) (defun indent-current-line (pane point) (let* ((buffer (buffer pane)) (view (stream-default-view pane)) (tab-space-count (tab-space-count view)) (indentation (syntax-line-indentation point tab-space-count (syntax buffer)))) (indent-line point indentation (and (indent-tabs-mode buffer) tab-space-count)))) (defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\))) (cond ((> count 0) (loop while (and (not (end-of-buffer-p mark)) (whitespacep syntax (object-after mark))) do (forward-object mark))) ((< count 0) (setf count (- count)) (loop repeat count do (backward-expression mark syntax)))) (unless (or (beginning-of-buffer-p mark) (whitespacep syntax (object-before mark))) (insert-object mark #\Space)) (insert-object mark open) (let ((here (clone-mark mark))) (loop repeat count do (forward-expression here syntax)) (insert-object here close) (unless (or (end-of-buffer-p here) (whitespacep syntax (object-after here))) (insert-object here #\Space)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case (defun downcase-word (mark &optional (n 1)) "Convert the next N words to lowercase, leaving mark after the last word." (let ((syntax (syntax (buffer mark)))) (loop repeat n do (forward-to-word-boundary mark syntax) (let ((offset (offset mark))) (forward-word mark syntax 1 nil) (downcase-region offset mark))))) (defun upcase-word (mark syntax &optional (n 1)) "Convert the next N words to uppercase, leaving mark after the last word." (loop repeat n do (forward-to-word-boundary mark syntax) (let ((offset (offset mark))) (forward-word mark syntax 1 nil) (upcase-region offset mark)))) (defun capitalize-word (mark &optional (n 1)) "Capitalize the next N words, leaving mark after the last word." (let ((syntax (syntax (buffer mark)))) (loop repeat n do (forward-to-word-boundary mark syntax) (let ((offset (offset mark))) (forward-word mark syntax 1 nil) (capitalize-region offset mark))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Indentation (defun indent-region (pane mark1 mark2) "Indent all lines in the region delimited by `mark1' and `mark2' according to the rules of the active syntax in `pane'." (let* ((buffer (buffer pane)) (view (clim:stream-default-view pane)) (tab-space-count (tab-space-count view)) (tab-width (and (indent-tabs-mode buffer) tab-space-count)) (syntax (syntax buffer))) (do-buffer-region-lines (line mark1 mark2) (let ((indentation (syntax-line-indentation line tab-space-count syntax))) (indent-line line indentation tab-width)) ;; We need to update the syntax every time we perform an ;; indentation, so that subsequent indentations will be ;; correctly indented (this matters in list forms). FIXME: This ;; should probably happen automatically. (update-syntax buffer syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Auto fill (defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax &optional (compress-whitespaces t)) "Breaks the contents of line pointed to by MARK up to MARK into multiple lines such that none of them is longer than FILL-COLUMN. If COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the decision is made to break the line at a point. For now, the compression means just the deletion of trailing whitespaces." (let ((begin-mark (clone-mark mark))) (beginning-of-line begin-mark) (loop with column = 0 with line-beginning-offset = (offset begin-mark) with walking-mark = (clone-mark begin-mark) while (mark< walking-mark mark) as object = (object-after walking-mark) do (case object (#\Space (setf (offset begin-mark) (offset walking-mark)) (incf column)) (#\Tab (setf (offset begin-mark) (offset walking-mark)) (incf column (- tab-width (mod column tab-width)))) (t (incf column))) (when (and (>= column fill-column) (/= (offset begin-mark) line-beginning-offset)) (when compress-whitespaces (let ((offset (buffer-search-backward (buffer begin-mark) (offset begin-mark) #(nil) :test #'(lambda (o1 o2) (declare (ignore o2)) (not (whitespacep syntax o1)))))) (when offset (delete-region begin-mark (1+ offset))))) (insert-object begin-mark #\Newline) (incf (offset begin-mark)) (let ((indentation (funcall syntax-line-indentation-function begin-mark))) (indent-line begin-mark indentation tab-width)) (beginning-of-line begin-mark) (setf line-beginning-offset (offset begin-mark)) (setf (offset walking-mark) (offset begin-mark)) (setf column 0)) (incf (offset walking-mark))))) (defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax &optional (compress-whitespaces t)) "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be mark<= `mark2.'" (let* ((buffer (buffer mark1))) (do-buffer-region (object offset buffer (offset mark1) (offset mark2)) (when (eql object #\Newline) (setf object #\Space))) (when (>= (buffer-display-column buffer (offset mark2) tab-width) (1- fill-column)) (fill-line mark2 syntax-line-indentation-function fill-column tab-width compress-whitespaces syntax)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Indentation (defgeneric indent-line (mark indentation tab-width) (:documentation "Indent the line containing mark with indentation spaces. Use tabs and spaces if tab-width is not nil, otherwise use spaces only.")) (defun indent-line* (mark indentation tab-width left) (let ((mark2 (clone-mark mark))) (beginning-of-line mark2) (loop until (end-of-buffer-p mark2) as object = (object-after mark2) while (or (eql object #\Space) (eql object #\Tab)) do (delete-range mark2 1)) (loop until (zerop indentation) do (cond ((and tab-width (>= indentation tab-width)) (insert-object mark2 #\Tab) (when left ; spaces must follow tabs (forward-object mark2)) (decf indentation tab-width)) (t (insert-object mark2 #\Space) (decf indentation)))))) (defmethod indent-line ((mark left-sticky-mark) indentation tab-width) (indent-line* mark indentation tab-width t)) (defmethod indent-line ((mark right-sticky-mark) indentation tab-width) (indent-line* mark indentation tab-width nil)) (defun delete-indentation (mark) (beginning-of-line mark) (unless (beginning-of-buffer-p mark) (delete-range mark -1) (loop until (end-of-buffer-p mark) while (buffer-whitespacep (object-after mark)) do (delete-range mark 1)) (loop until (beginning-of-buffer-p mark) while (buffer-whitespacep (object-before mark)) do (delete-range mark -1)) (when (and (not (beginning-of-buffer-p mark)) (constituentp (object-before mark))) (insert-object mark #\Space))))

1 0

[climacs-cvs] CVS climacs
by thenriksen 24 Jul '06

24 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv2300 Modified Files: window-commands.lisp search-commands.lisp pane.lisp packages.lisp misc-commands.lisp lisp-syntax-commands.lisp gui.lisp file-commands.lisp editing.lisp developer-commands.lisp climacs.asd buffer-test.lisp base.lisp Log Message: Final major package-cleanup for now. New package, CLIMACS-CORE, added. Lots of commands moved from CLIMACS-GUI to CLIMACS-COMMANDS, reusable functions moved to CLIMACS-CORE. --- /project/climacs/cvsroot/climacs/window-commands.lisp 2006/05/13 17:19:10 1.8 +++ /project/climacs/cvsroot/climacs/window-commands.lisp 2006/07/24 13:24:40 1.9 @@ -26,7 +26,7 @@ ;;; Windows commands for the Climacs editor. -(in-package :climacs-gui) +(in-package :climacs-commands) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/02 18:42:28 1.8 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/24 13:24:40 1.9 @@ -26,7 +26,7 @@ ;;; Search commands for the Climacs editor. -(in-package :climacs-gui) +(in-package :climacs-commands) (defun display-string (string) (with-output-to-string (result) @@ -329,7 +329,9 @@ with length = (length string) with use-region-case = (no-upper-p string) for occurrences from 0 - while (query-replace-find-next-match point string) + while (let ((offset-before (offset point))) + (search-forward point string :test (case-relevant-test string)) + (/= (offset point) offset-before)) do (backward-object point length) (replace-one-string point length newstring use-region-case) finally (display-message "Replaced ~A occurrence~:P" occurrences)))) @@ -340,10 +342,19 @@ (make-command-table 'query-replace-climacs-table :errorp nil) -(defun query-replace-find-next-match (mark string) - (let ((offset-before (offset mark))) - (search-forward mark string :test (case-relevant-test string)) - (/= (offset mark) offset-before))) +(defun query-replace-find-next-match (state) + (with-accessors ((string string1) + (buffers buffers) + (mark mark)) state + (let ((offset-before (offset mark))) + (search-forward mark string :test (case-relevant-test string)) + (or (/= (offset mark) offset-before) + (unless (null (rest buffers)) + (pop buffers) + (switch-to-buffer (first buffers)) + (setf mark (point (first buffers))) + (beginning-of-buffer mark) + (query-replace-find-next-match state)))))) (define-command (com-query-replace :name t :command-table search-table) () (let* ((pane (current-window)) @@ -375,11 +386,13 @@ (point (point pane)) (occurrences 0)) (declare (special string1 string2 occurrences)) - (when (query-replace-find-next-match point string1) - (setf (query-replace-state pane) (make-instance 'query-replace-state - :string1 string1 - :string2 string2) - (query-replace-mode pane) t) + (setf (query-replace-state pane) (make-instance 'query-replace-state + :string1 string1 + :string2 string2 + :mark point + :buffers (list (buffer pane)))) + (when (query-replace-find-next-match (query-replace-state pane)) + (setf (query-replace-mode pane) t) (display-message "Replace ~A with ~A:" string1 string2) (simple-command-loop 'query-replace-climacs-table @@ -394,12 +407,15 @@ (define-command (com-query-replace-replace :name t :command-table query-replace-climacs-table) () (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) - (point (point pane)) - (string1-length (length string1))) - (backward-object point string1-length) - (replace-one-string point string1-length string2 (no-upper-p string1)) + (string1-length (length string1)) + (state (query-replace-state pane))) + (backward-object (mark state) string1-length) + (replace-one-string (mark state) + string1-length + string2 + (no-upper-p string1)) (incf occurrences) - (if (query-replace-find-next-match point string1) + (if (query-replace-find-next-match (query-replace-state pane)) (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode pane) nil)))) @@ -410,10 +426,13 @@ () (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) - (point (point pane)) - (string1-length (length string1))) - (backward-object point string1-length) - (replace-one-string point string1-length string2 (no-upper-p string1)) + (string1-length (length string1)) + (state (query-replace-state pane))) + (backward-object (mark state) string1-length) + (replace-one-string (mark state) + string1-length + string2 + (no-upper-p string1)) (incf occurrences) (setf (query-replace-mode pane) nil))) @@ -423,19 +442,21 @@ () (declare (special string1 string2 occurrences)) (let* ((pane (current-window)) - (point (point pane)) - (string1-length (length string1))) - (loop do (backward-object point string1-length) - (replace-one-string point string1-length string2 (no-upper-p string1)) - (incf occurrences) - while (query-replace-find-next-match point string1) - finally (setf (query-replace-mode pane) nil)))) + (string1-length (length string1)) + (state (query-replace-state pane))) + (loop do (backward-object (mark state) string1-length) + (replace-one-string (mark state) + string1-length + string2 + (no-upper-p string1)) + (incf occurrences) + while (query-replace-find-next-match (query-replace-state pane)) + finally (setf (query-replace-mode pane) nil)))) (define-command (com-query-replace-skip :name t :command-table query-replace-climacs-table) () (declare (special string1 string2)) - (let* ((pane (current-window)) - (point (point pane))) - (if (query-replace-find-next-match point string1) + (let ((pane (current-window))) + (if (query-replace-find-next-match (query-replace-state pane)) (display-message "Replace ~A with ~A:" string1 string2) (setf (query-replace-mode pane) nil)))) @@ -694,4 +715,4 @@ (multiple-query-replace-set-key '(#\y) 'com-multiple-query-replace-replace) (multiple-query-replace-set-key '(#\n) 'com-multiple-query-replace-skip) (multiple-query-replace-set-key '(#\.) 'com-multiple-query-replace-replace-and-quit) -(multiple-query-replace-set-key '(#\!) 'com-multiple-query-replace-replace-all) \ No newline at end of file +(multiple-query-replace-set-key '(#\!) 'com-multiple-query-replace-replace-all) --- /project/climacs/cvsroot/climacs/pane.lisp 2006/07/21 06:25:45 1.45 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/07/24 13:24:40 1.46 @@ -183,7 +183,9 @@ (defclass query-replace-state () ((string1 :initarg :string1 :accessor string1) - (string2 :initarg :string2 :accessor string2))) + (string2 :initarg :string2 :accessor string2) + (buffers :initarg :buffers :accessor buffers) + (mark :initarg :mark :accessor mark))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/23 11:59:38 1.105 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/24 13:24:40 1.106 @@ -88,7 +88,6 @@ #:constituentp #:just-n-spaces #:buffer-whitespacep - #:forward-word #:backward-word #:buffer-region-case #:input-from-stream #:output-to-stream #:name-mixin #:name @@ -101,7 +100,6 @@ #:upcase-buffer-region #:upcase-region #:capitalize-buffer-region #:capitalize-region #:tabify-region #:untabify-region - #:indent-line #:delete-indentation #:*kill-ring*) (:documentation "Basic functionality built on top of the buffer protocol. Here is where we define slightly higher level @@ -186,7 +184,7 @@ #:isearch-state #:search-string #:search-mark #:search-forward-p #:search-success-p #:isearch-mode #:isearch-states #:isearch-previous-string - #:query-replace-state #:string1 #:string2 + #:query-replace-state #:string1 #:string2 #:buffers #:mark #:query-replace-mode #:region-visible-p #:with-undo @@ -302,14 +300,7 @@ ;; Sentences #:forward-delete-sentence #:backward-delete-sentence #:forward-kill-sentence #:backward-kill-sentence - #:transpose-sentences - - - #:downcase-word #:upcase-word #:capitalize-word - - #:indent-region - #:fill-line - #:fill-region) + #:transpose-sentences) (:documentation "Functions and facilities for changing the buffer contents by syntactical elements. The functions in this package are syntax-aware, and their behavior is based on the semantics @@ -318,51 +309,87 @@ to implement the editing commands.")) (defpackage :climacs-gui - (: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) - ;;(:import-from :lisp-string) - (:export #:climacs ; Frame. + (: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) + ;;(:import-from :lisp-string) + (:export #:climacs ; Frame. + + #:extended-pane + #:climacs-info-pane - ;; GUI functions follow. - #:current-window - #:current-point - #:current-buffer - #:current-buffer - #:point - #:syntax - #:mark - #:insert-character - #:base-table - #:buffer-table - #:case-table - #:comment-table - #:deletion-table - #:development-table - #:editing-table - #:fill-table - #:indent-table - #:info-table - #:marking-table - #:movement-table - #:pane-table - #:search-table - #:self-insert-table - #:window-table + ;; GUI functions follow. + #:current-window + #:current-point + #:current-buffer + #:current-point + #:point + #:syntax + #:mark + #:insert-character + #:switch-to-buffer + #:make-buffer + #:erase-buffer + #:buffer-pane-p + #:display-window - ;; Some configuration variables - #:*bg-color* - #:*fg-color* - #:*info-bg-color* - #:*info-fg-color* - #:*mini-bg-color* - #:*mini-fg-color*)) + ;; Some configuration variables + #:*bg-color* + #:*fg-color* + #:*info-bg-color* + #:*info-fg-color* + #:*mini-bg-color* + #:*mini-fg-color* + #:*with-scrollbars* + + ;; The command tables + #:global-climacs-table #:keyboard-macro-table #:climacs-help-table + #:base-table #:buffer-table #:case-table #:comment-table + #:deletion-table #:development-table #:editing-table + #:fill-table #:indent-table #:info-table #:marking-table + #:movement-table #:pane-table #:search-table #:self-insert-table + #:window-table + + ;; Other stuff + #:dabbrev-expansion-mark + #:original-prefix + #:prefix-start-offset + #:overwrite-mode + #:goal-column + )) + +(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 + #:goto-line + + #:possibly-fill-line + #:insert-character + #:back-to-indentation + #:delete-horizontal-space + #:indent-current-line + #:insert-pair + + #:downcase-word #:upcase-word #:capitalize-word + + #:indent-region + #:fill-line #:fill-region + + #:indent-line #:delete-indentation) + (:documentation "Package for editor functionality that is + syntax-aware, but yet not specific to certain + syntaxes. Contains stuff like indentation, filling and other + features that require a fairly high-level view of the + application, but are not solely GUI-specific.")) (defpackage :climacs-commands (:use :clim-lisp :clim :climacs-base :climacs-buffer :climacs-syntax :climacs-motion :climacs-editing - :climacs-gui :esa :climacs-kill-ring) + :climacs-gui :esa :climacs-kill-ring :climacs-pane + :climacs-abbrev :undo :climacs-core) (:export #:define-motion-commands #:define-deletion-commands #:define-editing-commands) --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/02 15:43:48 1.16 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/24 13:24:40 1.17 @@ -26,7 +26,7 @@ ;;; miscellaneous commands for the Climacs editor. -(in-package :climacs-gui) +(in-package :climacs-commands) (define-command (com-overwrite-mode :name t :command-table editing-table) () "Toggle overwrite mode for the current mode. @@ -52,6 +52,11 @@ 'buffer-table '((#\~ :meta :shift))) +(defun set-fill-column (column) + (if (> column 1) + (setf (auto-fill-column (current-window)) column) + (progn (beep) (display-message "Set Fill Column requires an explicit argument.")))) + (define-command (com-set-fill-column :name t :command-table fill-table) ((column 'integer :prompt "Column Number:")) "Set the fill column to the specified value. @@ -65,45 +70,6 @@ 'fill-table '((#\x :control) (#\f))) -(defun set-fill-column (column) - (if (> column 1) - (setf (auto-fill-column (current-window)) column) - (progn (beep) (display-message "Set Fill Column requires an explicit argument.")))) - -(defun possibly-fill-line () - (let* ((pane (current-window)) - (buffer (buffer pane))) - (when (auto-fill-mode pane) - (let* ((fill-column (auto-fill-column pane)) - (point (point pane)) - (offset (offset point)) - (tab-width (tab-space-count (stream-default-view pane))) - (syntax (syntax buffer))) - (when (>= (buffer-display-column buffer offset tab-width) - (1- fill-column)) - (fill-line point - (lambda (mark) - (syntax-line-indentation mark tab-width syntax)) - fill-column - tab-width - (syntax buffer))))))) - -(defun insert-character (char) - (let* ((window (current-window)) - (point (point window))) - (unless (constituentp char) - (possibly-expand-abbrev point)) - (when (whitespacep (syntax (buffer window)) char) - (possibly-fill-line)) - (if (and (slot-value window 'overwrite-mode) (not (end-of-line-p point))) - (progn - (delete-range point) - (insert-object point char)) - (insert-object point char)))) - -(define-command com-self-insert ((count 'integer)) - (loop repeat count do (insert-character *current-gesture*))) - (define-command (com-zap-to-object :name t :command-table deletion-table) () "Prompt for an object and kill to the next occurence of that object after point. Characters can be entered in #\ format." @@ -271,16 +237,6 @@ (untabify-region (mark pane) (point pane) (tab-space-count (stream-default-view pane))))) -(defun indent-current-line (pane point) - (let* ((buffer (buffer pane)) - (view (stream-default-view pane)) - (tab-space-count (tab-space-count view)) - (indentation (syntax-line-indentation point - tab-space-count - (syntax buffer)))) - (indent-line point indentation (and (indent-tabs-mode buffer) - tab-space-count)))) - (define-command (com-indent-line :name t :command-table indent-table) () (let* ((pane (current-window)) (point (point pane))) @@ -410,12 +366,6 @@ 'marking-table '((#\x :control) (#\h))) -(defun back-to-indentation (mark syntax) - (beginning-of-line mark) - (loop until (end-of-line-p mark) - while (whitespacep syntax (object-after mark)) - do (forward-object mark))) - (define-command (com-back-to-indentation :name t :command-table movement-table) () "Move point to the first non-whitespace object on the current line. If there is no non-whitespace object, leaves point at the end of the line." @@ -426,17 +376,6 @@ 'movement-table '((#\m :meta))) -(defun delete-horizontal-space (mark syntax &optional (backward-only-p nil)) - (let ((mark2 (clone-mark mark))) - (loop until (beginning-of-line-p mark) - while (whitespacep syntax (object-before mark)) - do (backward-object mark)) - (unless backward-only-p - (loop until (end-of-line-p mark2) - while (whitespacep syntax (object-after mark2)) - do (forward-object mark2))) - (delete-region mark mark2))) - (define-command (com-delete-horizontal-space :name t :command-table deletion-table) ((backward-only-p 'boolean :prompt "Delete backwards only?")) @@ -450,37 +389,19 @@ 'deletion-table '((#\\ :meta))) -(defun just-one-space (mark syntax count) - (let (offset) - (loop until (beginning-of-line-p mark) - while (whitespacep syntax (object-before mark)) - do (backward-object mark)) - (loop until (end-of-line-p mark) - while (whitespacep syntax (object-after mark)) - repeat count do (forward-object mark) - finally (setf offset (offset mark))) - (loop until (end-of-line-p mark) - while (whitespacep syntax (object-after mark)) - do (forward-object mark)) - (delete-region offset mark))) - (define-command (com-just-one-space :name t :command-table deletion-table) ((count 'integer :prompt "Number of spaces")) "Delete whitespace around point, leaving a single space. With a positive numeric argument, leave that many spaces. FIXME: should distinguish between types of whitespace." - (just-one-space (point (current-window)) - (syntax (buffer (current-window))) - count)) + (just-n-spaces (point (current-window)) + count)) (set-key `(com-just-one-space ,*numeric-argument-marker*) 'deletion-table '((#\Space :meta))) -(defun goto-position (mark pos) - (setf (offset mark) pos)) - (define-command (com-goto-position :name t :command-table movement-table) ((position 'integer :prompt "Goto Position")) "Prompts for an integer, and sets the offset of point to that integer." @@ -488,18 +409,6 @@ (point (current-window)) position)) -(defun goto-line (mark line-number) - (loop with m = (clone-mark (low-mark (buffer mark)) - :right) - initially (beginning-of-buffer m) - do (end-of-line m) - until (end-of-buffer-p m) - repeat (1- line-number) - do (incf (offset m)) - (end-of-line m) - finally (beginning-of-line m) - (setf (offset mark) (offset m)))) - (define-command (com-goto-line :name t :command-table movement-table) ((line-number 'integer :prompt "Goto Line")) "Prompts for a line number, and sets point to the beginning of that line. @@ -671,7 +580,9 @@ (let* ((window (current-window)) (point (point window)) (syntax (syntax (buffer window)))) - (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) window + (with-accessors ((original-prefix original-prefix) + (prefix-start-offset prefix-start-offset) + (dabbrev-expansion-mark dabbrev-expansion-mark)) window (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark) (setf (offset dabbrev-expansion-mark) (offset point)) @@ -829,26 +740,6 @@ ;; (defparameter *insert-pair-alist* ;; '((#\( #\)) (#\[ #\]) (#\{ #\}) (#\< #\>) (#\" #\") (#\' #\') (#\` #\'))) -(defun insert-pair (mark syntax &optional (count 0) (open #\() (close #\))) - (cond ((> count 0) - (loop while (and (not (end-of-buffer-p mark)) - (whitespacep syntax (object-after mark))) - do (forward-object mark))) - ((< count 0) - (setf count (- count)) - (loop repeat count do (backward-expression mark syntax)))) - (unless (or (beginning-of-buffer-p mark) - (whitespacep syntax (object-before mark))) - (insert-object mark #\Space)) - (insert-object mark open) - (let ((here (clone-mark mark))) - (loop repeat count - do (forward-expression here syntax)) - (insert-object here close) - (unless (or (end-of-buffer-p here) - (whitespacep syntax (object-after here))) - (insert-object here #\Space)))) - (defun insert-parentheses (mark syntax count) (insert-pair mark syntax count #\( #\))) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/24 08:20:28 1.11 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/24 13:24:40 1.12 @@ -72,7 +72,7 @@ (when (typep token 'string-form) (with-accessors ((offset1 start-offset) (offset2 end-offset)) token - (climacs-editing:fill-region (make-instance 'standard-right-sticky-mark + (climacs-core:fill-region (make-instance 'standard-right-sticky-mark :buffer implementation :offset offset1) (make-instance 'standard-right-sticky-mark @@ -94,7 +94,7 @@ (if (plusp count) (loop repeat count do (forward-expression mark syntax)) (loop repeat (- count) do (backward-expression mark syntax))) - (climacs-editing:indent-region pane (clone-mark point) mark))) + (climacs-core:indent-region pane (clone-mark point) mark))) (define-command (com-eval-last-expression :name t :command-table lisp-table) ((insertp 'boolean :prompt "Insert?")) @@ -106,7 +106,7 @@ (with-syntax-package syntax mark (package) (let ((*package* package) (*read-base* (base syntax))) - (climacs-gui::com-eval-expression + (climacs-commands::com-eval-expression (token-to-object syntax token :read t) insertp))) (esa:display-message "Nothing to evaluate.")))) --- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/22 20:35:06 1.222 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/24 13:24:40 1.223 @@ -30,12 +30,12 @@ (defclass extended-pane (climacs-pane esa-pane-mixin) (;; for next-line and previous-line commands - (goal-column :initform nil) + (goal-column :initform nil :accessor goal-column) ;; for dynamic abbrev expansion - (original-prefix :initform nil) - (prefix-start-offset :initform nil) - (dabbrev-expansion-mark :initform nil) - (overwrite-mode :initform nil))) + (original-prefix :initform nil :accessor original-prefix) + (prefix-start-offset :initform nil :accessor prefix-start-offset) + (dabbrev-expansion-mark :initform nil :accessor dabbrev-expansion-mark) + (overwrite-mode :initform nil :accessor overwrite-mode))) (defgeneric buffer-pane-p (pane) (:documentation "Returns T when a pane contains a buffer.")) @@ -128,7 +128,6 @@ (define-application-frame climacs (standard-application-frame esa-frame-mixin) ((buffers :initform '() :accessor buffers)) - (:command-table (global-climacs-table :inherit-from (global-esa-table keyboard-macro-table @@ -369,6 +368,9 @@ 'base-table '((#\c :control) (#\l :control))) +(define-command com-self-insert ((count 'integer)) + (loop repeat count do (insert-character *current-gesture*))) + (loop for code from (char-code #\Space) to (char-code #\~) do (set-key `(com-self-insert ,*numeric-argument-marker*) 'self-insert-table --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/06/12 19:10:58 1.20 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/07/24 13:24:40 1.21 @@ -26,7 +26,7 @@ ;;; File commands for the Climacs editor. -(in-package :climacs-gui) +(in-package :climacs-commands) (defun filename-completer (so-far mode) (flet ((remove-trail (s) --- /project/climacs/cvsroot/climacs/editing.lisp 2006/07/21 05:08:26 1.3 +++ /project/climacs/cvsroot/climacs/editing.lisp 2006/07/24 13:24:40 1.4 @@ -264,126 +264,3 @@ (define-edit-fns expression) (define-edit-fns definition) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Character case - -(defun downcase-word (mark &optional (n 1)) - "Convert the next N words to lowercase, leaving mark after the last word." - (let ((syntax (syntax (buffer mark)))) - (loop repeat n - do (forward-to-word-boundary mark syntax) - (let ((offset (offset mark))) - (forward-word mark syntax 1 nil) - (downcase-region offset mark))))) - -(defun upcase-word (mark syntax &optional (n 1)) - "Convert the next N words to uppercase, leaving mark after the last word." - (loop repeat n - do (forward-to-word-boundary mark syntax) - (let ((offset (offset mark))) - (forward-word mark syntax 1 nil) - (upcase-region offset mark)))) - -(defun capitalize-word (mark &optional (n 1)) - "Capitalize the next N words, leaving mark after the last word." - (let ((syntax (syntax (buffer mark)))) - (loop repeat n - do (forward-to-word-boundary mark syntax) - (let ((offset (offset mark))) - (forward-word mark syntax 1 nil) - (capitalize-region offset mark))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Indentation - -(defun indent-region (pane mark1 mark2) - "Indent all lines in the region delimited by `mark1' and `mark2' - according to the rules of the active syntax in `pane'." - (let* ((buffer (buffer pane)) - (view (clim:stream-default-view pane)) - (tab-space-count (tab-space-count view)) - (tab-width (and (indent-tabs-mode buffer) - tab-space-count)) - (syntax (syntax buffer))) - (do-buffer-region-lines (line mark1 mark2) - (let ((indentation (syntax-line-indentation - line - tab-space-count - syntax))) - (indent-line line indentation tab-width)) - ;; We need to update the syntax every time we perform an - ;; indentation, so that subsequent indentations will be - ;; correctly indented (this matters in list forms). FIXME: This - ;; should probably happen automatically. - (update-syntax buffer syntax)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Auto fill - -(defun fill-line (mark syntax-line-indentation-function fill-column tab-width syntax - &optional (compress-whitespaces t)) - "Breaks the contents of line pointed to by MARK up to MARK into -multiple lines such that none of them is longer than FILL-COLUMN. If -COMPRESS-WHITESPACES is non-nil, whitespaces are compressed after the -decision is made to break the line at a point. For now, the -compression means just the deletion of trailing whitespaces." - (let ((begin-mark (clone-mark mark))) - (beginning-of-line begin-mark) - (loop with column = 0 - with line-beginning-offset = (offset begin-mark) - with walking-mark = (clone-mark begin-mark) - while (mark< walking-mark mark) - as object = (object-after walking-mark) - do (case object - (#\Space - (setf (offset begin-mark) (offset walking-mark)) - (incf column)) - (#\Tab - (setf (offset begin-mark) (offset walking-mark)) - (incf column (- tab-width (mod column tab-width)))) - (t - (incf column))) - (when (and (>= column fill-column) - (/= (offset begin-mark) line-beginning-offset)) - (when compress-whitespaces - (let ((offset (buffer-search-backward - (buffer begin-mark) - (offset begin-mark) - #(nil) - :test #'(lambda (o1 o2) - (declare (ignore o2)) - (not (whitespacep syntax o1)))))) - (when offset - (delete-region begin-mark (1+ offset))))) - (insert-object begin-mark #\Newline) - (incf (offset begin-mark)) - (let ((indentation - (funcall syntax-line-indentation-function begin-mark))) - (indent-line begin-mark indentation tab-width)) - (beginning-of-line begin-mark) - (setf line-beginning-offset (offset begin-mark)) - (setf (offset walking-mark) (offset begin-mark)) - (setf column 0)) - (incf (offset walking-mark))))) - -(defun fill-region (mark1 mark2 syntax-line-indentation-function fill-column tab-width syntax - &optional (compress-whitespaces t)) - "Fill the region delimited by `mark1' and `mark2'. `Mark1' must be -mark<= `mark2.'" - (let* ((buffer (buffer mark1))) - (do-buffer-region (object offset buffer - (offset mark1) (offset mark2)) - (when (eql object #\Newline) - (setf object #\Space))) - (when (>= (buffer-display-column buffer (offset mark2) tab-width) - (1- fill-column)) - (fill-line mark2 - syntax-line-indentation-function - fill-column - tab-width - compress-whitespaces - syntax)))) \ No newline at end of file --- /project/climacs/cvsroot/climacs/developer-commands.lisp 2006/03/03 19:38:57 1.2 +++ /project/climacs/cvsroot/climacs/developer-commands.lisp 2006/07/24 13:24:40 1.3 @@ -26,7 +26,7 @@ ;;; Commands for developing the Climacs editor. -(in-package :climacs-gui) +(in-package :climacs-commands) (define-command (com-reset-profile :name t :command-table development-table) () #+sbcl (sb-profile:reset) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/11 14:20:20 1.47 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/24 13:24:40 1.48 @@ -86,14 +86,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")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands" + "misc-commands" "window-commands" "file-commands" "core")) #.(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" "abbrev" "editing" "motion")) - (:file "climacs" :depends-on ("gui")) + (: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")) @@ -111,7 +113,7 @@ :components ((:file "rt" :pathname #p"testing/rt.lisp") (:file "buffer-test" :depends-on ("rt")) - (:file "base-test" :depends-on ("rt")) + (:file "base-test" :depends-on ("rt" "buffer-test")) (:module "cl-automaton" :depends-on ("rt") --- /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/08 00:11:22 1.22 +++ /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/24 13:24:40 1.23 @@ -4,7 +4,8 @@ ;;; (cl:defpackage :climacs-tests - (:use :cl :rtest :climacs-buffer :climacs-base :climacs-motion :climacs-editing :automaton)) + (:use :cl :rtest :climacs-buffer :climacs-base :climacs-motion + :climacs-editing :automaton :climacs-core)) (cl:in-package :climacs-tests) --- /project/climacs/cvsroot/climacs/base.lisp 2006/07/23 11:57:10 1.55 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/24 13:24:40 1.56 @@ -666,52 +666,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Indentation - -(defgeneric indent-line (mark indentation tab-width) - (:documentation "Indent the line containing mark with indentation -spaces. Use tabs and spaces if tab-width is not nil, otherwise use -spaces only.")) - -(defun indent-line* (mark indentation tab-width left) - (let ((mark2 (clone-mark mark))) - (beginning-of-line mark2) - (loop until (end-of-buffer-p mark2) - as object = (object-after mark2) - while (or (eql object #\Space) (eql object #\Tab)) - do (delete-range mark2 1)) - (loop until (zerop indentation) - do (cond ((and tab-width (>= indentation tab-width)) - (insert-object mark2 #\Tab) - (when left ; spaces must follow tabs - (forward-object mark2)) - (decf indentation tab-width)) - (t - (insert-object mark2 #\Space) - (decf indentation)))))) - -(defmethod indent-line ((mark left-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width t)) - -(defmethod indent-line ((mark right-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width nil)) - -(defun delete-indentation (mark) - (beginning-of-line mark) - (unless (beginning-of-buffer-p mark) - (delete-range mark -1) - (loop until (end-of-buffer-p mark) - while (buffer-whitespacep (object-after mark)) - do (delete-range mark 1)) - (loop until (beginning-of-buffer-p mark) - while (buffer-whitespacep (object-before mark)) - do (delete-range mark -1)) - (when (and (not (beginning-of-buffer-p mark)) - (constituentp (object-before mark))) - (insert-object mark #\Space)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Kill ring (defvar *kill-ring* (make-instance 'kill-ring :max-size 7))

1 0

[climacs-cvs] CVS climacs
by thenriksen 24 Jul '06

24 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28737 Modified Files: lisp-syntax.lisp lisp-syntax-commands.lisp Log Message: Non-10 bases should work properly now. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/23 20:31:56 1.97 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/24 08:20:27 1.98 @@ -72,8 +72,7 @@ designator in the form. The list is sorted with the earliest (in-package) forms last (descending offset).") - (base :accessor base - :initform 10 + (base :initform nil :documentation "The base which numbers in the buffer are expected to be in.") (option-specified-package :accessor option-specified-package @@ -91,6 +90,13 @@ (:pathname-types "lisp" "lsp" "cl") (:command-table lisp-table)) +(defgeneric base (syntax) + (:documentation "Get the base `syntax' should interpret numbers + in.") + (:method ((syntax lisp-syntax)) + (or (slot-value syntax 'base) + *read-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)))) @@ -160,7 +166,8 @@ the source code.") (:method (image form buffer buffer-mark) (compile-string-for-climacs image - (write-to-string form) + (let ((*print-base* (base (syntax buffer)))) + (write-to-string form)) *package* buffer buffer-mark))) (defgeneric compile-file-for-climacs (image filepath package &optional load-p) @@ -3086,23 +3093,26 @@ (defun eval-region (start end syntax) ;; Must be (mark>= end start). - (with-slots (package) syntax - (let* ((string (buffer-substring (buffer start) - (offset start) - (offset end))) - (values (multiple-value-list - (eval-string syntax string))) - ;; Enclose each set of values in {}. - (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}" - values))) - (esa:display-message result)))) + (with-syntax-package syntax start (package) + (let ((*package* package) + (*read-base* (base syntax))) + (let* ((string (buffer-substring (buffer start) + (offset start) + (offset end))) + (values (multiple-value-list + (eval-string syntax string))) + ;; Enclose each set of values in {}. + (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}" + values))) + (esa:display-message result))))) (defun compile-definition-interactively (mark syntax) (with-syntax-package syntax mark (package) (let* ((token (definition-at-mark mark syntax)) (string (token-string syntax token)) (m (clone-mark mark)) - (buffer-name (name (buffer syntax)))) + (buffer-name (name (buffer syntax))) + (*read-base* (base syntax))) (forward-definition m syntax) (backward-definition m syntax) (multiple-value-bind (result notes) @@ -3122,12 +3132,13 @@ (accept 'boolean :prompt (format nil "Save buffer ~A ?" (name buffer)))) (climacs-gui::save-buffer buffer)) (with-syntax-package (syntax buffer) 0 (package) - (multiple-value-bind (result notes) - (compile-file-for-climacs (get-usable-image (syntax buffer)) - (filepath buffer) - package load-p) - (show-note-counts notes (second result)) - (when notes (show-notes notes (name buffer) ""))))) + (let ((*read-base* (base (syntax buffer)))) + (multiple-value-bind (result notes) + (compile-file-for-climacs (get-usable-image (syntax buffer)) + (filepath buffer) + package load-p) + (show-note-counts notes (second result)) + (when notes (show-notes notes (name buffer) "")))))) ;;; Parameter hinting --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/23 20:31:56 1.10 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/24 08:20:28 1.11 @@ -104,7 +104,8 @@ (token (form-before syntax (offset mark)))) (if token (with-syntax-package syntax mark (package) - (let ((*package* package)) + (let ((*package* package) + (*read-base* (base syntax))) (climacs-gui::com-eval-expression (token-to-object syntax token :read t) insertp))) @@ -141,9 +142,8 @@ (point (point (current-window)))) (when (mark> mark point) (rotatef mark point)) - (evaluating-interactively - (eval-region mark point - (syntax (buffer (current-window))))))) + (eval-region mark point + (syntax (buffer (current-window)))))) (define-command (com-compile-definition :name t :command-table lisp-table) ()

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Jul '06

23 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3885 Modified Files: lisp-syntax.lisp lisp-syntax-commands.lisp Log Message: Many changes, but CVS makes it too painful to break it up into smaller patches (/me wishes for more modern VCS). The highlights are: * Symbol completion should no longer nuke quoting. * Symbol completion is now more intelligent with respect to completion of keywords for keyword arguments. * Changed some form selection functions to accept offsets as well as marks (using the `as-offsets' macro). * Realized that this syntax is becoming quite complex, slight refactoring is needed. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/22 22:12:04 1.96 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/23 20:31:56 1.97 @@ -1305,17 +1305,15 @@ found, return the package specified in the attribute list. If no package can be found at all, or the otherwise found packages are invalid, return the CLIM-USER package." - (let* ((mark-offset (if (numberp mark-or-offset) - mark-or-offset - (offset mark-or-offset))) - (designator (rest (find mark-offset (package-list syntax) - :key #'first - :test #'>=)))) - (or (handler-case (find-package designator) - (type-error () + (as-offsets ((mark-or-offset offset)) + (let* ((designator (rest (find offset (package-list syntax) + :key #'first + :test #'>=)))) + (or (handler-case (find-package designator) + (type-error () nil)) - (find-package (option-specified-package syntax)) - (find-package :clim-user)))) + (find-package (option-specified-package syntax)) + (find-package :clim-user))))) (defmacro with-syntax-package (syntax offset (package-sym) &body body) @@ -1489,8 +1487,6 @@ (:method (form syntax) nil)) (defmethod form-operands ((form list-form) syntax) - ;; If *anything' goes wrong, just assume that we could not find any - ;; operands and return nil. (mapcar #'(lambda (operand) (if (typep operand 'form) (token-to-object syntax operand :no-error t))) @@ -1517,60 +1513,64 @@ ;;; ;;; Useful functions for selecting forms based on the mark. -(defun expression-at-mark (mark syntax) - "Return the form at `mark'. If `mark' is just after, +(defun expression-at-mark (mark-or-offset syntax) + "Return the form at `mark-or-offset'. If `mark-or-offset' is just after, or inside, a top-level-form, or if there are no forms after -`mark', the form preceding `mark' is returned. Otherwise, the -form following `mark' is returned." - (or (form-around syntax (offset mark)) - (form-after syntax (offset mark)) - (form-before syntax (offset mark)))) - -(defun definition-at-mark (mark syntax) - "Return the top-level form at `mark'. If `mark' is just after, -or inside, a top-level-form, or if there are no forms after -`mark', the top-level-form preceding `mark' is -returned. Otherwise, the top-level-form following `mark' is +`mark-or-offset', the form preceding `mark-or-offset' is +returned. Otherwise, the form following `mark-or-offset' is returned." - (form-toplevel (expression-at-mark mark syntax) syntax)) + (as-offsets ((mark-or-offset offset)) + (or (form-around syntax offset) + (form-after syntax offset) + (form-before syntax offset)))) -(defun symbol-at-mark (mark syntax) - "Return a symbol token at mark. This function will \"unwrap\" - quote-forms in order to return the symbol token. If no symbol - token can be found, NIL will be returned." +(defun definition-at-mark (mark-or-offset syntax) + "Return the top-level form at `mark-or-offset'. If `mark-or-offset' is just after, +or inside, a top-level-form, or if there are no forms after +`mark-or-offset', the top-level-form preceding `mark-or-offset' +is returned. Otherwise, the top-level-form following +`mark-or-offset' is returned." + (form-toplevel (expression-at-mark mark-or-offset syntax) syntax)) + +(defun symbol-at-mark (mark-or-offset syntax) + "Return a symbol token at `mark-or-offset'. This function will + \"unwrap\" quote-forms in order to return the symbol token. If + no symbol token can be found, NIL will be returned." (labels ((unwrap-form (form) (cond ((typep form 'quote-form) (unwrap-form (first-form (children form)))) ((typep form 'complete-token-lexeme) form)))) - (unwrap-form (expression-at-mark mark syntax)))) + (unwrap-form (expression-at-mark mark-or-offset syntax)))) -(defun this-form (mark syntax) - "Return a form at mark. This function defines which +(defun this-form (mark-or-offset syntax) + "Return a form at `mark-or-offset'. This function defines which forms the COM-FOO-this commands affect." - (or (form-around syntax (offset mark)) - (form-before syntax (offset mark)))) - -(defun preceding-form (mark syntax) - "Return a form at mark." - (or (form-before syntax (offset mark)) - (form-around syntax (offset mark)))) + (as-offsets ((mark-or-offset offset)) + (or (form-around syntax offset) + (form-before syntax offset)))) + +(defun preceding-form (mark-or-offset syntax) + "Return a form at `mark-or-offset'." + (as-offsets ((mark-or-offset offset)) + (or (form-before syntax offset) + (form-around syntax offset)))) (defun text-of-definition-at-mark (mark syntax) "Return the text of the definition at mark." (let ((definition (definition-at-mark mark syntax))) (buffer-substring (buffer mark) - (start-offset definition) + (start-offset definition) (end-offset definition)))) -(defun text-of-expression-at-mark (mark syntax) - "Return the text of the expression at mark." - (let ((expression (expression-at-mark mark syntax))) +(defun text-of-expression-at-mark (mark-or-offset syntax) + "Return the text of the expression at `mark-or-offset'." + (let ((expression (expression-at-mark mark-or-offset syntax))) (token-string syntax expression))) -(defun symbol-name-at-mark (mark syntax) - "Return the text of the symbol at mark." - (let ((token (symbol-at-mark mark syntax))) +(defun symbol-name-at-mark (mark-or-offset syntax) + "Return the text of the symbol at `mark-or-offset'." + (let ((token (symbol-at-mark mark-or-offset syntax))) (when token (token-string syntax token)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1581,8 +1581,7 @@ "Replace the symbol at `mark' with `string' and move `mark' to after `string'." (let ((token (symbol-at-mark mark syntax))) - (unless (= (offset mark) (start-offset token)) - (backward-expression mark syntax 1 nil)) + (setf (offset mark) (start-offset token)) (forward-kill-expression mark syntax) (insert-sequence mark string))) @@ -1844,15 +1843,15 @@ (should-highlight (or (= (the fixnum (end-offset parse-symbol)) point-offset) (= (the fixnum (start-offset parse-symbol)) point-offset)))) (if should-highlight - (with-text-face (pane :bold) - (display-parse-tree (car children) syntax pane)) - (display-parse-tree (car children) syntax pane)) + (with-text-face (pane :bold) + (display-parse-tree (car children) syntax pane)) + (display-parse-tree (car children) syntax pane)) (loop for child-list on (cdr children) if (and should-highlight (null (cdr child-list))) do - (with-text-face (pane :bold) - (display-parse-tree (car child-list) syntax pane)) - else do - (display-parse-tree (car child-list) syntax pane)))) + (with-text-face (pane :bold) + (display-parse-tree (car child-list) syntax pane)) + else do + (display-parse-tree (car child-list) syntax pane)))) (defmethod display-parse-tree ((parse-symbol incomplete-list-form) (syntax lisp-syntax) pane) (let* ((children (children parse-symbol)) @@ -3559,44 +3558,42 @@ (defun find-operand-info (mark-or-offset syntax operator-form) "Returns two values: The operand preceding `mark-or-offset' and the path from `operator-form' to the operand." - (let* ((offset (if (numberp mark-or-offset) - mark-or-offset - (offset mark-or-offset))) - (preceding-arg-token (form-before syntax offset)) - (indexing-start-arg - (let* ((candidate-before preceding-arg-token) - (candidate-after (when (null candidate-before) - (let ((after (form-after syntax offset))) - (when after - (parent after))))) - (candidate-around (when (null candidate-after) - (form-around syntax offset))) - (candidate (or candidate-before - candidate-after - candidate-around))) - (if (or (and candidate-before - (typep candidate-before 'incomplete-list-form)) - (and (null candidate-before) - (typep (or candidate-after candidate-around) - 'list-form))) - ;; HACK: We should not attempt to find the location of - ;; the list form itself, so we create a new parser - ;; symbol, attach the list form as a parent and try to - ;; find the new symbol. That way we can get a list of - ;; argument-indices to the first element of the list - ;; form, even if it is empty or incomplete. - (let ((obj (make-instance 'parser-symbol))) - (setf (parent obj) candidate) - obj) - candidate))) - (argument-indices (find-argument-indices-for-operand - syntax - indexing-start-arg - operator-form)) - (preceding-arg-obj (when preceding-arg-token - (token-to-object syntax preceding-arg-token - :no-error t)))) - (values preceding-arg-obj argument-indices))) + (as-offsets ((mark-or-offset offset)) + (let* ((preceding-arg-token (form-before syntax offset)) + (indexing-start-arg + (let* ((candidate-before preceding-arg-token) + (candidate-after (when (null candidate-before) + (let ((after (form-after syntax offset))) + (when after + (parent after))))) + (candidate-around (when (null candidate-after) + (form-around syntax offset))) + (candidate (or candidate-before + candidate-after + candidate-around))) + (if (or (and candidate-before + (typep candidate-before 'incomplete-list-form)) + (and (null candidate-before) + (typep (or candidate-after candidate-around) + 'list-form))) + ;; HACK: We should not attempt to find the location of + ;; the list form itself, so we create a new parser + ;; symbol, attach the list form as a parent and try to + ;; find the new symbol. That way we can get a list of + ;; argument-indices to the first element of the list + ;; form, even if it is empty or incomplete. + (let ((obj (make-instance 'parser-symbol))) + (setf (parent obj) candidate) + obj) + candidate))) + (argument-indices (find-argument-indices-for-operand + syntax + indexing-start-arg + operator-form)) + (preceding-arg-obj (when preceding-arg-token + (token-to-object syntax preceding-arg-token + :no-error t)))) + (values preceding-arg-obj argument-indices)))) (defun valid-operator-p (operator) "Check whether or not `operator' is a valid @@ -3654,9 +3651,9 @@ (when (parent form) (recurse (parent form))))) -(defmacro with-code-insight (mark syntax (&key operator preceding-operand - form preceding-operand-indices - operands) +(defmacro with-code-insight (mark-or-offset syntax (&key operator preceding-operand + form preceding-operand-indices + operands) &body body) "Evaluate `body' with the provided symbols lexically bound to interesting details about the code at `mark'. If `mark' is not @@ -3669,7 +3666,7 @@ ;; My kingdom for with-gensyms (or once-only)! (mark-value-sym (gensym)) (syntax-value-sym (gensym))) - `(let* ((,mark-value-sym ,mark) + `(let* ((,mark-value-sym ,mark-or-offset) (,syntax-value-sym ,syntax) (,form-sym ;; Find a form with a valid (fboundp) operator. @@ -3683,35 +3680,38 @@ ;; cannot find a form with a valid operator, just ;; return the form `mark' is in. (unless (null immediate-form) - (labels ((recurse (form) - (unless (null (parent form)) - (or (unless (eq (first-form (children (parent form))) - form) - (recurse (parent form))) - (and (valid-operator-p (form-operator - form - ,syntax-value-sym)) - (indices-match-arglist - (arglist-for-form - (form-operator - form - ,syntax-value-sym) - (form-operands - form - ,syntax-value-sym)) - (second - (multiple-value-list - (find-operand-info ,mark-value-sym ,syntax-value-sym form)))) - (not (direct-arg-p form ,syntax-value-sym)) - form))))) - (or (recurse (parent immediate-form)) - (parent immediate-form)))))) + (labels ((recurse (form) + (unless (null (parent form)) + (or (unless (eq (first-form (children (parent form))) + form) + (recurse (parent form))) + (and (valid-operator-p (form-operator + form + ,syntax-value-sym)) + (indices-match-arglist + (arglist-for-form + (form-operator + form + ,syntax-value-sym) + (form-operands + form + ,syntax-value-sym)) + (second + (multiple-value-list + (find-operand-info ,mark-value-sym ,syntax-value-sym form)))) + (not (direct-arg-p form ,syntax-value-sym)) + form))))) + (or (recurse (parent immediate-form)) + (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking ;; up any of this stuff. (,operator-sym (when ,form-sym (form-operator ,form-sym ,syntax-value-sym))) (,operands-sym (when ,form-sym (form-operands ,form-sym ,syntax-value-sym)))) + (declare (ignorable ,mark-value-sym ,syntax-value-sym ,form-sym + ,operator-sym ,operands-sym)) (multiple-value-bind (,preceding-operand-sym ,operand-indices-sym) (when ,form-sym (find-operand-info ,mark-value-sym ,syntax-value-sym ,form-sym)) + (declare (ignorable ,preceding-operand-sym ,operand-indices-sym)) ,@body)))) (defun show-arglist-for-form-at-mark (mark syntax) @@ -3824,6 +3824,103 @@ (defvar *completion-pane* nil) +(defun relevant-keywords (arglist arg-indices) + "Return a list of the keyword arguments that it would make + sense to use at the position `arg-indices' relative to the + operator that has the argument list `arglist'." + (let* ((key-position (position '&key arglist)) + (cleaned-arglist (remove-if #'arglist-keyword-p + arglist)) + (index (first arg-indices)) + (difference (- (length arglist) + (length cleaned-arglist)))) + (cond ((and (null key-position) + (rest arg-indices) + (> (length cleaned-arglist) + index) + (listp (elt cleaned-arglist index))) + ;; Look in a nested argument list. + (relevant-keywords (elt cleaned-arglist index) + (rest arg-indices))) + ((and (not (null key-position)) + (>= (+ index + difference) + key-position) + (not (evenp (- index key-position difference)))) + (mapcar #'unlisted (subseq cleaned-arglist + (- key-position + difference + -1))))))) + +(defun completions-from-keywords (syntax token) + "Assume that `token' is a (partial) keyword argument +keyword. Find out which operator it is applicable to, and return +a completion list based on the valid keywords, or NIL, if no +keyword arguments would be valid (for example, if the operator +doesn't take keyword arguments)." + (with-code-insight (start-offset token) syntax + (:preceding-operand-indices poi + :operator operator) + (when (valid-operator-p operator) + (let* ((relevant-keywords + (relevant-keywords (arglist-for-form operator) + poi)) + (completions (simple-completions + (get-usable-image syntax) + (token-string syntax token) + +keyword-package+)) + (relevant-completions + (remove-if-not #'(lambda (compl) + (member compl relevant-keywords + :test #'(lambda (a b) + (string-equal a b + :start1 1)) + :key #'symbol-name)) + (mapcar #'string-downcase (first completions))))) + (list relevant-completions + (longest-completion relevant-completions)))))) + +;; The following stuff is from Swank. + +(defun longest-completion (completions) + "Return the longest completion of `completions', which must be a +list of sequences." [76 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/21 06:15:40 1.9 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/23 20:31:56 1.10 @@ -254,11 +254,11 @@ (buffer (buffer pane)) (syntax (syntax buffer)) (mark (point pane)) - (name (symbol-name-at-mark mark - syntax))) - (when name + (token (symbol-at-mark mark + syntax))) + (when token (with-syntax-package syntax mark (package) - (let ((completion (show-completions syntax name package))) + (let ((completion (show-completions syntax token package))) (unless (= (length completion) 0) (replace-symbol-at-mark mark syntax completion)))))))

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Jul '06

23 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv31341 Modified Files: packages.lisp Log Message: Export the `as-offsets' macro from :climacs-base. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/11 14:20:20 1.104 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/23 11:59:38 1.105 @@ -75,7 +75,8 @@ (defpackage :climacs-base (:use :clim-lisp :climacs-buffer :climacs-kill-ring) - (:export #:do-buffer-region + (:export #:as-offsets + #:do-buffer-region #:do-buffer-region-lines #:previous-line #:next-line #:open-line

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Jul '06

23 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv31285 Modified Files: base.lisp Log Message: Added `as-offsets' macro for ease of writing functions that accept both offsets and marks. --- /project/climacs/cvsroot/climacs/base.lisp 2006/07/07 23:59:38 1.54 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/23 11:57:10 1.55 @@ -32,6 +32,30 @@ (in-package :climacs-base) +(defmacro as-offsets ((&rest marks) + &body body) + "Bind the symbols in `marks' to the numeric offsets of the mark + objects that the symbols are bound to. If a symbol in `mark' is + already bound to an offset, just keep that binding. An element + of `marks' may also be a list - in this case, the first element + is used to get an offset, and the second element (which should + be a symbol) will be bound to this offset. Evaluate `body' with + these bindings." + `(let ,(mapcar #'(lambda (mark-sym) + (if (listp mark-sym) + `(,(second mark-sym) + (let ((value ,(first mark-sym))) + (if (numberp value) + value + (offset value)))) + `(,mark-sym + (let ((value ,mark-sym)) + (if (numberp value) + ,mark-sym + (offset value)))))) + marks) + ,@body)) + (defmacro do-buffer-region ((object offset buffer offset1 offset2) &body body) "Iterate over the elements of the region delimited by offset1 and offset2.

1 0