climacs-cvs

climacs-cvs@common-lisp.net

847 discussions

[climacs-cvs] CVS update: climacs/base.lisp climacs/gui.lisp climacs/packages.lisp climacs/pane.lisp
by mvilleneuve＠common-lisp.net 19 Jan '05

19 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12217 Modified Files: base.lisp gui.lisp packages.lisp pane.lisp Log Message: Added auto-fill mode Date: Wed Jan 19 12:04:39 2005 Author: mvilleneuve Index: climacs/base.lisp diff -u climacs/base.lisp:1.21 climacs/base.lisp:1.22 --- climacs/base.lisp:1.21 Tue Jan 18 10:59:51 2005 +++ climacs/base.lisp Wed Jan 19 12:04:39 2005 @@ -114,7 +114,7 @@ count (eql (buffer-object buffer offset1) #\Newline) do (incf offset1))) -(defun buffer-display-column-number (buffer offset tab-width) +(defun buffer-display-column (buffer offset tab-width) (let ((line-start-offset (- offset (buffer-column-number buffer offset)))) (loop with column = 0 for i from line-start-offset below offset @@ -308,7 +308,7 @@ finally (return t)))) (loop for offset = offset1 then (1+ offset) until (>= offset offset2) - do (let* ((column (buffer-display-column-number + do (let* ((column (buffer-display-column buffer offset tab-width)) (count (- tab-width (mod column tab-width)))) (when (looking-at-spaces buffer offset count) @@ -336,8 +336,9 @@ (loop for offset = offset1 then (1+ offset) until (>= offset offset2) when (char= (buffer-object buffer offset) #\Tab) - do (let* ((column (buffer-display-column-number - buffer offset tab-width)) + do (let* ((column (buffer-display-column buffer + offset + tab-width)) (count (- tab-width (mod column tab-width)))) (delete-buffer-range buffer offset 1) (loop repeat count @@ -391,6 +392,37 @@ while (whitespacep (object-before mark)) do (delete-range mark -1)) (insert-object mark #\Space))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Auto fill + +(defun fill-line (mark syntax-line-indentation-function fill-column tab-width) + (let ((begin-mark (clone-mark mark))) + (beginning-of-line begin-mark) + (loop with column = 0 + 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 (>= column fill-column) + (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 (offset walking-mark) (offset begin-mark)) + (setf column 0)) + (incf (offset walking-mark))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.85 climacs/gui.lisp:1.86 --- climacs/gui.lisp:1.85 Wed Jan 19 06:38:47 2005 +++ climacs/gui.lisp Wed Jan 19 12:04:39 2005 @@ -109,13 +109,16 @@ (declare (ignore frame)) (with-slots (climacs-pane) pane (let* ((buf (buffer climacs-pane)) - (name-info (format nil " ~a ~a Syntax: ~a ~a ~a" + (name-info (format nil " ~a ~a Syntax: ~a~a~a ~a" (if (needs-saving buf) "**" "--") (name buf) (name (syntax buf)) (if (slot-value climacs-pane 'overwrite-mode) - "Ovwrt" + " Ovwrt" "") + (if (auto-fill-mode buf) + " Fill" + "") (if (recordingp *application-frame*) "Def" "")))) @@ -285,16 +288,37 @@ (setf (slot-value win 'overwrite-mode) (not (slot-value win 'overwrite-mode))))) -(define-command com-self-insert () +(defun insert-character (char) (let* ((win (current-window)) (point (point win))) - (unless (constituentp *current-gesture*) + (unless (constituentp char) (possibly-expand-abbrev point)) (if (and (slot-value win 'overwrite-mode) (not (end-of-line-p point))) (progn (delete-range point) - (insert-object point *current-gesture*)) - (insert-object point *current-gesture*)))) + (insert-object point char)) + (insert-object point char)))) + +(define-command com-self-insert () + (insert-character *current-gesture*)) + +(define-command com-self-filling-insert () + (let* ((pane (current-window)) + (buffer (buffer pane))) + (when (auto-fill-mode buffer) + (let* ((fill-column (auto-fill-column buffer)) + (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- (auto-fill-column buffer))) + (fill-line point + (lambda (mark) + (syntax-line-indentation mark tab-width syntax)) + fill-column + tab-width))))) + (insert-character *current-gesture*)) (define-named-command com-beginning-of-line () (beginning-of-line (point (current-window)))) @@ -475,6 +499,10 @@ (define-named-command com-delete-indentation () (delete-indentation (point (current-window)))) +(define-named-command com-auto-fill-mode () + (let ((buffer (buffer (current-window)))) + (setf (auto-fill-mode buffer) (not (auto-fill-mode buffer))))) + (define-command com-extended-command () (let ((item (accept 'command :prompt "Extended Command"))) (execute-frame-command *application-frame* item))) @@ -938,11 +966,12 @@ (find :meta gesture)) (dead-escape-set-key (remove :meta gesture) command))) -(loop for code from (char-code #\space) to (char-code #\~) +(loop for code from (char-code #\!) to (char-code #\~) do (global-set-key (code-char code) 'com-self-insert)) -(global-set-key #\newline 'com-self-insert) -(global-set-key #\tab 'com-indent-line) +(global-set-key #\Space 'com-self-filling-insert) +(global-set-key #\Newline 'com-self-filling-insert) +(global-set-key #\Tab 'com-indent-line) (global-set-key '(#\j :control) 'com-newline-and-indent) (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*)) (global-set-key '(#\b :control) `(com-backward-object ,*numeric-argument-marker*)) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.35 climacs/packages.lisp:1.36 --- climacs/packages.lisp:1.35 Mon Jan 17 15:10:24 2005 +++ climacs/packages.lisp Wed Jan 19 12:04:39 2005 @@ -51,6 +51,7 @@ #:open-line #:kill-line #:empty-line-p #:line-indentation + #:buffer-display-column #:number-of-lines-in-region #:constituentp #:whitespacep #:forward-word #:backward-word @@ -60,6 +61,7 @@ #:tabify-region #:untabify-region #:indent-line #:delete-indentation + #:fill-line #:input-from-stream #:output-to-stream #:name-mixin #:name #:buffer-lookin-at #:looking-at @@ -95,6 +97,7 @@ #:page-down #:page-up #:tab-space-count #:indent-tabs-mode + #:auto-fill-mode #:auto-fill-column #:url)) (defpackage :climacs-gui Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.6 climacs/pane.lisp:1.7 --- climacs/pane.lisp:1.6 Tue Jan 18 21:21:16 2005 +++ climacs/pane.lisp Wed Jan 19 12:04:39 2005 @@ -58,7 +58,9 @@ ((needs-saving :initform nil :accessor needs-saving) (syntax :initarg :syntax :initform (make-instance 'basic-syntax) :accessor syntax) (indent-tabs-mode :initarg indent-tabs-mode :initform t - :accessor indent-tabs-mode)) + :accessor indent-tabs-mode) + (auto-fill-mode :initform t :accessor auto-fill-mode) + (auto-fill-column :initform 70 :accessor auto-fill-column)) (:default-initargs :name "*scratch*"))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 19 Jan '05

19 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27404 Modified Files: gui.lisp Log Message: Implemented keyboard macros, except that there is a bug that do not have time to track down right now, leaving an extra 'e' in the buffer. Date: Wed Jan 19 06:38:48 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.84 climacs/gui.lisp:1.85 --- climacs/gui.lisp:1.84 Tue Jan 18 21:28:38 2005 +++ climacs/gui.lisp Wed Jan 19 06:38:47 2005 @@ -50,7 +50,11 @@ (define-application-frame climacs () ((windows :accessor windows) - (buffers :initform '() :accessor buffers)) + (buffers :initform '() :accessor buffers) + (recordingp :initform nil :accessor recordingp) + (executingp :initform nil :accessor executingp) + (recorded-keys :initform '() :accessor recorded-keys) + (remaining-keys :initform '() :accessor remaining-keys)) (:panes (win (let* ((extended-pane (make-pane 'extended-pane @@ -105,12 +109,15 @@ (declare (ignore frame)) (with-slots (climacs-pane) pane (let* ((buf (buffer climacs-pane)) - (name-info (format nil " ~a ~a Syntax: ~a ~a" + (name-info (format nil " ~a ~a Syntax: ~a ~a ~a" (if (needs-saving buf) "**" "--") (name buf) (name (syntax buf)) (if (slot-value climacs-pane 'overwrite-mode) "Ovwrt" + "") + (if (recordingp *application-frame*) + "Def" "")))) (princ name-info pane)))) @@ -139,8 +146,11 @@ :test #'event-matches-gesture-name-p)) (defun climacs-read-gesture () + (unless (null (remaining-keys *application-frame*)) + (return-from climacs-read-gesture + (pop (remaining-keys *application-frame*)))) (loop for gesture = (read-gesture :stream *standard-input*) - when (event-matches-gesture-name-p gesture '(#\g :control)) + when (event-matches-gesture-name-p gesture '(:keyboard #\g 512)) ; FIXME do (throw 'outer-loop nil) until (or (characterp gesture) (and (typep gesture 'keyboard-event) @@ -154,7 +164,16 @@ :hyper-left :hyper-right :shift-lock :caps-lock :alt-left :alt-right)))))) - finally (return gesture))) + finally (progn (when (recordingp *application-frame*) + (push gesture (recorded-keys *application-frame*))) + (return gesture)))) + +(defun climacs-unread-gesture (gesture stream) + (cond ((recordingp *application-frame*) + (pop (recorded-keys *application-frame*))) + ((executingp *application-frame*) + (push gesture (remaining-keys *application-frame*)))) + (unread-gesture gesture :stream stream)) (defun read-numeric-argument (&key (stream *standard-input*)) (let ((gesture (climacs-read-gesture))) @@ -163,7 +182,7 @@ (loop for gesture = (climacs-read-gesture) while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME do (setf numarg (* 4 numarg)) - finally (unread-gesture gesture :stream stream)) + finally (climacs-unread-gesture gesture stream)) (let ((gesture (climacs-read-gesture))) (cond ((and (characterp gesture) (digit-char-p gesture 10)) @@ -173,19 +192,19 @@ (digit-char-p gesture 10)) do (setf numarg (+ (* 10 numarg) (- (char-code gesture) (char-code #\0)))) - finally (unread-gesture gesture :stream stream) + finally (climacs-unread-gesture gesture stream) (return (values numarg t)))) (t - (unread-gesture gesture :stream stream) + (climacs-unread-gesture gesture stream) (values numarg t)))))) ((meta-digit gesture) (let ((numarg (meta-digit gesture))) (loop for gesture = (climacs-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) - finally (unread-gesture gesture :stream stream) + finally (climacs-unread-gesture gesture stream) (return (values numarg t))))) - (t (unread-gesture gesture :stream stream) + (t (climacs-unread-gesture gesture stream) (values 1 nil))))) ;;; we know the vbox pane has a scroller pane and an info @@ -237,12 +256,16 @@ (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame))) + (when (null (remaining-keys *application-frame*)) + (setf (executingp *application-frame*) nil) + (redisplay-frame-panes frame)))) (beep) (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame))))) + (when (null (remaining-keys *application-frame*)) + (setf (executingp *application-frame*) nil) + (redisplay-frame-panes frame)))))) (defun region-limits (pane) (if (mark< (mark pane) (point pane)) @@ -675,6 +698,25 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Keyboard macros + +(define-named-command com-start-kbd-macro () + (setf (recordingp *application-frame*) t) + (setf (recorded-keys *application-frame*) '())) + +(define-named-command com-end-kbd-macro () + (setf (recordingp *application-frame*) nil) + (setf (recorded-keys *application-frame*) + ;; this won't work if the command was invoked in any old way + (reverse (cddr (recorded-keys *application-frame*))))) + +(define-named-command com-call-last-kbd-macro () + (setf (remaining-keys *application-frame*) + (recorded-keys *application-frame*)) + (setf (executingp *application-frame*) t)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Commands for splitting windows (defun replace-constellation (constellation additional-constellation vertical-p) @@ -971,7 +1013,10 @@ (c-x-set-key '(#\0) 'com-delete-window) (c-x-set-key '(#\2) 'com-split-window-vertically) (c-x-set-key '(#\3) 'com-split-window-horizontally) +(c-x-set-key '(#\() 'com-start-kbd-macro) +(c-x-set-key '(#\)) 'com-end-kbd-macro) (c-x-set-key '(#\b) 'com-switch-to-buffer) +(c-x-set-key '(#\e) 'com-call-last-kbd-macro) (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\l :control) 'com-load-file)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 19 Jan '05

19 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32062 Modified Files: gui.lisp Log Message: find-file does not create the file if it does not exist. (thanks to Lawrence Mitchell) Date: Tue Jan 18 21:28:38 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.83 climacs/gui.lisp:1.84 --- climacs/gui.lisp:1.83 Tue Jan 18 21:21:16 2005 +++ climacs/gui.lisp Tue Jan 18 21:28:38 2005 @@ -546,8 +546,10 @@ (push buffer (buffers *application-frame*)) (setf (buffer (current-window)) buffer) (setf (syntax buffer) (make-instance 'basic-syntax)) - (with-open-file (stream filename :direction :input :if-does-not-exist :create) - (input-from-stream stream buffer 0)) + ;; Don't want to create the file if it doesn't exist. + (when (probe-file filename) + (with-open-file (stream filename :direction :input) + (input-from-stream stream buffer 0))) (setf (filename buffer) filename (name buffer) (pathname-filename filename) (needs-saving buffer) nil)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp
by rstrandh＠common-lisp.net 19 Jan '05

19 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32010 Modified Files: gui.lisp pane.lisp Log Message: implemented preliminary multi-window support. C-x 2 splits the window vertically, C-x splits horizontally. C-x 0 deletes the current window. This is still preliminary code. One annoying problem is that the entire frame gets resized whenever a new window is added or deleted. Date: Tue Jan 18 21:21:17 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.82 climacs/gui.lisp:1.83 --- climacs/gui.lisp:1.82 Tue Jan 18 10:59:51 2005 +++ climacs/gui.lisp Tue Jan 18 21:21:16 2005 @@ -49,7 +49,7 @@ (window-clear pane)) (define-application-frame climacs () - ((win :reader win) + ((windows :accessor windows) (buffers :initform '() :accessor buffers)) (:panes (win (let* ((extended-pane @@ -82,14 +82,16 @@ (:top-level (climacs-top-level))) (defmacro current-window () - `(win *application-frame*)) + `(car (windows *application-frame*))) (defmethod redisplay-frame-panes :around ((frame climacs) &rest args) (declare (ignore args)) - (let ((buffer (buffer (win frame)))) - (update-syntax buffer (syntax buffer)) + (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame))))) + (loop for buffer in buffers + do (update-syntax buffer (syntax buffer))) (call-next-method) - (clear-modify buffer))) + (loop for buffer in buffers + do (clear-modify buffer)))) (defun climacs () "Starts up a climacs session" @@ -115,7 +117,7 @@ (defun display-win (frame pane) "The display function used by the climacs application frame." (declare (ignore frame)) - (redisplay-pane pane)) + (redisplay-pane pane (eq pane (car (windows *application-frame*))))) (defun find-gestures (gestures start-table) (loop with table = (find-command-table start-table) @@ -200,10 +202,10 @@ command-parser command-unparser partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser prompt)) - (with-slots (win) frame - (setf win (find-climacs-pane (find-pane-named frame 'win))) - (push (buffer win) (buffers frame)) - (let ((*standard-output* win) + (with-slots (windows) frame + (setf windows (list (find-climacs-pane (find-pane-named frame 'win)))) + (push (buffer (car windows)) (buffers frame)) + (let ((*standard-output* (car windows)) (*standard-input* (find-pane-named frame 'int)) (*print-pretty* nil) (*abort-gestures* nil)) @@ -232,12 +234,12 @@ command)) (return))) (t nil)))) - (let ((buffer (buffer (win frame)))) + (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) (redisplay-frame-panes frame))) (beep) - (let ((buffer (buffer (win frame)))) + (let ((buffer (buffer (current-window)))) (when (modified-p buffer) (setf (needs-saving buffer) t))) (redisplay-frame-panes frame))))) @@ -673,32 +675,106 @@ ;;; ;;; 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))) + (assert (member constellation children)) + (cond ((eq constellation first) + (sheet-disown-child parent constellation) + (let ((new (if vertical-p + (vertically () constellation additional-constellation) + (horizontally () constellation additional-constellation)))) + (sheet-adopt-child parent new) + (reorder-sheets parent (list new second)))) + (t + (sheet-disown-child parent constellation) + (let ((new (if vertical-p + (vertically () constellation additional-constellation) + (horizontally () constellation additional-constellation)))) + (sheet-adopt-child parent new) + (reorder-sheets parent (list first new))))))) + +(defun parent3 (sheet) + (sheet-parent (sheet-parent (sheet-parent sheet)))) + +(defun make-pane-constellation () + "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" + (let* ((extended-pane + (make-pane 'extended-pane + :width 900 :height 400 + :name 'win + :incremental-redisplay t + :display-function 'display-win)) + (vbox + (vertically () + (scrolling () extended-pane) + (make-pane 'info-pane + :climacs-pane extended-pane + :width 900 :height 20 + :max-height 20 :min-height 20 + ::background +gray85+ + :scroll-bars nil + :borders nil + :incremental-redisplay t + :display-function 'display-info)))) + (values vbox extended-pane))) + (define-named-command com-split-window-vertically () (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) - (let* ((pane (current-window)) - (new-pane (make-pane 'extended-pane - :width 900 :height 400 - :name 'win - :incremental-redisplay t - :display-function 'display-win)) - (parent (sheet-parent (sheet-parent (sheet-parent pane))))) - (setf (buffer new-pane) (buffer pane)) - (sheet-adopt-child parent - (vertically () - (scrolling () new-pane) - (make-pane 'info-pane - :climacs-pane new-pane - :width 900 :height 20 - :max-height 20 :min-height 20 - ::background +gray85+ - :scroll-bars nil - :borders nil - :incremental-redisplay t - :display-function 'display-info))) - (setf (sheet-enabled-p new-pane) t) - (full-redisplay pane) - (full-redisplay new-pane)))) + (multiple-value-bind (vbox new-pane) (make-pane-constellation) + (let* ((current-window (current-window)) + (constellation-root (parent3 current-window))) + (setf (buffer new-pane) (buffer current-window)) + (push new-pane (windows *application-frame*)) + (replace-constellation constellation-root vbox t) + (full-redisplay current-window) + (full-redisplay new-pane))))) + +(define-named-command com-split-window-horizontally () + (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)) + (constellation-root (parent3 current-window))) + (setf (buffer new-pane) (buffer current-window)) + (push new-pane (windows *application-frame*)) + (replace-constellation constellation-root vbox nil) + (full-redisplay current-window) + (full-redisplay new-pane))))) + +(define-named-command com-other-window () + (setf (windows *application-frame*) + (append (cdr (windows *application-frame*)) + (list (car (windows *application-frame*)))))) + +(define-named-command com-delete-window () + (unless (null (cdr (windows *application-frame*))) + (let* ((constellation (parent3 (current-window))) + (box (sheet-parent constellation)) + (box-children (sheet-children box)) + (other (if (eq constellation (first box-children)) + (second box-children) + (first box-children))) + (parent (sheet-parent box)) + (children (sheet-children parent)) + (first (first children)) + (second (second children))) + (pop (windows *application-frame*)) + (sheet-disown-child box other) + (cond ((eq box first) + (sheet-disown-child parent box) + (sheet-adopt-child parent other) + (reorder-sheets parent (list other second))) + (t + (sheet-disown-child parent box) + (sheet-adopt-child parent other) + (reorder-sheets parent (list first other))))))) ;;;;;;;;;;;;;;;;;;;; ;; Kill ring commands @@ -890,11 +966,14 @@ (add-command-to-command-table command 'c-x-climacs-table :keystroke gesture :errorp nil)) +(c-x-set-key '(#\0) 'com-delete-window) (c-x-set-key '(#\2) 'com-split-window-vertically) +(c-x-set-key '(#\3) 'com-split-window-horizontally) (c-x-set-key '(#\b) 'com-switch-to-buffer) (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\l :control) 'com-load-file) +(c-x-set-key '(#\o) 'com-other-window) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\t :control) 'com-transpose-lines) (c-x-set-key '(#\w :control) 'com-write-buffer) Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.5 climacs/pane.lisp:1.6 --- climacs/pane.lisp:1.5 Tue Jan 18 02:11:29 2005 +++ climacs/pane.lisp Tue Jan 18 21:21:16 2005 @@ -304,7 +304,7 @@ (beginning-of-line (point pane)) (empty-cache cache))))) -(defun display-cache (pane) +(defun display-cache (pane cursor-ink) (let* ((medium (sheet-medium pane)) (style (medium-text-style medium)) (height (text-style-height style medium))) @@ -331,18 +331,18 @@ (draw-rectangle* pane (1- cursor-x) (- cursor-y (* 0.2 height)) (+ cursor-x 2) (+ cursor-y (* 0.8 height)) - :ink +red+))))) + :ink cursor-ink))))) -(defgeneric redisplay-pane (pane)) +(defgeneric redisplay-pane (pane current-p)) -(defmethod redisplay-pane ((pane climacs-pane)) +(defmethod redisplay-pane ((pane climacs-pane) current-p) (if (full-redisplay-p pane) (progn (reposition-window pane) (adjust-cache-size-and-bot pane) (setf (full-redisplay-p pane) nil)) (adjust-cache pane)) (fill-cache pane) - (display-cache pane)) + (display-cache pane (if current-p +red+ +blue+))) (defgeneric full-redisplay (pane))

1 0

[climacs-cvs] CVS update: climacs/Doc/climacs-internals.texi
by abakic＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv32053/Doc Modified Files: climacs-internals.texi Log Message: Rudi's change to delete-region (the relative order of marks should not matter) and one more related to insertions at the end of buffer. Date: Tue Jan 18 10:59:55 2005 Author: abakic Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.7 climacs/Doc/climacs-internals.texi:1.8 --- climacs/Doc/climacs-internals.texi:1.7 Fri Jan 7 22:04:21 2005 +++ climacs/Doc/climacs-internals.texi Tue Jan 18 10:59:54 2005 @@ -307,13 +307,12 @@ @deffn {Generic Function} {delete-region} mark1 mark2 -Delete the objects in the buffer that are after mark1 and before -mark2. An error is signaled if the two marks are positioned in -different buffers. If mark1 is positioned at an offset equal to or -greater than that of mark2, no objects are deleted. If objects are -to be deleted, this function calls delete-buffer-range with the -appropriate arguments. It is acceptable to pass an offset in place -of one of the marks. +Delete the objects in the buffer that are +between mark1 and mark2. An error is signaled if the two marks +are positioned in different buffers. It is acceptable to pass an +offset in place of one of the marks. + +This function calls delete-buffer-range with the appropriate arguments. @end deffn @section Getting objects out of the buffer

1 0

[climacs-cvs] CVS update: climacs/base.lisp climacs/buffer-test.lisp climacs/buffer.lisp climacs/gui.lisp
by abakic＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32053 Modified Files: base.lisp buffer-test.lisp buffer.lisp gui.lisp Log Message: Rudi's change to delete-region (the relative order of marks should not matter) and one more related to insertions at the end of buffer. Date: Tue Jan 18 10:59:52 2005 Author: abakic Index: climacs/base.lisp diff -u climacs/base.lisp:1.20 climacs/base.lisp:1.21 --- climacs/base.lisp:1.20 Tue Jan 18 05:53:28 2005 +++ climacs/base.lisp Tue Jan 18 10:59:51 2005 @@ -182,13 +182,13 @@ "Delete until the end of the word" (let ((mark2 (clone-mark mark))) (forward-word mark2) - (delete-range mark (- (offset mark2) (offset mark))))) + (delete-region mark mark2))) (defun backward-delete-word (mark) "Delete until the beginning of the word" (let ((mark2 (clone-mark mark))) (backward-word mark2) - (delete-range mark (- (offset mark2) (offset mark))))) + (delete-region mark mark2))) (defun previous-word (mark) "Return a freshly allocated sequence, that is word before the mark" Index: climacs/buffer-test.lisp diff -u climacs/buffer-test.lisp:1.5 climacs/buffer-test.lisp:1.6 --- climacs/buffer-test.lisp:1.5 Sun Jan 16 09:58:13 2005 +++ climacs/buffer-test.lisp Tue Jan 18 10:59:51 2005 @@ -4,9 +4,9 @@ ;;; (cl:defpackage :climacs-tests - (:use :rtest :climacs-buffer #+cmu :cl)) + (:use :rtest :climacs-buffer :cl)) -(in-package :climacs-tests) +(cl:in-package :climacs-tests) (deftest standard-buffer-make-instance.test-1 (let* ((buffer (make-instance 'standard-buffer)) @@ -302,13 +302,13 @@ (m2 (make-instance 'standard-left-sticky-mark :buffer buffer :offset 5))) (delete-region m2 m) - (and (= (size buffer) 7) + (and (= (size buffer) 5) (eq (buffer m) buffer) (eq (buffer m2) buffer) (= (offset m) 3) - (= (offset m2) 5) - (buffer-sequence buffer 0 7)))) - "climacs") + (= (offset m2) 3) + (buffer-sequence buffer 0 5)))) + "clics") (deftest standard-buffer-delete-region.test-4 (let ((buffer (make-instance 'standard-buffer))) @@ -318,13 +318,13 @@ (m2 (make-instance 'standard-right-sticky-mark :buffer buffer :offset 5))) (delete-region m2 m) - (and (= (size buffer) 7) + (and (= (size buffer) 5) (eq (buffer m) buffer) (eq (buffer m2) buffer) (= (offset m) 3) - (= (offset m2) 5) - (buffer-sequence buffer 0 7)))) - "climacs") + (= (offset m2) 3) + (buffer-sequence buffer 0 5)))) + "clics") (deftest standard-buffer-delete-region.test-5 (handler-case Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.22 climacs/buffer.lisp:1.23 --- climacs/buffer.lisp:1.22 Tue Jan 18 02:11:29 2005 +++ climacs/buffer.lisp Tue Jan 18 10:59:51 2005 @@ -124,15 +124,9 @@ returned. Otherwise type is the name of a class (subclass of the mark class) to be used as a class of the clone.")) -(defmethod clone-mark ((mark standard-left-sticky-mark) &optional type) - (unless type - (setf type 'standard-left-sticky-mark)) - (make-instance type :buffer (buffer mark) :offset (offset mark))) - -(defmethod clone-mark ((mark standard-right-sticky-mark) &optional type) - (unless type - (setf type 'standard-right-sticky-mark)) - (make-instance type :buffer (buffer mark) :offset (offset mark))) +(defmethod clone-mark ((mark mark) &optional type) + (make-instance (or type (class-of mark)) + :buffer (buffer mark) :offset (offset mark))) (define-condition no-such-offset (simple-error) ((offset :reader condition-offset :initarg :offset)) @@ -392,32 +386,30 @@ (t nil))) (defgeneric delete-region (mark1 mark2) - (:documentation "Delete the objects in the buffer that are after mark1 and before -mark2. An error is signaled if the two marks are positioned in -different buffers. If mark1 is positioned at an offset equal to or -greater than that of mark2, no objects are deleted. If objects are -to be deleted, this function calls delete-buffer-range with the -appropriate arguments. It is acceptable to pass an offset in place -of one of the marks.")) + (:documentation "Delete the objects in the buffer that are +between mark1 and mark2. An error is signaled if the two marks +are positioned in different buffers. It is acceptable to pass an +offset in place of one of the marks.")) (defmethod delete-region ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) - (when (> (offset mark2) (offset mark1)) - (delete-buffer-range (buffer mark1) - (offset mark1) - (- (offset mark2) (offset mark1))))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1)))) (defmethod delete-region ((mark1 mark-mixin) offset2) - (when (> offset2 (offset mark1)) - (delete-buffer-range (buffer mark1) - (offset mark1) - (- offset2 (offset mark1))))) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (delete-buffer-range (buffer mark1) offset1 (- offset2 offset1)))) (defmethod delete-region (offset1 (mark2 mark-mixin)) - (when (> (offset mark2) offset1) - (delete-buffer-range (buffer mark2) - offset1 - (- (offset mark2) offset1)))) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1)))) (defgeneric buffer-object (buffer offset) (:documentation "Return the object at the offset in the buffer. The first object Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.81 climacs/gui.lisp:1.82 --- climacs/gui.lisp:1.81 Mon Jan 17 22:55:47 2005 +++ climacs/gui.lisp Tue Jan 18 10:59:51 2005 @@ -340,10 +340,10 @@ ;; 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. - (when (progn (end-of-line point) - (end-of-buffer-p point)) + (end-of-line point) + (when (end-of-buffer-p point) (insert-object point #\Newline)) - (next-line point) + (next-line point 0) (insert-sequence point line) (insert-object point #\Newline))))

1 0

[climacs-cvs] CVS update: climacs/base.lisp
by rstrandh＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16261 Modified Files: base.lisp Log Message: Fixes for indent commands. (thanks to Rudi Schlatte) Date: Tue Jan 18 05:53:28 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.19 climacs/base.lisp:1.20 --- climacs/base.lisp:1.19 Mon Jan 17 15:10:23 2005 +++ climacs/base.lisp Tue Jan 18 05:53:28 2005 @@ -124,11 +124,14 @@ finally (return column)))) (defgeneric number-of-lines-in-region (mark1 mark2) - (:documentation "Return the number of lines (or rather the number of -Newline characters) in the region between MARK and MARK2. It is -acceptable to pass an offset in place of one of the marks")) + (:documentation "Return the number of lines (or rather the +number of Newline characters) in the region between MARK and +MARK2. An error is signaled if the two marks are positioned in +different buffers. It is acceptable to pass an offset in place of +one of the marks")) (defmethod number-of-lines-in-region ((mark1 mark) (mark2 mark)) + (assert (eq (buffer mark1) (buffer mark2))) (buffer-number-of-lines-in-region (buffer mark1) (offset mark1) (offset mark2))) (defmethod number-of-lines-in-region ((offset integer) (mark mark)) @@ -177,21 +180,15 @@ (defun delete-word (mark) "Delete until the end of the word" - (loop until (end-of-buffer-p mark) - until (constituentp (object-after mark)) - do (delete-range mark)) - (loop until (end-of-buffer-p mark) - while (constituentp (object-after mark)) - do (delete-range mark))) + (let ((mark2 (clone-mark mark))) + (forward-word mark2) + (delete-range mark (- (offset mark2) (offset mark))))) (defun backward-delete-word (mark) "Delete until the beginning of the word" - (loop until (beginning-of-buffer-p mark) - until (constituentp (object-before mark)) - do (delete-range mark -1)) - (loop until (beginning-of-buffer-p mark) - while (constituentp (object-before mark)) - do (delete-range mark -1))) + (let ((mark2 (clone-mark mark))) + (backward-word mark2) + (delete-range mark (- (offset mark2) (offset mark))))) (defun previous-word (mark) "Return a freshly allocated sequence, that is word before the mark" @@ -388,10 +385,10 @@ (beginning-of-line mark) (unless (beginning-of-buffer-p mark) (loop until (end-of-buffer-p mark) - until (constituentp (object-after mark)) + while (whitespacep (object-after mark)) do (delete-range mark 1)) (loop until (beginning-of-buffer-p mark) - until (constituentp (object-before mark)) + while (whitespacep (object-before mark)) do (delete-range mark -1)) (insert-object mark #\Space)))

1 0

[climacs-cvs] CVS update: climacs/buffer.lisp climacs/pane.lisp
by rstrandh＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4423 Modified Files: buffer.lisp pane.lisp Log Message: Added :stream argument to presentations of characters Date: Tue Jan 18 02:11:30 2005 Author: rstrandh Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.21 climacs/buffer.lisp:1.22 --- climacs/buffer.lisp:1.21 Sat Jan 15 15:13:46 2005 +++ climacs/buffer.lisp Tue Jan 18 02:11:29 2005 @@ -451,9 +451,13 @@ (make-condition 'no-such-offset :offset offset1)) (assert (<= 0 offset2 (size buffer)) () (make-condition 'no-such-offset :offset offset2)) - (coerce (loop for offset from offset1 below offset2 - collect (buffer-object buffer offset)) - 'vector)) + (if (< offset1 offset2) + (loop with result = (make-array (- offset2 offset1)) + for offset from offset1 below offset2 + for i upfrom 0 + do (setf (aref result i) (buffer-object buffer offset)) + finally (return result)) + (make-array 0))) (defgeneric object-before (mark) (:documentation "Return the object that is immediately before the mark. If mark is at Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.4 climacs/pane.lisp:1.5 --- climacs/pane.lisp:1.4 Mon Jan 17 15:10:24 2005 +++ climacs/pane.lisp Tue Jan 18 02:11:29 2005 @@ -165,13 +165,13 @@ (output-word index) (updating-output (pane :unique-id (incf id) :cache-value obj) - (present obj))) + (present obj 'character :stream pane))) (t (output-word index) (updating-output (pane :unique-id (incf id) :cache-value obj :cache-test #'eq) - (present obj)))) + (present obj 'character :stream pane)))) (incf scan) finally (output-word index) (when (mark= scan (point pane))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27111 Modified Files: gui.lisp Log Message: The info pane now displays info about its own associated Climacs pane. Date: Mon Jan 17 22:55:47 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.80 climacs/gui.lisp:1.81 --- climacs/gui.lisp:1.80 Mon Jan 17 21:58:24 2005 +++ climacs/gui.lisp Mon Jan 17 22:55:47 2005 @@ -39,6 +39,9 @@ (dabbrev-expansion-mark :initform nil) (overwrite-mode :initform nil))) +(defclass info-pane (application-pane) + ((climacs-pane :initarg :climacs-pane))) + (defclass minibuffer-pane (application-pane) ()) (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args) @@ -49,20 +52,25 @@ ((win :reader win) (buffers :initform '() :accessor buffers)) (:panes - (win (vertically () - (scrolling () - (make-pane 'extended-pane - :width 900 :height 400 - :name 'bla - :incremental-redisplay t - :display-function 'display-win)) - (make-pane 'application-pane - :width 900 :height 20 :max-height 20 :min-height 20 - ::background +gray85+ - :scroll-bars nil - :borders nil - :incremental-redisplay t - :display-function 'display-info))) + (win (let* ((extended-pane + (make-pane 'extended-pane + :width 900 :height 400 + :name 'bla + :incremental-redisplay t + :display-function 'display-win)) + (info-pane + (make-pane 'info-pane + :climacs-pane extended-pane + :width 900 :height 20 :max-height 20 :min-height 20 + ::background +gray85+ + :scroll-bars nil + :borders nil + :incremental-redisplay t + :display-function 'display-info))) + (vertically () + (scrolling () + extended-pane) + info-pane))) (int (make-pane 'minibuffer-pane :width 900 :height 20 :max-height 20 :min-height 20 :scroll-bars nil))) @@ -92,16 +100,17 @@ (apply #'format *standard-input* format-string format-args)) (defun display-info (frame pane) - (let* ((win (win frame)) - (buf (buffer win)) - (name-info (format nil " ~a ~a Syntax: ~a ~a" - (if (needs-saving buf) "**" "--") - (name buf) - (name (syntax buf)) - (if (slot-value win 'overwrite-mode) - "Ovwrt" - "")))) - (princ name-info pane))) + (declare (ignore frame)) + (with-slots (climacs-pane) pane + (let* ((buf (buffer climacs-pane)) + (name-info (format nil " ~a ~a Syntax: ~a ~a" + (if (needs-saving buf) "**" "--") + (name buf) + (name (syntax buf)) + (if (slot-value climacs-pane 'overwrite-mode) + "Ovwrt" + "")))) + (princ name-info pane)))) (defun display-win (frame pane) "The display function used by the climacs application frame." @@ -678,7 +687,8 @@ (sheet-adopt-child parent (vertically () (scrolling () new-pane) - (make-pane 'application-pane + (make-pane 'info-pane + :climacs-pane new-pane :width 900 :height 20 :max-height 20 :min-height 20 ::background +gray85+

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by rstrandh＠common-lisp.net 18 Jan '05

18 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv24090 Modified Files: gui.lisp Log Message: Cleaned up some useless code. Introduced a macro `current-window' in preparation for true multi-window support. Please use it now instead of the previous idiom (win *application-frame*). A key sequence such as ESC <key> now works the same way as they keystroke M-<key>. (thanks to Ignas Mikalajunas) Date: Mon Jan 17 21:58:27 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.79 climacs/gui.lisp:1.80 --- climacs/gui.lisp:1.79 Mon Jan 17 15:10:23 2005 +++ climacs/gui.lisp Mon Jan 17 21:58:24 2005 @@ -63,19 +63,6 @@ :borders nil :incremental-redisplay t :display-function 'display-info))) -; (win (make-pane 'extended-pane -; :width 900 :height 400 -; :name 'bla -; :incremental-redisplay t -; :display-function 'display-win)) - - (info :application - :width 900 :height 20 :max-height 30 :min-height 30 - :name 'info :background +gray85+ - :scroll-bars nil - :borders nil - :incremental-redisplay t - :display-function 'display-info) (int (make-pane 'minibuffer-pane :width 900 :height 20 :max-height 20 :min-height 20 :scroll-bars nil))) @@ -83,21 +70,18 @@ (default (vertically (:scroll-bars nil) win - int)) - (without-interactor - (vertically (:scroll-bars nil) - (scrolling (:width 900 :height 400) win) - info))) + int))) (:top-level (climacs-top-level))) -(defmethod redisplay-frame-panes :before ((frame climacs) &rest args) - (declare (ignore args)) - (let ((buffer (buffer (win frame)))) - (update-syntax buffer (syntax buffer)))) +(defmacro current-window () + `(win *application-frame*)) -(defmethod redisplay-frame-panes :after ((frame climacs) &rest args) +(defmethod redisplay-frame-panes :around ((frame climacs) &rest args) (declare (ignore args)) - (clear-modify (buffer (win frame)))) + (let ((buffer (buffer (win frame)))) + (update-syntax buffer (syntax buffer)) + (call-next-method) + (clear-modify buffer))) (defun climacs () "Starts up a climacs session" @@ -263,12 +247,12 @@ (frame-exit *application-frame*)) (define-named-command com-toggle-overwrite-mode () - (let ((win (win *application-frame*))) + (let ((win (current-window))) (setf (slot-value win 'overwrite-mode) (not (slot-value win 'overwrite-mode))))) (define-command com-self-insert () - (let* ((win (win *application-frame*)) + (let* ((win (current-window)) (point (point win))) (unless (constituentp *current-gesture*) (possibly-expand-abbrev point)) @@ -279,19 +263,19 @@ (insert-object point *current-gesture*)))) (define-named-command com-beginning-of-line () - (beginning-of-line (point (win *application-frame*)))) + (beginning-of-line (point (current-window)))) (define-named-command com-end-of-line () - (end-of-line (point (win *application-frame*)))) + (end-of-line (point (current-window)))) (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects")) - (delete-range (point (win *application-frame*)) count)) + (delete-range (point (current-window)) count)) (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects")) - (delete-range (point (win *application-frame*)) (- count))) + (delete-range (point (current-window)) (- count))) (define-named-command com-transpose-objects () - (let* ((point (point (win *application-frame*)))) + (let* ((point (point (current-window)))) (unless (beginning-of-buffer-p point) (when (end-of-line-p point) (backward-object point)) @@ -302,13 +286,13 @@ (forward-object point))))) (define-named-command com-backward-object ((count 'integer :prompt "Number of Objects")) - (backward-object (point (win *application-frame*)) count)) + (backward-object (point (current-window)) count)) (define-named-command com-forward-object ((count 'integer :prompt "Number of Objects")) - (forward-object (point (win *application-frame*)) count)) + (forward-object (point (current-window)) count)) (define-named-command com-transpose-words () - (let* ((point (point (win *application-frame*)))) + (let* ((point (point (current-window)))) (let (bw1 bw2 ew1 ew2) (backward-word point) (setf bw1 (offset point)) @@ -332,7 +316,7 @@ (forward-word point))))) (define-named-command com-transpose-lines () - (let ((point (point (win *application-frame*)))) + (let ((point (point (current-window)))) (beginning-of-line point) (unless (beginning-of-buffer-p point) (previous-line point)) @@ -355,7 +339,7 @@ (insert-object point #\Newline)))) (define-named-command com-previous-line () - (let* ((win (win *application-frame*)) + (let* ((win (current-window)) (point (point win))) (unless (or (eq (previous-command win) 'com-previous-line) (eq (previous-command win) 'com-next-line)) @@ -363,7 +347,7 @@ (previous-line point (slot-value win 'goal-column)))) (define-named-command com-next-line () - (let* ((win (win *application-frame*)) + (let* ((win (current-window)) (point (point win))) (unless (or (eq (previous-command win) 'com-previous-line) (eq (previous-command win) 'com-next-line)) @@ -371,10 +355,10 @@ (next-line point (slot-value win 'goal-column)))) (define-named-command com-open-line () - (open-line (point (win *application-frame*)))) + (open-line (point (current-window)))) (define-named-command com-kill-line () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane)) (mark (offset point))) (cond ((end-of-buffer-p point) nil) @@ -391,45 +375,45 @@ (delete-region mark point))) (define-named-command com-forward-word () - (forward-word (point (win *application-frame*)))) + (forward-word (point (current-window)))) (define-named-command com-backward-word () - (backward-word (point (win *application-frame*)))) + (backward-word (point (current-window)))) (define-named-command com-delete-word () - (delete-word (point (win *application-frame*)))) + (delete-word (point (current-window)))) (define-named-command com-backward-delete-word () - (backward-delete-word (point (win *application-frame*)))) + (backward-delete-word (point (current-window)))) (define-named-command com-upcase-region () - (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (multiple-value-bind (start end) (region-limits (current-window)) (upcase-region start end))) (define-named-command com-downcase-region () - (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (multiple-value-bind (start end) (region-limits (current-window)) (downcase-region start end))) (define-named-command com-capitalize-region () - (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (multiple-value-bind (start end) (region-limits (current-window)) (capitalize-region start end))) (define-named-command com-upcase-word () - (upcase-word (point (win *application-frame*)))) + (upcase-word (point (current-window)))) (define-named-command com-downcase-word () - (downcase-word (point (win *application-frame*)))) + (downcase-word (point (current-window)))) (define-named-command com-capitalize-word () - (capitalize-word (point (win *application-frame*)))) + (capitalize-word (point (current-window)))) (define-named-command com-tabify-region () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (multiple-value-bind (start end) (region-limits pane) (tabify-region start end (tab-space-count (stream-default-view pane)))))) (define-named-command com-untabify-region () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (multiple-value-bind (start end) (region-limits pane) (untabify-region start end (tab-space-count (stream-default-view pane)))))) @@ -444,24 +428,18 @@ tab-space-count)))) (define-named-command com-indent-line () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane))) (indent-current-line pane point))) (define-named-command com-newline-and-indent () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane))) (insert-object point #\Newline) (indent-current-line pane point))) (define-named-command com-delete-indentation () - (delete-indentation (point (win *application-frame*)))) - -(define-named-command com-toggle-layout () - (setf (frame-current-layout *application-frame*) - (if (eq (frame-current-layout *application-frame*) 'default) - 'without-interactor - 'default))) + (delete-indentation (point (current-window)))) (define-command com-extended-command () (let ((item (accept 'command :prompt "Extended Command"))) @@ -553,9 +531,9 @@ (let ((filename (accept 'completable-pathname :prompt "Find File")) (buffer (make-instance 'climacs-buffer)) - (pane (win *application-frame*))) + (pane (current-window))) (push buffer (buffers *application-frame*)) - (setf (buffer (win *application-frame*)) buffer) + (setf (buffer (current-window)) buffer) (setf (syntax buffer) (make-instance 'basic-syntax)) (with-open-file (stream filename :direction :input :if-does-not-exist :create) (input-from-stream stream buffer 0)) @@ -568,7 +546,7 @@ (redisplay-frame-panes *application-frame*))) (define-named-command com-save-buffer () - (let* ((buffer (buffer (win *application-frame*))) + (let* ((buffer (buffer (current-window))) (filename (or (filename buffer) (accept 'completable-pathname :prompt "Save Buffer to File")))) @@ -585,7 +563,7 @@ (define-named-command com-write-buffer () (let ((filename (accept 'completable-pathname :prompt "Write Buffer to File")) - (buffer (buffer (win *application-frame*)))) + (buffer (buffer (current-window)))) (with-open-file (stream filename :direction :output :if-exists :supersede) (output-to-stream stream buffer 0 (size buffer))) (setf (filename buffer) filename @@ -612,13 +590,13 @@ (define-named-command com-switch-to-buffer () (let ((buffer (accept 'buffer :prompt "Switch to buffer"))) - (setf (buffer (win *application-frame*)) buffer) + (setf (buffer (current-window)) buffer) (setf (syntax buffer) (make-instance 'basic-syntax)) - (beginning-of-buffer (point (win *application-frame*))) - (full-redisplay (win *application-frame*)))) + (beginning-of-buffer (point (current-window))) + (full-redisplay (current-window)))) (define-named-command com-full-redisplay () - (full-redisplay (win *application-frame*))) + (full-redisplay (current-window))) (define-named-command com-load-file () (let ((filename (accept 'completable-pathname @@ -626,56 +604,56 @@ (load filename))) (define-named-command com-beginning-of-buffer () - (beginning-of-buffer (point (win *application-frame*)))) + (beginning-of-buffer (point (current-window)))) (define-named-command com-page-down () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (page-down pane))) (define-named-command com-page-up () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (page-up pane))) (define-named-command com-end-of-buffer () - (end-of-buffer (point (win *application-frame*)))) + (end-of-buffer (point (current-window)))) (define-named-command com-back-to-indentation () - (let ((point (point (win *application-frame*)))) + (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))))) (define-named-command com-goto-position () - (setf (offset (point (win *application-frame*))) + (setf (offset (point (current-window))) (accept 'integer :prompt "Goto Position"))) (define-named-command com-goto-line () (loop with mark = (make-instance 'standard-right-sticky-mark - :buffer (buffer (win *application-frame*))) + :buffer (buffer (current-window))) do (end-of-line mark) until (end-of-buffer-p mark) repeat (accept 'integer :prompt "Goto Line") do (incf (offset mark)) (end-of-line mark) finally (beginning-of-line mark) - (setf (offset (point (win *application-frame*))) + (setf (offset (point (current-window))) (offset mark)))) (define-named-command com-browse-url () (accept 'url :prompt "Browse URL")) (define-named-command com-set-mark () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (setf (mark pane) (clone-mark (point pane))))) (define-named-command com-exchange-point-and-mark () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (psetf (offset (mark pane)) (offset (point pane)) (offset (point pane)) (offset (mark pane))))) (define-named-command com-set-syntax () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (buffer (buffer pane))) (setf (syntax buffer) (make-instance (accept 'syntax :prompt "Set Syntax"))) @@ -689,7 +667,7 @@ (define-named-command com-split-window-vertically () (with-look-and-feel-realization ((frame-manager *application-frame*) *application-frame*) - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (new-pane (make-pane 'extended-pane :width 900 :height 400 :name 'win @@ -717,21 +695,21 @@ ;; Copies an element from a kill-ring to a buffer at the given offset (define-named-command com-yank () - (insert-sequence (point (win *application-frame*)) (kill-ring-yank *kill-ring*))) + (insert-sequence (point (current-window)) (kill-ring-yank *kill-ring*))) ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () - (multiple-value-bind (start end) (region-limits (win *application-frame*)) + (multiple-value-bind (start end) (region-limits (current-window)) (kill-ring-standard-push *kill-ring* (region-to-sequence start end)) (delete-region (offset start) end))) ;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () - (let ((pane (win *application-frame*))) + (let ((pane (current-window))) (kill-ring-standard-push *kill-ring* (region-to-sequence (point pane) (mark pane))))) (define-named-command com-rotate-yank () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane)) (last-yank (kill-ring-yank *kill-ring*))) (if (eq (previous-command pane) @@ -746,19 +724,19 @@ (setf (kill-ring-max-size *kill-ring*) size))) (define-named-command com-search-forward () - (search-forward (point (win *application-frame*)) + (search-forward (point (current-window)) (accept 'string :prompt "Search Forward") :test (lambda (a b) (and (characterp b) (char-equal a b))))) (define-named-command com-search-backward () - (search-backward (point (win *application-frame*)) + (search-backward (point (current-window)) (accept 'string :prompt "Search Backward") :test (lambda (a b) (and (characterp b) (char-equal a b))))) (define-named-command com-dabbrev-expand () - (let* ((win (win *application-frame*)) + (let* ((win (current-window)) (point (point win))) (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark) @@ -795,26 +773,40 @@ (move)))))))) (define-named-command com-beginning-of-paragraph () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) (beginning-of-paragraph point syntax))) (define-named-command com-end-of-paragraph () - (let* ((pane (win *application-frame*)) + (let* ((pane (current-window)) (point (point pane)) (syntax (syntax (buffer pane)))) (end-of-paragraph point syntax))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Global command table +;;; Global and dead-escape command tables (make-command-table 'global-climacs-table :errorp nil) +(make-command-table 'dead-escape-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-escape" + :menu 'dead-escape-climacs-table + :keystroke '(:escape)) + +(defun dead-escape-set-key (gesture command) + (add-command-to-command-table command 'dead-escape-climacs-table + :keystroke gesture :errorp nil)) + (defun global-set-key (gesture command) (add-command-to-command-table command 'global-climacs-table - :keystroke gesture :errorp nil)) + :keystroke gesture :errorp nil) + (when (and + (listp gesture) + (find :meta gesture)) + (dead-escape-set-key (remove :meta gesture) command))) (loop for code from (char-code #\space) to (char-code #\~) do (global-set-key (code-char code) 'com-self-insert)) @@ -903,7 +895,7 @@ ;;; Some Unicode stuff (define-named-command com-insert-charcode ((code 'integer :prompt "Code point")) - (insert-object (point (win *application-frame*)) (code-char code))) + (insert-object (point (current-window)) (code-char code))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

← Newer
1
...
71
72
73
74
75
76
77
...
85
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs