[climacs-cvs] CVS update: climacs/syntax.lisp climacs/packages.lisp climacs/gui.lisp
Dave Murray
dmurray at common-lisp.net
Tue Aug 16 23:10:32 UTC 2005
Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv5492
Modified Files:
syntax.lisp packages.lisp gui.lisp
Log Message:
Various refactoring to allow non-interactive access to functionality.
Checks to see that buffers aren't written to, or attempted to be
read from, directories. com-load-file now on C-c C-l.
Also some rearrangement of stuff in gui.lisp.
Date: Wed Aug 17 01:10:30 2005
Author: dmurray
Index: climacs/syntax.lisp
diff -u climacs/syntax.lisp:1.56 climacs/syntax.lisp:1.57
--- climacs/syntax.lisp:1.56 Sun Aug 14 14:12:35 2005
+++ climacs/syntax.lisp Wed Aug 17 01:10:29 2005
@@ -216,6 +216,13 @@
(declare (ignore success string))
object))
+(defun syntax-from-name (syntax)
+ (let ((description (find syntax *syntaxes*
+ :key #'syntax-description-name
+ :test #'string-equal)))
+ (when description
+ (find-class (syntax-description-class-name description)))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Basic syntax
Index: climacs/packages.lisp
diff -u climacs/packages.lisp:1.77 climacs/packages.lisp:1.78
--- climacs/packages.lisp:1.77 Tue Aug 16 01:31:22 2005
+++ climacs/packages.lisp Wed Aug 17 01:10:29 2005
@@ -92,6 +92,7 @@
(defpackage :climacs-syntax
(:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain)
(:export #:syntax #:define-syntax
+ #:syntax-from-name
#:basic-syntax
#:update-syntax #:update-syntax-for-display
#:grammar #:grammar-rule #:add-rule
Index: climacs/gui.lisp
diff -u climacs/gui.lisp:1.177 climacs/gui.lisp:1.178
--- climacs/gui.lisp:1.177 Tue Aug 16 01:31:22 2005
+++ climacs/gui.lisp Wed Aug 17 01:10:29 2005
@@ -189,6 +189,9 @@
(setf (needs-saving (buffer (current-window))) nil))
(define-named-command com-set-fill-column ((column 'integer :prompt "Column Number:"))
+ (set-fill-column column))
+
+(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."))))
@@ -279,15 +282,17 @@
(delete-range current-point (- (offset item-mark) current-offset))))
(define-named-command com-transpose-objects ()
- (let* ((point (point (current-window))))
- (unless (beginning-of-buffer-p point)
- (when (end-of-line-p point)
- (backward-object point))
- (let ((object (object-after point)))
- (delete-range point)
- (backward-object point)
- (insert-object point object)
- (forward-object point)))))
+ (transpose-objects (point (current-window))))
+
+(defun transpose-objects (mark)
+ (unless (beginning-of-buffer-p mark)
+ (when (end-of-line-p mark)
+ (backward-object mark))
+ (let ((object (object-after mark)))
+ (delete-range mark)
+ (backward-object mark)
+ (insert-object mark object)
+ (forward-object mark))))
(define-named-command com-backward-object ((count 'integer :prompt "Number of Objects"))
(backward-object (point (current-window)) count))
@@ -296,51 +301,55 @@
(forward-object (point (current-window)) count))
(define-named-command com-transpose-words ()
- (let* ((point (point (current-window))))
- (let (bw1 bw2 ew1 ew2)
- (backward-word point)
- (setf bw1 (offset point))
- (forward-word point)
- (setf ew1 (offset point))
- (forward-word point)
- (when (= (offset point) ew1)
- ;; this is emacs' message in the minibuffer
- (error "Don't have two things to transpose"))
- (setf ew2 (offset point))
- (backward-word point)
- (setf bw2 (offset point))
- (let ((w2 (buffer-sequence (buffer point) bw2 ew2))
- (w1 (buffer-sequence (buffer point) bw1 ew1)))
- (delete-word point)
- (insert-sequence point w1)
- (backward-word point)
- (backward-word point)
- (delete-word point)
- (insert-sequence point w2)
- (forward-word point)))))
+ (transpose-words (point (current-window))))
+
+(defun transpose-words (mark)
+ (let (bw1 bw2 ew1 ew2)
+ (backward-word mark)
+ (setf bw1 (offset mark))
+ (forward-word mark)
+ (setf ew1 (offset mark))
+ (forward-word mark)
+ (when (= (offset mark) ew1)
+ ;; this is emacs' message in the minibuffer
+ (error "Don't have two things to transpose"))
+ (setf ew2 (offset mark))
+ (backward-word mark)
+ (setf bw2 (offset mark))
+ (let ((w2 (buffer-sequence (buffer mark) bw2 ew2))
+ (w1 (buffer-sequence (buffer mark) bw1 ew1)))
+ (delete-word mark)
+ (insert-sequence mark w1)
+ (backward-word mark)
+ (backward-word mark)
+ (delete-word mark)
+ (insert-sequence mark w2)
+ (forward-word mark))))
(define-named-command com-transpose-lines ()
- (let ((point (point (current-window))))
- (beginning-of-line point)
- (unless (beginning-of-buffer-p point)
- (previous-line point))
- (let* ((bol (offset point))
- (eol (progn (end-of-line point)
- (offset point)))
- (line (buffer-sequence (buffer point) bol eol)))
- (delete-region bol point)
- ;; Remove newline at end of line as well.
- (unless (end-of-buffer-p point)
- (delete-range point))
- ;; If the current line is at the end of the buffer, we want to
- ;; be able to insert past it, so we need to get an extra line
- ;; at the end.
- (end-of-line point)
- (when (end-of-buffer-p point)
- (insert-object point #\Newline))
- (next-line point 0)
- (insert-sequence point line)
- (insert-object point #\Newline))))
+ (transpose-lines (point (current-window))))
+
+(defun transpose-lines (mark)
+ (beginning-of-line mark)
+ (unless (beginning-of-buffer-p mark)
+ (previous-line mark))
+ (let* ((bol (offset mark))
+ (eol (progn (end-of-line mark)
+ (offset mark)))
+ (line (buffer-sequence (buffer mark) bol eol)))
+ (delete-region bol mark)
+ ;; Remove newline at end of line as well.
+ (unless (end-of-buffer-p mark)
+ (delete-range mark))
+ ;; If the current line is at the end of the buffer, we want to
+ ;; be able to insert past it, so we need to get an extra line
+ ;; at the end.
+ (end-of-line mark)
+ (when (end-of-buffer-p mark)
+ (insert-object mark #\Newline))
+ (next-line mark 0)
+ (insert-sequence mark line)
+ (insert-object mark #\Newline)))
(define-named-command com-previous-line ((numarg 'integer :prompt "How many lines?"))
(let* ((win (current-window))
@@ -365,36 +374,40 @@
(define-named-command com-open-line ((numarg 'integer :prompt "How many lines?"))
(open-line (point (current-window)) numarg))
+(defun kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil))
+ (let ((start (offset mark)))
+ (cond ((= 0 count)
+ (beginning-of-line mark))
+ ((< count 0)
+ (loop repeat (- count)
+ until (beginning-of-buffer-p mark)
+ do (beginning-of-line mark)
+ until (beginning-of-buffer-p mark)
+ do (backward-object mark)))
+ ((or whole-lines-p (> count 1))
+ (loop repeat count
+ until (end-of-buffer-p mark)
+ do (end-of-line mark)
+ until (end-of-buffer-p mark)
+ do (forward-object mark)))
+ (t
+ (cond ((end-of-buffer-p mark) nil)
+ ((end-of-line-p mark)(forward-object mark))
+ (t (end-of-line mark)))))
+ (unless (mark= mark start)
+ (if concatenate-p
+ (kill-ring-concatenating-push *kill-ring*
+ (region-to-sequence start mark))
+ (kill-ring-standard-push *kill-ring*
+ (region-to-sequence start mark)))
+ (delete-region start mark))))
+
(define-named-command com-kill-line ((numarg 'integer :prompt "Kill how many lines?")
(numargp 'boolean :prompt "Kill entire lines?"))
(let* ((pane (current-window))
(point (point pane))
- (mark (offset point)))
- (cond ((= 0 numarg)
- (beginning-of-line point))
- ((< numarg 0)
- (loop repeat (- numarg)
- until (beginning-of-buffer-p point)
- do (beginning-of-line point)
- until (beginning-of-buffer-p point)
- do (backward-object point)))
- ((or numargp (> numarg 1))
- (loop repeat numarg
- until (end-of-buffer-p point)
- do (end-of-line point)
- until (end-of-buffer-p point)
- do (forward-object point)))
- (t
- (cond ((end-of-buffer-p point) nil)
- ((end-of-line-p point)(forward-object point))
- (t (end-of-line point)))))
- (unless (mark= point mark)
- (if (eq (previous-command pane) 'com-kill-line)
- (kill-ring-concatenating-push *kill-ring*
- (region-to-sequence mark point))
- (kill-ring-standard-push *kill-ring*
- (region-to-sequence mark point)))
- (delete-region mark point))))
+ (concatenate-p (eq (previous-command pane) 'com-kill-line)))
+ (kill-line point numarg numargp concatenate-p)))
(define-named-command com-forward-word ((count 'integer :prompt "Number of words"))
(if (plusp count)
@@ -407,35 +420,37 @@
(define-named-command com-delete-word ((count 'integer :prompt "Number of words"))
(delete-word (point (current-window)) count))
+(defun kill-word (mark &optional (count 1) (concatenate-p nil))
+ (let ((start (offset mark)))
+ (if (plusp count)
+ (loop repeat count
+ until (end-of-buffer-p mark)
+ do (forward-word mark))
+ (loop repeat (- count)
+ until (beginning-of-buffer-p mark)
+ do (backward-word mark)))
+ (unless (mark= mark start)
+ (if concatenate-p
+ (if (plusp count)
+ (kill-ring-concatenating-push *kill-ring*
+ (region-to-sequence start mark))
+ (kill-ring-reverse-concatenating-push *kill-ring*
+ (region-to-sequence start mark)))
+ (kill-ring-standard-push *kill-ring*
+ (region-to-sequence start mark)))
+ (delete-region start mark))))
+
(define-named-command com-kill-word ((count 'integer :prompt "Number of words"))
(let* ((pane (current-window))
(point (point pane))
- (mark (offset point)))
- (loop repeat count
- until (end-of-buffer-p point)
- do (forward-word point))
- (unless (mark= point mark)
- (if (eq (previous-command pane) 'com-kill-word)
- (kill-ring-concatenating-push *kill-ring*
- (region-to-sequence mark point))
- (kill-ring-standard-push *kill-ring*
- (region-to-sequence mark point)))
- (delete-region mark point))))
+ (concatenate-p (eq (previous-command pane) 'com-kill-word)))
+ (kill-word point count concatenate-p)))
(define-named-command com-backward-kill-word ((count 'integer :prompt "Number of words"))
(let* ((pane (current-window))
(point (point pane))
- (mark (offset point)))
- (loop repeat count
- until (end-of-buffer-p point)
- do (backward-word point))
- (unless (mark= point mark)
- (if (eq (previous-command pane) 'com-backward-kill-word)
- (kill-ring-reverse-concatenating-push *kill-ring*
- (region-to-sequence mark point))
- (kill-ring-standard-push *kill-ring*
- (region-to-sequence mark point)))
- (delete-region mark point))))
+ (concatenate-p (eq (previous-command pane) 'com-backward-kill-word)))
+ (kill-word point (- count) concatenate-p)))
(define-named-command com-mark-word ((count 'integer :prompt "Number of words"))
(let* ((pane (current-window))
@@ -546,18 +561,18 @@
(full-so-far (concatenate 'string directory-prefix so-far))
(pathnames
(loop with length = (length full-so-far)
- and wildcard = (concatenate 'string (remove-trail so-far) "*.*")
- for path in
- #+(or sbcl cmu lispworks) (directory wildcard)
- #+openmcl (directory wildcard :directories t)
- #+allegro (directory wildcard :directories-are-files nil)
- #+cormanlisp (nconc (directory wildcard)
+ and wildcard = (concatenate 'string (remove-trail so-far) "*.*")
+ for path in
+ #+(or sbcl cmu lispworks) (directory wildcard)
+ #+openmcl (directory wildcard :directories t)
+ #+allegro (directory wildcard :directories-are-files nil)
+ #+cormanlisp (nconc (directory wildcard)
(cl::directory-subdirs dirname))
- #-(or sbcl cmu lispworks openmcl allegro cormanlisp)
- (directory wildcard)
- when (let ((mismatch (mismatch (namestring path) full-so-far)))
- (or (null mismatch) (= mismatch length)))
- collect path))
+ #-(or sbcl cmu lispworks openmcl allegro cormanlisp)
+ (directory wildcard)
+ when (let ((mismatch (mismatch (namestring path) full-so-far)))
+ (or (null mismatch) (= mismatch length)))
+ collect path))
(strings (mapcar #'namestring pathnames))
(first-string (car strings))
(length-common-prefix nil)
@@ -607,9 +622,13 @@
(complete-input stream
#'filename-completer
:allow-any-input t)
- (declare (ignore success))
- (or pathname string)))
+; (declare (ignore success))
+; (or pathname string)))
+ (if success
+ (values pathname 'pathname)
+ (values string 'string))))
+
(defun filepath-filename (pathname)
(if (null (pathname-type pathname))
(pathname-name pathname)
@@ -622,33 +641,44 @@
(pathname-name filepath))
climacs-syntax::*syntaxes*
:test (lambda (x y)
- (member x y :test #'string=))
+ (member x y :test #'string-equal))
:key #'climacs-syntax::syntax-description-pathname-types))
'basic-syntax))
+;; 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)))))
+
(define-named-command com-find-file ()
(let ((filepath (accept 'completable-pathname
- :prompt "Find File"))
- (buffer (make-instance 'climacs-buffer))
- (pane (current-window)))
- (setf (offset (point (buffer pane))) (offset (point pane)))
- (push buffer (buffers *application-frame*))
- (setf (buffer (current-window)) buffer)
- (setf (syntax buffer)
- (make-instance
- (syntax-class-name-for-filepath filepath)
- :buffer (buffer (point pane))))
- ;; 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 (filepath buffer) filepath
- (name buffer) (filepath-filename filepath)
- (needs-saving buffer) nil)
- (beginning-of-buffer (point pane))
- ;; this one is needed so that the buffer modification protocol
- ;; resets the low and high marks after redisplay
- (redisplay-frame-panes *application-frame*)))
+ :prompt "Find File")))
+ (cond ((directory-pathname-p filepath)
+ (display-message "~A is a directory name." filepath)
+ (beep))
+ (t
+ (let ((buffer (make-instance 'climacs-buffer))
+ (pane (current-window)))
+ (setf (offset (point (buffer pane))) (offset (point pane)))
+ (push buffer (buffers *application-frame*))
+ (setf (buffer (current-window)) buffer)
+ (setf (syntax buffer)
+ (make-instance (syntax-class-name-for-filepath filepath)
+ :buffer (buffer (point pane))))
+ ;; 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 (filepath buffer) filepath
+ (name buffer) (filepath-filename filepath)
+ (needs-saving buffer) nil)
+ (beginning-of-buffer (point pane))
+ ;; this one is needed so that the buffer modification protocol
+ ;; resets the low and high marks after redisplay
+ (redisplay-frame-panes *application-frame*))))))
(define-named-command com-insert-file ()
(let ((filename (accept 'completable-pathname
@@ -668,12 +698,17 @@
(let ((filepath (or (filepath buffer)
(accept 'completable-pathname
:prompt "Save Buffer to File"))))
- (with-open-file (stream filepath :direction :output :if-exists :supersede)
- (output-to-stream stream buffer 0 (size buffer)))
- (setf (filepath buffer) filepath
- (name buffer) (filepath-filename filepath))
- (display-message "Wrote: ~a" (filepath buffer))
- (setf (needs-saving buffer) nil)))
+ (cond
+ ((directory-pathname-p filepath)
+ (display-message "~A is a directory." filepath)
+ (beep))
+ (t
+ (with-open-file (stream filepath :direction :output :if-exists :supersede)
+ (output-to-stream stream buffer 0 (size buffer)))
+ (setf (filepath buffer) filepath
+ (name buffer) (filepath-filename filepath))
+ (display-message "Wrote: ~a" (filepath buffer))
+ (setf (needs-saving buffer) nil)))))
(define-named-command com-save-buffer ()
(let ((buffer (buffer (current-window))))
@@ -704,12 +739,16 @@
(let ((filepath (accept 'completable-pathname
:prompt "Write Buffer to File"))
(buffer (buffer (current-window))))
- (with-open-file (stream filepath :direction :output :if-exists :supersede)
- (output-to-stream stream buffer 0 (size buffer)))
- (setf (filepath buffer) filepath
- (name buffer) (filepath-filename filepath)
- (needs-saving buffer) nil)
- (display-message "Wrote: ~a" (filepath buffer))))
+ (cond
+ ((directory-pathname-p filepath)
+ (display-message "~A is a directory name." filepath))
+ (t
+ (with-open-file (stream filepath :direction :output :if-exists :supersede)
+ (output-to-stream stream buffer 0 (size buffer)))
+ (setf (filepath buffer) filepath
+ (name buffer) (filepath-filename filepath)
+ (needs-saving buffer) nil)
+ (display-message "Wrote: ~a" (filepath buffer))))))
(define-presentation-method accept
((type buffer) stream (view textual-view) &key)
@@ -723,41 +762,82 @@
:partial-completers '(#\Space)
:allow-any-input t)
(declare (ignore success))
- (or object
- (car (push (make-instance 'climacs-buffer :name string)
- (buffers *application-frame*))))))
+ (or object string)))
-(define-named-command com-switch-to-buffer ()
- (let ((buffer (accept 'buffer
- :prompt "Switch to buffer"))
- (pane (current-window)))
+(defgeneric switch-to-buffer (buffer))
+
+(defmethod switch-to-buffer ((buffer climacs-buffer))
+ (let* ((buffers (buffers *application-frame*))
+ (position (position buffer buffers))
+ (pane (current-window)))
+ (if position
+ (rotatef (car buffers) (nth position buffers))
+ (push buffer buffers))
(setf (offset (point (buffer pane))) (offset (point pane)))
(setf (buffer pane) buffer)
(full-redisplay pane)))
-(define-named-command com-kill-buffer ()
+(defmethod switch-to-buffer ((name string))
+ (let ((buffer (find name (buffers *application-frame*)
+ :key #'name :test #'string=)))
+ (switch-to-buffer (or buffer
+ (make-instance 'climacs-buffer :name name)))))
+
+;;placeholder
+(defmethod switch-to-buffer ((symbol (eql 'nil)))
+ (switch-to-buffer (second (buffers *application-frame*))))
+
+(define-named-command com-switch-to-buffer ()
+ (let ((buffer (accept 'buffer
+ :prompt "Switch to buffer")))
+ (switch-to-buffer buffer)))
+
+(defgeneric kill-buffer (buffer))
+
+(defmethod kill-buffer ((buffer climacs-buffer))
(with-slots (buffers) *application-frame*
- (let ((buffer (buffer (current-window))))
- (when (and (needs-saving buffer)
- (handler-case (accept 'boolean :prompt "Save buffer first?")
- (error () (progn (beep)
- (display-message "Invalid answer")
- (return-from com-kill-buffer nil)))))
- (com-save-buffer))
- (setf buffers (remove buffer buffers))
- ;; Always need one buffer.
- (when (null buffers)
- (push (make-instance 'climacs-buffer :name "*scratch*")
- buffers))
- (setf (buffer (current-window)) (car buffers)))))
+ (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)
+ (push (make-instance 'climacs-buffer :name "*scratch*")
+ buffers))
+ (setf (buffer (current-window)) (car buffers))))
+
+(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-named-command com-kill-buffer ()
+ (kill-buffer (buffer (current-window))))
(define-named-command com-full-redisplay ()
(full-redisplay (current-window)))
+(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-named-command com-load-file ()
(let ((filepath (accept 'completable-pathname
:prompt "Load File")))
- (load filepath)))
+ (load-file filepath)))
(define-named-command com-beginning-of-buffer ()
(beginning-of-buffer (point (current-window))))
@@ -777,65 +857,76 @@
(beginning-of-buffer (point (current-window)))
(end-of-buffer (mark (current-window))))
+(defun back-to-indentation (mark)
+ (beginning-of-line mark)
+ (loop until (end-of-line-p mark)
+ while (whitespacep (object-after mark))
+ do (forward-object mark)))
+
(define-named-command com-back-to-indentation ()
- (let ((point (point (current-window))))
- (beginning-of-line point)
- (loop until (end-of-line-p point)
- while (whitespacep (object-after point))
- do (incf (offset point)))))
+ (back-to-indentation (point (current-window))))
+
+(defun delete-horizontal-space (mark &optional (backward-only-p nil))
+ (let ((mark2 (clone-mark mark)))
+ (loop until (beginning-of-line-p mark)
+ while (whitespacep (object-before mark))
+ do (backward-object mark))
+ (unless backward-only-p
+ (loop until (end-of-line-p mark2)
+ while (whitespacep (object-after mark2))
+ do (forward-object mark2)))
+ (delete-region mark mark2)))
(define-named-command com-delete-horizontal-space ((backward-only-p
'boolean :prompt "Delete backwards only?"))
- (let* ((point (point (current-window)))
- (mark (clone-mark point)))
- (loop until (beginning-of-line-p point)
- while (whitespacep (object-before point))
- do (backward-object point))
- (unless backward-only-p
- (loop until (end-of-line-p mark)
- while (whitespacep (object-after mark))
- do (forward-object mark)))
- (delete-region point mark)))
+ (delete-horizontal-space (point (current-window)) backward-only-p))
+
+(defun just-one-space (mark count)
+ (let (offset)
+ (loop until (beginning-of-line-p mark)
+ while (whitespacep (object-before mark))
+ do (backward-object mark))
+ (loop until (end-of-line-p mark)
+ while (whitespacep (object-after mark))
+ repeat count do (forward-object mark)
+ finally (setf offset (offset mark)))
+ (loop until (end-of-line-p mark)
+ while (whitespacep (object-after mark))
+ do (forward-object mark))
+ (delete-region offset mark)))
(define-named-command com-just-one-space ((count 'integer :prompt "Number of spaces"))
- (let ((point (point (current-window)))
- offset)
- (loop until (beginning-of-line-p point)
- while (whitespacep (object-before point))
- do (backward-object point))
- (loop until (end-of-line-p point)
- while (whitespacep (object-after point))
- repeat count do (forward-object point)
- finally (setf offset (offset point)))
- (loop until (end-of-line-p point)
- while (whitespacep (object-after point))
- do (forward-object point))
- (delete-region offset point)))
+ (just-one-space (point (current-window)) count))
+
+(defun goto-position (mark pos)
+ (setf (offset mark) pos))
(define-named-command com-goto-position ()
- (setf (offset (point (current-window)))
- (handler-case (accept 'integer :prompt "Goto Position")
- (error () (progn (beep)
- (display-message "Not a valid position")
- (return-from com-goto-position nil))))))
+ (goto-position
+ (point (current-window))
+ (handler-case (accept 'integer :prompt "Goto Position")
+ (error () (progn (beep)
+ (display-message "Not a valid position")
+ (return-from com-goto-position nil))))))
+
+(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-named-command com-goto-line ()
- (loop with mark = (let ((m (clone-mark
- (low-mark (buffer (current-window)))
- :right)))
- (beginning-of-buffer m)
- m)
- do (end-of-line mark)
- until (end-of-buffer-p mark)
- repeat (1- (handler-case (accept 'integer :prompt "Goto Line")
+ (goto-line (point (current-window))
+ (handler-case (accept 'integer :prompt "Goto Line")
(error () (progn (beep)
(display-message "Not a valid line number")
- (return-from com-goto-line nil)))))
- do (incf (offset mark))
- (end-of-line mark)
- finally (beginning-of-line mark)
- (setf (offset (point (current-window)))
- (offset mark))))
+ (return-from com-goto-line nil))))))
(define-named-command com-browse-url ()
(let ((url (accept 'url :prompt "Browse URL")))
@@ -851,15 +942,28 @@
(psetf (offset (mark pane)) (offset (point pane))
(offset (point pane)) (offset (mark pane)))))
+(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-named-command com-set-syntax ()
(let* ((pane (current-window))
(buffer (buffer pane)))
- (setf (syntax buffer)
- (make-instance (or (accept 'syntax :prompt "Set Syntax")
- (progn (beep)
- (display-message "No such syntax")
- (return-from com-set-syntax nil)))
- :buffer (buffer (point pane))))))
+ (set-syntax buffer (accept 'syntax :prompt "Set Syntax"))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -897,7 +1001,7 @@
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."
+If *with-scrollbars* nil, omit the scroller."
(let* ((extended-pane
(make-pane 'extended-pane
@@ -918,11 +1022,11 @@
:width 900))))
(values vbox extended-pane)))
-(define-named-command com-split-window-vertically ()
+(defun split-window-vertically (&optional (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 (current-window))
+ (let* ((current-window pane)
(constellation-root (if *with-scrollbars*
(parent3 current-window)
(sheet-parent current-window))))
@@ -934,13 +1038,17 @@
(setf *standard-output* new-pane)
(replace-constellation constellation-root vbox t)
(full-redisplay current-window)
- (full-redisplay new-pane)))))
+ (full-redisplay new-pane)
+ new-pane))))
-(define-named-command com-split-window-horizontally ()
+(define-named-command com-split-window-vertically ()
+ (split-window-vertically))
+
+(defun split-window-horizontally (&optional (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 (current-window))
+ (let* ((current-window pane)
(constellation-root (if *with-scrollbars*
(parent3 current-window)
(sheet-parent current-window))))
@@ -952,21 +1060,31 @@
(setf *standard-output* new-pane)
(replace-constellation constellation-root vbox nil)
(full-redisplay current-window)
- (full-redisplay new-pane)))))
+ (full-redisplay new-pane)
+ new-pane))))
-(define-named-command com-other-window ()
+(define-named-command com-split-window-horizontally ()
+ (split-window-horizontally))
+
+(defun other-window ()
(setf (windows *application-frame*)
(append (cdr (windows *application-frame*))
(list (car (windows *application-frame*)))))
(setf *standard-output* (car (windows *application-frame*))))
-(define-named-command com-single-window ()
+(define-named-command com-other-window ()
+ (other-window))
+
+(defun single-window ()
(loop until (null (cdr (windows *application-frame*)))
do (rotatef (car (windows *application-frame*))
(cadr (windows *application-frame*)))
(com-delete-window))
(setf *standard-output* (car (windows *application-frame*))))
+(define-named-command com-single-window ()
+ (single-window))
+
(define-named-command com-scroll-other-window ()
(let ((other-window (second (windows *application-frame*))))
(when other-window
@@ -977,11 +1095,11 @@
(when other-window
(page-up other-window))))
-(define-named-command com-delete-window ()
+(defun delete-window (&optional (window (current-window)))
(unless (null (cdr (windows *application-frame*)))
(let* ((constellation (if *with-scrollbars*
- (parent3 (current-window))
- (sheet-parent (current-window))))
+ (parent3 window)
+ (sheet-parent window)))
(box (sheet-parent constellation))
(box-children (sheet-children box))
(other (if (eq constellation (first box-children))
@@ -992,7 +1110,8 @@
(first (first children))
(second (second children))
(third (third children)))
- (pop (windows *application-frame*))
+ (setf (windows *application-frame*)
+ (remove window (windows *application-frame*)))
(setf *standard-output* (car (windows *application-frame*)))
(sheet-disown-child box other)
(sheet-disown-child parent box)
@@ -1005,6 +1124,9 @@
(list first second other)
(list first other)))))))
+(define-named-command com-delete-window ()
+ (delete-window))
+
;;;;;;;;;;;;;;;;;;;;
;; Kill ring commands
@@ -1019,7 +1141,7 @@
*kill-ring* (region-to-sequence (mark pane) (point pane)))
(delete-region (mark pane) (point pane))))
-;; Non destructively copies in buffer region to the kill ring
+;; Non destructively copies buffer region to the kill ring
(define-named-command com-copy-region ()
(let ((pane (current-window)))
(kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane)))))
@@ -1049,6 +1171,8 @@
;;;
;;; Incremental search
+(make-command-table 'isearch-climacs-table :errorp nil)
+
(defun isearch-command-loop (pane forwardp)
(let ((point (point pane)))
(unless (endp (isearch-states pane))
@@ -1092,15 +1216,15 @@
(unless success
(beep)))))
-(define-named-command com-isearch-mode-forward ()
+(define-named-command com-isearch-forward ()
(display-message "Isearch: ")
(isearch-command-loop (current-window) t))
-(define-named-command com-isearch-mode-backward ()
+(define-named-command com-isearch-backward ()
(display-message "Isearch backward: ")
(isearch-command-loop (current-window) nil))
-(define-named-command com-isearch-append-char ()
+(define-command (com-append-char :name t :command-table isearch-climacs-table) ()
(let* ((pane (current-window))
(states (isearch-states pane))
(string (concatenate 'string
@@ -1112,7 +1236,7 @@
(incf (offset mark)))
(isearch-from-mark pane mark string forwardp)))
-(define-named-command com-isearch-delete-char ()
+(define-command (com-delete-char :name t :command-table isearch-climacs-table) ()
(let* ((pane (current-window)))
(cond ((null (second (isearch-states pane)))
(display-message "Isearch: ")
@@ -1133,7 +1257,7 @@
(search-forward-p state)
(search-string state)))))))
-(define-named-command com-isearch-forward ()
+(define-command (com-forward :name t :command-table isearch-climacs-table) ()
(let* ((pane (current-window))
(point (point pane))
(states (isearch-states pane))
@@ -1143,7 +1267,7 @@
(mark (clone-mark point)))
(isearch-from-mark pane mark string t)))
-(define-named-command com-isearch-backward ()
+(define-command (com-backward :name t :command-table isearch-climacs-table) ()
(let* ((pane (current-window))
(point (point pane))
(states (isearch-states pane))
@@ -1153,13 +1277,27 @@
(mark (clone-mark point)))
(isearch-from-mark pane mark string nil)))
-(define-named-command com-isearch-exit ()
+(define-command (com-exit :name t :command-table isearch-climacs-table) ()
(setf (isearch-mode (current-window)) nil))
+(defun isearch-set-key (gesture command)
+ (add-command-to-command-table command 'isearch-climacs-table
+ :keystroke gesture :errorp nil))
+
+(loop for code from (char-code #\Space) to (char-code #\~)
+ do (isearch-set-key (code-char code) 'com-append-char))
+
+(isearch-set-key '(#\Newline) 'com-exit)
+(isearch-set-key '(#\Backspace) 'com-delete-char)
+(isearch-set-key '(#\s :control) 'com-forward)
+(isearch-set-key '(#\r :control) 'com-backward)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Query replace
+(make-command-table 'query-replace-climacs-table :errorp nil)
+
(defun query-replace-find-next-match (mark string)
(flet ((object-equal (x y)
(and (characterp x)
@@ -1211,7 +1349,7 @@
((setf (query-replace-mode pane) nil))))
(display-message "Replaced ~A occurrence~:P" occurrences)))
-(define-named-command com-query-replace-replace ()
+(define-command (com-replace :name t :command-table query-replace-climacs-table) ()
(declare (special string1 string2 occurrences))
(let* ((pane (current-window))
(point (point pane))
@@ -1235,7 +1373,7 @@
string1 string2)
(setf (query-replace-mode pane) nil))))
-(define-named-command com-query-replace-skip ()
+(define-command (com-skip :name t :command-table query-replace-climacs-table) ()
(declare (special string1 string2))
(let* ((pane (current-window))
(point (point pane)))
@@ -1244,9 +1382,21 @@
string1 string2)
(setf (query-replace-mode pane) nil))))
-(define-named-command com-query-replace-exit ()
+(define-command (com-exit :name t :command-table query-replace-climacs-table) ()
(setf (query-replace-mode (current-window)) nil))
+(defun query-replace-set-key (gesture command)
+ (add-command-to-command-table command 'query-replace-climacs-table
+ :keystroke gesture :errorp nil))
+
+(query-replace-set-key '(#\Newline) 'com-exit)
+(query-replace-set-key '(#\Space) 'com-replace)
+(query-replace-set-key '(#\Backspace) 'com-skip)
+(query-replace-set-key '(#\Rubout) 'com-skip)
+(query-replace-set-key '(#\q) 'com-exit)
+(query-replace-set-key '(#\y) 'com-replace)
+(query-replace-set-key '(#\n) 'com-skip)
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Undo/redo
@@ -1301,7 +1451,8 @@
(region-to-sequence offset dabbrev-expansion-mark)
(setf (offset dabbrev-expansion-mark) offset))))
(move))))))))
-
+
+
(define-named-command com-backward-paragraph ((count 'integer :prompt "Number of paragraphs"))
(let* ((pane (current-window))
(point (point pane))
@@ -1448,11 +1599,12 @@
(error () (progn (beep)
(display-message "Empty string")
(return-from com-eval-expression nil)))))
- (result (format nil "~a"
- (handler-case (eval (read-from-string string))
- (error (condition) (progn (beep)
- (display-message "~a" condition)
- (return-from com-eval-expression nil)))))))
+ (values (multiple-value-list
+ (handler-case (eval (read-from-string string))
+ (error (condition) (progn (beep)
+ (display-message "~a" condition)
+ (return-from com-eval-expression nil))))))
+ (result (format nil "~:[; No values~;~:*~{~S~^,~}~]" values)))
(if insertp
(insert-sequence (point (current-window)) result)
(display-message result))))
@@ -1469,21 +1621,6 @@
(syntax (syntax (buffer pane))))
(comment-region syntax point mark)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; For testing purposes
-
-(define-named-command com-reset-profile ()
- #+sbcl (sb-profile:reset)
- #-sbcl nil)
-
-(define-named-command com-report-profile ()
- #+sbcl (sb-profile:report)
- #-sbcl nil)
-
-(define-named-command com-recompile ()
- (asdf:operate 'asdf:load-op :climacs))
-
(define-named-command com-backward-expression ((count 'integer :prompt "Number of expressions"))
(let* ((pane (current-window))
(point (point pane))
@@ -1620,6 +1757,22 @@
(package (climacs-lisp-syntax::package-of syntax)))
(display-message (format nil "~s" package))))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
+;;; For testing purposes
+
+(define-named-command com-reset-profile ()
+ #+sbcl (sb-profile:reset)
+ #-sbcl nil)
+
+(define-named-command com-report-profile ()
+ #+sbcl (sb-profile:report)
+ #-sbcl nil)
+
+(define-named-command com-recompile ()
+ (asdf:operate 'asdf:load-op :climacs))
+
+
(define-gesture-name :select-other :pointer-button-press (:left :meta) :unique nil)
(define-presentation-translator lisp-string-to-string
@@ -1719,8 +1872,8 @@
(global-set-key '(#\{ :meta :shift) `(com-backward-paragraph ,*numeric-argument-marker*))
(global-set-key '(#\} :meta :shift) `(com-forward-paragraph ,*numeric-argument-marker*))
(global-set-key '(#\h :meta) `(com-mark-paragraph ,*numeric-argument-marker*))
-(global-set-key '(#\s :control) 'com-isearch-mode-forward)
-(global-set-key '(#\r :control) 'com-isearch-mode-backward)
+(global-set-key '(#\s :control) 'com-isearch-forward)
+(global-set-key '(#\r :control) 'com-isearch-backward)
(global-set-key '(#\_ :shift :meta) 'com-redo)
(global-set-key '(#\_ :shift :control) 'com-undo)
(global-set-key '(#\% :shift :meta) 'com-query-replace)
@@ -1952,41 +2105,6 @@
(dead-circumflex-set-key '(#\u) '(com-insert-charcode 251))
(dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Isearch command table
-
-(make-command-table 'isearch-climacs-table :errorp nil)
-
-(defun isearch-set-key (gesture command)
- (add-command-to-command-table command 'isearch-climacs-table
- :keystroke gesture :errorp nil))
-
-(loop for code from (char-code #\Space) to (char-code #\~)
- do (isearch-set-key (code-char code) 'com-isearch-append-char))
-
-(isearch-set-key '(#\Newline) 'com-isearch-exit)
-(isearch-set-key '(#\Backspace) 'com-isearch-delete-char)
-(isearch-set-key '(#\s :control) 'com-isearch-forward)
-(isearch-set-key '(#\r :control) 'com-isearch-backward)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;;
-;;; Query replace command table
-
-(make-command-table 'query-replace-climacs-table :errorp nil)
-
-(defun query-replace-set-key (gesture command)
- (add-command-to-command-table command 'query-replace-climacs-table
- :keystroke gesture :errorp nil))
-
-(query-replace-set-key '(#\Newline) 'com-query-replace-exit)
-(query-replace-set-key '(#\Space) 'com-query-replace-replace)
-(query-replace-set-key '(#\Backspace) 'com-query-replace-skip)
-(query-replace-set-key '(#\Rubout) 'com-query-replace-skip)
-(query-replace-set-key '(#\q) 'com-query-replace-exit)
-(query-replace-set-key '(#\y) 'com-query-replace-replace)
-(query-replace-set-key '(#\n) 'com-query-replace-skip)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -2002,3 +2120,4 @@
(add-command-to-command-table command 'c-c-climacs-table
:keystroke gesture :errorp nil))
+(c-c-set-key '(#\l :control) 'com-load-file)
More information about the Climacs-cvs
mailing list