January 2005 - climacs-cvs@common-lisp.net

[climacs-cvs] CVS update: climacs/gui.lisp climacs/packages.lisp
by abakic＠common-lisp.net 09 Jan '05

09 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1272 Modified Files: gui.lisp packages.lisp Log Message: Overwrite mode: first iteration (no protocol changes). Date: Sun Jan 9 03:42:15 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.57 climacs/gui.lisp:1.58 --- climacs/gui.lisp:1.57 Sat Jan 8 18:16:19 2005 +++ climacs/gui.lisp Sun Jan 9 03:42:14 2005 @@ -104,13 +104,18 @@ (defun display-message (format-string &rest format-args) (apply #'format *standard-input* format-string format-args)) +(defvar *overwrite-mode* nil) + (defun display-info (frame pane) (let* ((win (win frame)) (buf (buffer win)) - (name-info (format nil " ~a ~a Syntax: ~a" + (name-info (format nil " ~a ~a Syntax: ~a ~a" (if (needs-saving buf) "**" "--") (name buf) - (name (syntax win))))) + (name (syntax win)) + (if *overwrite-mode* + "Ovwrt" + (format nil "L~d" (line-number (point win))))))) (princ name-info pane))) (defun display-win (frame pane) @@ -236,10 +241,18 @@ (define-named-command (com-quit) () (frame-exit *application-frame*)) +(define-named-command com-toggle-overwrite-mode () + (setf *overwrite-mode* (not *overwrite-mode*))) + (define-command com-self-insert () - (unless (constituentp *current-gesture*) - (possibly-expand-abbrev (point (win *application-frame*)))) - (insert-object (point (win *application-frame*)) *current-gesture*)) + (let ((point (point (win *application-frame*)))) + (unless (constituentp *current-gesture*) + (possibly-expand-abbrev point)) + (if (and *overwrite-mode* (not (end-of-line-p point))) + (progn + (delete-range point) + (insert-object point *current-gesture*)) + (insert-object point *current-gesture*)))) (define-named-command com-beginning-of-line () (beginning-of-line (point (win *application-frame*)))) @@ -707,6 +720,8 @@ (global-set-key '(:end :control) 'com-end-of-buffer) (global-set-key #\Rubout 'com-delete-object) (global-set-key #\Backspace 'com-backward-delete-object) + +(global-set-key '(:insert) 'com-toggle-overwrite-mode) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.22 climacs/packages.lisp:1.23 --- climacs/packages.lisp:1.22 Fri Jan 7 14:07:45 2005 +++ climacs/packages.lisp Sun Jan 9 03:42:14 2005 @@ -33,7 +33,7 @@ #:beginning-of-line-p #:end-of-line-p #:line-number #:column-number #:insert-buffer-object #:insert-buffer-sequence - #:insert-object #:insert-sequence + #:update-object #:insert-object #:insert-sequence #:delete-buffer-range #:delete-range #:delete-region #:buffer-object #:buffer-sequence

1 0

[climacs-cvs] CVS update: climacs/INSTALL
by ejohnson＠common-lisp.net 08 Jan '05

08 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7947 Modified Files: INSTALL Log Message: testing cvs commit Date: Sat Jan 8 19:07:40 2005 Author: ejohnson Index: climacs/INSTALL diff -u climacs/INSTALL:1.2 climacs/INSTALL:1.3 --- climacs/INSTALL:1.2 Wed Dec 22 15:43:18 2004 +++ climacs/INSTALL Sat Jan 8 19:07:30 2005 @@ -33,3 +33,5 @@ Start the Climacs editor. + +

1 0

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

08 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5135 Modified Files: gui.lisp Log Message: Made PgUp and PgDn (:PRIOR and :NEXT) keys work. Date: Sat Jan 8 18:16:22 2005 Author: abridgewater Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.56 climacs/gui.lisp:1.57 --- climacs/gui.lisp:1.56 Sat Jan 8 08:46:33 2005 +++ climacs/gui.lisp Sat Jan 8 18:16:19 2005 @@ -701,6 +701,8 @@ (global-set-key '(:right :control) 'com-forward-word) (global-set-key '(:home) 'com-beginning-of-line) (global-set-key '(:end) 'com-end-of-line) +(global-set-key '(:prior) 'com-page-up) +(global-set-key '(:next) 'com-page-down) (global-set-key '(:home :control) 'com-beginning-of-buffer) (global-set-key '(:end :control) 'com-end-of-buffer) (global-set-key #\Rubout 'com-delete-object)

1 0

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

08 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8946 Modified Files: gui.lisp Log Message: Fixed the beeping from C-k at end-of-buffer, thanks Robert Date: Sat Jan 8 08:46:33 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.55 climacs/gui.lisp:1.56 --- climacs/gui.lisp:1.55 Sat Jan 8 07:30:25 2005 +++ climacs/gui.lisp Sat Jan 8 08:46:33 2005 @@ -350,13 +350,12 @@ (let* ((pane (win *application-frame*)) (point (point pane)) (mark (offset point))) - (if (end-of-line-p point) - (forward-object point) - (progn - (end-of-line point) - (cond ((or (beginning-of-buffer-p point) - (end-of-buffer-p point)) nil) - ((beginning-of-line-p point)(forward-object point))))) + (cond ((end-of-buffer-p point) nil) + ((end-of-line-p point)(forward-object point)) + (t + (end-of-line point) + (cond ((beginning-of-buffer-p point) nil) + ((beginning-of-line-p point)(forward-object point))))) (if (eq (previous-command pane) 'com-kill-line) (kill-ring-concatenating-push *kill-ring* (region-to-sequence mark point))

1 0

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

08 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4907 Modified Files: gui.lisp Log Message: Minor clean ups on com-cut-out and com-copy-out. Basically leftover bits of code that could be factored out. Date: Sat Jan 8 07:30:28 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.54 climacs/gui.lisp:1.55 --- climacs/gui.lisp:1.54 Fri Jan 7 19:58:08 2005 +++ climacs/gui.lisp Sat Jan 8 07:30:25 2005 @@ -572,24 +572,18 @@ ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () - (with-slots (buffer point mark)(win *application-frame*) - (let ((offset-point (offset point)) - (offset-mark (offset mark))) - (if (< offset-point offset-mark) - (progn - (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) - (delete-buffer-range buffer offset-point (- offset-mark offset-point ))) - (progn - (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) - (delete-buffer-range buffer offset-mark (- offset-point offset-mark))))))) - + (with-slots (point mark)(win *application-frame*) + (cond ((< (offset mark)(offset point)) + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) + (delete-region (offset mark) point)) + (t + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (delete-region (offset point) mark))))) ;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () (with-slots (point mark)(win *application-frame*) - (if (< (offset point) (offset mark)) - (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) - (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))))) + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)))) (define-named-command com-rotate-yank ()

1 0

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

08 Jan '05

Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv3803 Modified Files: climacs-internals.texi Log Message: added implementation details of the kill ring protocol Date: Sat Jan 8 07:04:22 2005 Author: ejohnson Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.6 climacs/Doc/climacs-internals.texi:1.7 --- climacs/Doc/climacs-internals.texi:1.6 Thu Jan 6 18:56:42 2005 +++ climacs/Doc/climacs-internals.texi Sat Jan 8 07:04:21 2005 @@ -665,7 +665,7 @@ @end multitable @multitable @columnfractions .3 .3 .3 -@headitem Expression @tab Syntax @tab handle/read +@item Expression @tab Syntax @tab handle/read @item quoted-expression @tab 'expr @tab handle @item comment @tab ; chars <newline> @tab handle @item string @tab " chars " @tab read @@ -1502,11 +1502,9 @@ Undo might be presented in a CLIM gadget in the form of a tree where branches are added to the right over time, in @xref{figundo}. -@float + @image{undo} @anchor{figundo} -@caption{Suggested CLIM pane for `undo'} -@end float where the bigger black circle indicates the current state. The tree will be fairly tall and skinny, so the gadget should probably be a @@ -1726,6 +1724,29 @@ Returns the vector of objects currently pointed to by the cursor. If reset is T, then a call to reset-yank-position is called before the object is yanked. The default for reset is NIL. +@end deffn + +@section Implementation + +The kill ring structure is built mainly of two parts: the stack like ring portion, which is +a cursorchain, and the yank point, which is a left-sticky-flexicursor. +To initialize a kill ring, the :max-size slot initarg is simply used to set the max +size. The remaining slots constisting of the cursorchain and the left-sticky-flexicursor +are instantized upon creation of the kill ring. + +Stored onto the cursorchain are simple-vectors of objects, mainly characters from a +climacs buffer. In order to facilitate this, the kill ring implementation borrows heavily from +the flexichain library of functions. The following functions lie outside the kill ring and +flexichain protocols, but are pertinent to the kill ring implementation. + +@deffn {accessor} kill-ring-chain kill-ring +A slot accessor provided by the Climacs implemention of the kill ring class, which returns the +cursorchain associated with kill-ring. +@end deffn + +@deffn {accessor} kill-ring-cursor kill-ring +A slot accessor provided by the Climacs implemention of the kill ring class, which returns the +flexicursor assocated with kill-ring. @end deffn @node Index

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/kill-ring.lisp
by ejohnson＠common-lisp.net 07 Jan '05

07 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv1713 Modified Files: gui.lisp kill-ring.lisp Log Message: Kill Ring clean up. Fixed com-cut-out bug and substituted my habitual use of lambdas for progn's Date: Fri Jan 7 19:58:08 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.53 climacs/gui.lisp:1.54 --- climacs/gui.lisp:1.53 Fri Jan 7 16:01:20 2005 +++ climacs/gui.lisp Fri Jan 7 19:58:08 2005 @@ -347,22 +347,22 @@ (open-line (point (win *application-frame*)))) (define-named-command com-kill-line () - (let* ((payne (win *application-frame*)) - (pnt (point payne)) - (mrk (offset pnt))) - (if (end-of-line-p pnt) - (forward-object pnt) + (let* ((pane (win *application-frame*)) + (point (point pane)) + (mark (offset point))) + (if (end-of-line-p point) + (forward-object point) (progn - (end-of-line pnt) - (cond ((or (beginning-of-buffer-p pnt) - (end-of-buffer-p pnt)) nil) - ((beginning-of-line-p pnt)(forward-object pnt))))) - (if (eq (previous-command payne) 'com-kill-line) + (end-of-line point) + (cond ((or (beginning-of-buffer-p point) + (end-of-buffer-p point)) nil) + ((beginning-of-line-p point)(forward-object point))))) + (if (eq (previous-command pane) 'com-kill-line) (kill-ring-concatenating-push *kill-ring* - (region-to-sequence mrk pnt)) + (region-to-sequence mark point)) (kill-ring-standard-push *kill-ring* - (region-to-sequence mrk pnt))) - (delete-region mrk pnt))) + (region-to-sequence mark point))) + (delete-region mark point))) (define-named-command com-forward-word () (forward-word (point (win *application-frame*)))) @@ -573,40 +573,35 @@ ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () (with-slots (buffer point mark)(win *application-frame*) - (let ((offp (offset point)) - (offm (offset mark))) - (if (< offp offm) - ((lambda (b o1 o2) - (kill-ring-standard-push *kill-ring* (buffer-sequence b o1 o2)) - (delete-buffer-range b o1 (- o2 o1))) - buffer offp offm) - ((lambda (b o1 o2) - (kill-ring-standard-push *kill-ring* (buffer-sequence b o2 o1)) - (delete-buffer-range b o1 (- o2 o1))) - buffer offm offp))))) + (let ((offset-point (offset point)) + (offset-mark (offset mark))) + (if (< offset-point offset-mark) + (progn + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (delete-buffer-range buffer offset-point (- offset-mark offset-point ))) + (progn + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point)) + (delete-buffer-range buffer offset-mark (- offset-point offset-mark))))))) ;; Non destructively copies in buffer region to the kill ring (define-named-command com-copy-out () - (with-slots (buffer point mark)(win *application-frame*) - (let ((off1 (offset point)) - (off2 (offset mark))) - (if (< off1 off2) - (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off1 off2)) - (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off2 off1)))))) + (with-slots (point mark)(win *application-frame*) + (if (< (offset point) (offset mark)) + (kill-ring-standard-push *kill-ring* (region-to-sequence point mark)) + (kill-ring-standard-push *kill-ring* (region-to-sequence mark point))))) (define-named-command com-rotate-yank () - (let* ((payne (win *application-frame*)) - (pnt (point payne)) + (let* ((pane (win *application-frame*)) + (point (point pane)) (last-yank (kill-ring-yank *kill-ring*))) - (if (eq (previous-command payne) + (if (eq (previous-command pane) 'com-rotate-yank) - ((lambda (p ly) - (delete-range p (* -1 (length ly))) - (rotate-yank-position *kill-ring*)) - pnt last-yank)) - (insert-sequence pnt (kill-ring-yank *kill-ring*)))) + (progn + (delete-range point (* -1 (length last-yank))) + (rotate-yank-position *kill-ring*))) + (insert-sequence point (kill-ring-yank *kill-ring*)))) (define-named-command com-resize-kill-ring () (let ((size (accept 'integer :prompt "New kill ring size"))) Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.4 climacs/kill-ring.lisp:1.5 --- climacs/kill-ring.lisp:1.4 Fri Jan 7 14:07:45 2005 +++ climacs/kill-ring.lisp Fri Jan 7 19:58:08 2005 @@ -113,10 +113,9 @@ (let ((chain (kill-ring-chain kr))) (if (>= (kill-ring-length kr) (kill-ring-max-size kr)) - ((lambda (flex obj) - (pop-end flex) - (push-start flex obj)) - chain vector) + (progn + (pop-end chain) + (push-start chain vector)) (push-start chain vector))) (reset-yank-position kr)) @@ -132,5 +131,4 @@ (defmethod kill-ring-yank ((kr kill-ring) &optional (reset NIL)) (if reset (reset-yank-position kr)) - (element> (kill-ring-cursor kr))) - + (element> (kill-ring-cursor kr))) \ No newline at end of file

1 0

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

07 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv22222 Modified Files: gui.lisp Log Message: Lets try this again Date: Fri Jan 7 16:01:23 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.52 climacs/gui.lisp:1.53 --- climacs/gui.lisp:1.52 Fri Jan 7 15:59:15 2005 +++ climacs/gui.lisp Fri Jan 7 16:01:20 2005 @@ -350,11 +350,13 @@ (let* ((payne (win *application-frame*)) (pnt (point payne)) (mrk (offset pnt))) - (end-of-line pnt) - (cond ((or (beginning-of-buffer-p pnt) - (end-of-buffer-p pnt)) nil) - ((and (beginning-of-line-p pnt) - (end-of-line-p pnt))(forward-object pnt))) + (if (end-of-line-p pnt) + (forward-object pnt) + (progn + (end-of-line pnt) + (cond ((or (beginning-of-buffer-p pnt) + (end-of-buffer-p pnt)) nil) + ((beginning-of-line-p pnt)(forward-object pnt))))) (if (eq (previous-command payne) 'com-kill-line) (kill-ring-concatenating-push *kill-ring* (region-to-sequence mrk pnt))

1 0

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

07 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21935 Modified Files: gui.lisp Log Message: Now C-k dosn't kill newlines be default and does kill newlines if kills are performed at the end of line. Good stuff :) Date: Fri Jan 7 15:59:15 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.51 climacs/gui.lisp:1.52 --- climacs/gui.lisp:1.51 Fri Jan 7 15:29:05 2005 +++ climacs/gui.lisp Fri Jan 7 15:59:15 2005 @@ -353,7 +353,8 @@ (end-of-line pnt) (cond ((or (beginning-of-buffer-p pnt) (end-of-buffer-p pnt)) nil) - ((beginning-of-line-p pnt)(forward-object pnt))) + ((and (beginning-of-line-p pnt) + (end-of-line-p pnt))(forward-object pnt))) (if (eq (previous-command payne) 'com-kill-line) (kill-ring-concatenating-push *kill-ring* (region-to-sequence mrk pnt))

1 0

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

07 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20385 Modified Files: gui.lisp Log Message: fixed up a flaw in C-k, thanks antifuchsls Date: Fri Jan 7 15:29:10 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.50 climacs/gui.lisp:1.51 --- climacs/gui.lisp:1.50 Fri Jan 7 14:07:45 2005 +++ climacs/gui.lisp Fri Jan 7 15:29:05 2005 @@ -348,21 +348,18 @@ (define-named-command com-kill-line () (let* ((payne (win *application-frame*)) - (pnt (point payne))) - (if (and (beginning-of-buffer-p pnt) - (end-of-line-p pnt)) - NIL - (let ((mrk (offset pnt))) - (end-of-line pnt) - (if (end-of-buffer-p pnt) - nil - (forward-object pnt)) - (if (eq (previous-command payne) 'com-kill-line) - (kill-ring-concatenating-push *kill-ring* - (region-to-sequence mrk pnt)) - (kill-ring-standard-push *kill-ring* - (region-to-sequence mrk pnt))) - (delete-region mrk pnt))))) + (pnt (point payne)) + (mrk (offset pnt))) + (end-of-line pnt) + (cond ((or (beginning-of-buffer-p pnt) + (end-of-buffer-p pnt)) nil) + ((beginning-of-line-p pnt)(forward-object pnt))) + (if (eq (previous-command payne) 'com-kill-line) + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence mrk pnt)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence mrk pnt))) + (delete-region mrk pnt))) (define-named-command com-forward-word () (forward-word (point (win *application-frame*))))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/kill-ring.lisp climacs/packages.lisp
by ejohnson＠common-lisp.net 07 Jan '05

07 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16638 Modified Files: gui.lisp kill-ring.lisp packages.lisp Log Message: kill ring updated and functioning protocol. Enjoy C-k and M-y like you never have in climacs before:) Date: Fri Jan 7 14:07:46 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.49 climacs/gui.lisp:1.50 --- climacs/gui.lisp:1.49 Fri Jan 7 08:26:24 2005 +++ climacs/gui.lisp Fri Jan 7 14:07:45 2005 @@ -128,7 +128,7 @@ (setf table (command-menu-item-value item))) finally (return item))) -(defvar *kill-ring* (initialize-kill-ring 7)) +(defvar *kill-ring* (make-instance 'kill-ring :max-size 7)) (defparameter *current-gesture* nil) (defun meta-digit (gesture) @@ -347,7 +347,22 @@ (open-line (point (win *application-frame*)))) (define-named-command com-kill-line () - (kill-line (point (win *application-frame*)))) + (let* ((payne (win *application-frame*)) + (pnt (point payne))) + (if (and (beginning-of-buffer-p pnt) + (end-of-line-p pnt)) + NIL + (let ((mrk (offset pnt))) + (end-of-line pnt) + (if (end-of-buffer-p pnt) + nil + (forward-object pnt)) + (if (eq (previous-command payne) 'com-kill-line) + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence mrk pnt)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence mrk pnt))) + (delete-region mrk pnt))))) (define-named-command com-forward-word () (forward-word (point (win *application-frame*)))) @@ -552,25 +567,23 @@ ;; Kill ring commands ;; Copies an element from a kill-ring to a buffer at the given offset -(define-named-command com-copy-in () - (insert-sequence (point (win *application-frame*)) (kr-copy *kill-ring*))) - -;; Cuts an element from a kill-ring out to a buffer at a given offset -(define-named-command com-cut-in () - (insert-sequence (point (win *application-frame*)) (kr-pop *kill-ring*))) +(define-named-command com-yank () + (insert-sequence (point (win *application-frame*)) (kill-ring-yank *kill-ring*))) ;; Destructively cut a given buffer region into the kill-ring (define-named-command com-cut-out () (with-slots (buffer point mark)(win *application-frame*) - (if (< (offset point) (offset mark)) - ((lambda (b o1 o2) - (kr-push *kill-ring* (buffer-sequence b o1 o2)) - (delete-buffer-range b o1 (- o2 o1))) - buffer (offset point) (offset mark)) - ((lambda (b o1 o2) - (kr-push *kill-ring* (buffer-sequence b o2 o1)) - (delete-buffer-range b o1 (- o2 o1))) - buffer (offset mark) (offset point))))) + (let ((offp (offset point)) + (offm (offset mark))) + (if (< offp offm) + ((lambda (b o1 o2) + (kill-ring-standard-push *kill-ring* (buffer-sequence b o1 o2)) + (delete-buffer-range b o1 (- o2 o1))) + buffer offp offm) + ((lambda (b o1 o2) + (kill-ring-standard-push *kill-ring* (buffer-sequence b o2 o1)) + (delete-buffer-range b o1 (- o2 o1))) + buffer offm offp))))) ;; Non destructively copies in buffer region to the kill ring @@ -579,17 +592,25 @@ (let ((off1 (offset point)) (off2 (offset mark))) (if (< off1 off2) - (kr-push *kill-ring* (buffer-sequence buffer off1 off2)) - (kr-push *kill-ring* (buffer-sequence buffer off2 off1)))))) + (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off1 off2)) + (kill-ring-standard-push *kill-ring* (buffer-sequence buffer off2 off1)))))) + -;; Needs adjustment to be like emacs M-y -(define-named-command com-kr-rotate () - (kr-rotate *kill-ring* -1)) +(define-named-command com-rotate-yank () + (let* ((payne (win *application-frame*)) + (pnt (point payne)) + (last-yank (kill-ring-yank *kill-ring*))) + (if (eq (previous-command payne) + 'com-rotate-yank) + ((lambda (p ly) + (delete-range p (* -1 (length ly))) + (rotate-yank-position *kill-ring*)) + pnt last-yank)) + (insert-sequence pnt (kill-ring-yank *kill-ring*)))) -;; Not bound to a key yet -(define-named-command com-kr-resize () +(define-named-command com-resize-kill-ring () (let ((size (accept 'integer :prompt "New kill ring size"))) - (kr-resize *kill-ring* size))) + (setf (kill-ring-max-size *kill-ring*) size))) (define-named-command com-search-forward () (search-forward (point (win *application-frame*)) @@ -666,13 +687,13 @@ (global-set-key '(#\k :control) 'com-kill-line) (global-set-key '(#\t :control) 'com-transpose-objects) (global-set-key '(#\Space :control) 'com-set-mark) -(global-set-key '(#\y :control) 'com-copy-in) +(global-set-key '(#\y :control) 'com-yank) (global-set-key '(#\w :control) 'com-cut-out) (global-set-key '(#\f :meta) 'com-forward-word) (global-set-key '(#\b :meta) 'com-backward-word) (global-set-key '(#\t :meta) 'com-transpose-words) (global-set-key '(#\x :meta) 'com-extended-command) -(global-set-key '(#\y :meta) 'com-kr-rotate) ;currently rotates only +(global-set-key '(#\y :meta) 'com-rotate-yank) (global-set-key '(#\w :meta) 'com-copy-out) (global-set-key '(#\v :control) 'com-page-down) (global-set-key '(#\v :meta) 'com-page-up) Index: climacs/kill-ring.lisp diff -u climacs/kill-ring.lisp:1.3 climacs/kill-ring.lisp:1.4 --- climacs/kill-ring.lisp:1.3 Thu Dec 30 04:55:14 2004 +++ climacs/kill-ring.lisp Fri Jan 7 14:07:45 2005 @@ -25,70 +25,112 @@ (in-package :climacs-kill-ring) (defclass kill-ring () - ((max-size :type unsigned-byte - :initarg :max-size - :accessor kr-max-size) - (flexichain :type standard-flexichain - :initarg :flexichain - :accessor kr-flexi)) - (:documentation "Basic flexichain without resizing")) - -(defun initialize-kill-ring (size) - "Construct a kill ring of a given size" - (make-instance 'kill-ring - :max-size size - :flexichain (make-instance 'standard-flexichain))) - - -(defgeneric kr-length (kr) - (:documentation "Returns the length of a kill-ring's flexichain")) - -(defmethod kr-length ((kr kill-ring)) - (nb-elements (kr-flexi kr))) - -(defgeneric kr-resize (kr size) - (:documentation "Resize a kill ring to the value of SIZE")) - -(defmethod kr-resize ((kr kill-ring) size) - (setf (slot-value kr 'max-size) size) - (let ((len (kr-length kr))) + ((max-size :type (integer 5 *) ;5 element minimum from flexichain protocol + :initarg :max-size) + (cursorchain :type standard-cursorchain + :accessor kill-ring-chain + :initform (make-instance 'standard-cursorchain)) + (yankpoint :type left-sticky-flexicursor + :accessor kill-ring-cursor)) + (:documentation "A class for all kill rings")) + +(defmethod initialize-instance :after((kr kill-ring) &rest args) + "Adds in the yankpoint" + (declare (ignore args)) + (with-slots (cursorchain yankpoint) kr + (setf yankpoint (make-instance 'left-sticky-flexicursor :chain cursorchain)))) + +(defgeneric kill-ring-length (kr) + (:documentation "Returns the current length of the kill ring")) + +(defgeneric kill-ring-max-size (kr) + (:documentation "Returns the value of a kill ring's maximum size")) + +(defgeneric (setf kill-ring-max-size) (kr size) + (:documentation "Alters the maximum size of a kill ring, even +if it means dropping elements to do so.")) + +(defgeneric reset-yank-position (kr) + (:documentation "Moves the current yank point back to the start of + of kill ring position")) + +(defgeneric rotate-yank-position (kr &optional times) + (:documentation "Moves the yank point associated with a kill-ring + one or times many positions away from the start + of ring position. If times is greater than the + current length then the cursor will wrap to the + start of ring position and continue rotating.")) + +(defgeneric kill-ring-standard-push (kr vector) + (:documentation "Pushes a vector of objects onto the kill ring creating a new +start of ring position. This function is much like an every- +day lisp push with size considerations. If the length of the +kill ring is greater than the maximum size, then \"older\" +elements will be removed from the ring until the maximum size +is reached.")) + +(defgeneric kill-ring-concatenating-push (kr vector) + (:documentation "Concatenates the contents of vector onto the end + of the current contents of the top of the kill ring. + If the kill ring is empty the a new entry is pushed.")) + +(defgeneric kill-ring-yank (kr &optional reset) + (:documentation "Returns the vector of objects currently pointed to + by the cursor. If reset is T, a call to + reset-yank-position is called befor the object is + yanked. The default for reset is NIL")) + +(defmethod kill-ring-length ((kr kill-ring)) + (nb-elements (kill-ring-chain kr))) + +(defmethod kill-ring-max-size ((kr kill-ring)) + (with-slots (max-size) kr + max-size)) + +(defmethod (setf kill-ring-max-size) ((kr kill-ring) size) + (unless (typep size 'integer) + (error "Error, ~S, is not an integer value" size)) + (if (< size 5) + (set (slot-value kr 'max-size) 5) + (setf (slot-value kr 'max-size) size)) + (let ((len (kill-ring-length kr))) (if (> len size) (loop for n from 1 to (- len size) - do (pop-end (kr-flexi kr)))))) + do (pop-end (kill-ring-chain kr)))))) -(defgeneric kr-push (kr object) - (:documentation "Push an object onto a kill ring with size considerations")) - -(defmethod kr-push ((kr kill-ring) object) - (let ((flexi (kr-flexi kr))) - (if (>= (kr-length kr)(kr-max-size kr)) +(defmethod reset-yank-position ((kr kill-ring)) + (setf (cursor-pos (kill-ring-cursor kr)) 0) + t) + +(defmethod rotate-yank-position ((kr kill-ring) &optional (times 1)) + (if (> (kill-ring-length kr) 0) + (let* ((curs (kill-ring-cursor kr)) + (pos (mod (+ times (cursor-pos curs)) + (kill-ring-length kr)))) + (setf (cursor-pos curs) pos)))) + +(defmethod kill-ring-standard-push ((kr kill-ring) vector) + (let ((chain (kill-ring-chain kr))) + (if (>= (kill-ring-length kr) + (kill-ring-max-size kr)) ((lambda (flex obj) (pop-end flex) (push-start flex obj)) - flexi object) - (push-start flexi object)))) - -(defgeneric kr-pop (kr) - (:documentation "Pops an object off of a kill ring")) - -(defmethod kr-pop ((kr kill-ring)) - (if (> (nb-elements (kr-flexi kr)) 0) - (pop-start (kr-flexi kr)) - nil)) - -(defgeneric kr-rotate (kr &optional n) - (:documentation "Rotates the kill ring either once forward or an optional amound +/-")) - -(defmethod kr-rotate ((kr kill-ring) &optional (n -1)) - (assert (typep n 'fixnum)(n) "Can not rotate the kill ring ~S positions" n) - (let ((flexi (kr-flexi kr))) - (rotate flexi n))) - -(defgeneric kr-copy (kr) - (:documentation "Copies out a member of a kill ring without deleting it")) - -(defmethod kr-copy ((kr kill-ring)) - (let ((object (kr-pop kr))) - (kr-push kr object) - object)) + chain vector) + (push-start chain vector))) + (reset-yank-position kr)) + +(defmethod kill-ring-concatenating-push ((kr kill-ring) vector) + (let ((chain (kill-ring-chain kr))) + (if (zerop (kill-ring-length kr)) + (push-start chain vector) + (push-start chain + (concatenate 'vector + (pop-start chain) + vector)))) + (reset-yank-position kr)) + +(defmethod kill-ring-yank ((kr kill-ring) &optional (reset NIL)) + (if reset (reset-yank-position kr)) + (element> (kill-ring-cursor kr))) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.21 climacs/packages.lisp:1.22 --- climacs/packages.lisp:1.21 Fri Jan 7 08:26:24 2005 +++ climacs/packages.lisp Fri Jan 7 14:07:45 2005 @@ -52,8 +52,7 @@ #:name-mixin #:name #:buffer-lookin-at #:looking-at #:buffer-search-forward #:buffer-search-backward - #:search-forward #:search-backward - #:buffer-search-word-backward #:buffer-search-word-forward)) + #:search-forward #:search-backward)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) @@ -68,10 +67,10 @@ #:url)) (defpackage :climacs-kill-ring - (:use :clim-lisp :climacs-buffer :flexichain) - (:export #:initialize-kill-ring #:kr-length - #:kr-resize #:kr-rotate #:kill-ring - #:kr-copy #:kr-push #:kr-pop)) + (:use :clim-lisp :flexichain) + (:export #:kill-ring #:kill-ring-length #:kill-ring-max-size + #:reset-yank-position #:rotate-yank-position #:kill-ring-yank + #:kill-ring-standard-push #:kill-ring-concatenating-push)) (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax :climacs-kill-ring))

1 0

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

07 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31712 Modified Files: base.lisp gui.lisp packages.lisp Log Message: replaced *previous-command* and *goal-column* by slots in the pane according to a suggestion by Rudi Schlatte. implemented dynamic abbrev expansion according to a suggestion by Luigi Panzeri. Date: Fri Jan 7 08:26:25 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.11 climacs/base.lisp:1.12 --- climacs/base.lisp:1.11 Thu Jan 6 17:38:54 2005 +++ climacs/base.lisp Fri Jan 7 08:26:23 2005 @@ -137,6 +137,15 @@ while (constituentp (object-before mark)) do (delete-range mark -1))) +(defun previous-word (mark) + "Return a freshly allocated sequence, that is word before the mark" + (region-to-sequence + (loop for i downfrom (offset mark) + while (and (plusp i) + (constituentp (buffer-object (buffer mark) (1- i)))) + finally (return i)) + mark)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Named objects @@ -195,4 +204,20 @@ (when offset (setf (offset mark) offset)))) +(defun buffer-search-word-backward (buffer offset word &key (test #'eql)) + "return the largest offset of BUFFER <= (- OFFSET (length WORD)) +containing WORD as a word or NIL if no such offset exists" + (loop for i downfrom (- offset (length word)) to 0 + when (and (or (zerop i) (whitespacep (buffer-object buffer (1- i)))) + (buffer-looking-at buffer i word :test test)) + return i + finally (return nil))) +(defun buffer-search-word-forward (buffer offset word &key (test #'eql)) + "Return the smallest offset of BUFFER >= (+ OFFSET (length WORD)) +containing WORD as a word or NIL if no such offset exists" + (loop for i upfrom (+ offset (length word)) to (- (size buffer) (max (length word) 1)) + when (and (whitespacep (buffer-object buffer (1- i))) + (buffer-looking-at buffer i word :test test)) + return i + finally (return nil))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.48 climacs/gui.lisp:1.49 --- climacs/gui.lisp:1.48 Thu Jan 6 17:41:11 2005 +++ climacs/gui.lisp Fri Jan 7 08:26:24 2005 @@ -36,7 +36,15 @@ ((buffer :initform (make-instance 'climacs-buffer) :accessor buffer) (point :initform nil :initarg :point :reader point) (syntax :initarg :syntax :accessor syntax) - (mark :initform nil :initarg :mark :reader mark))) + (mark :initform nil :initarg :mark :reader mark) + ;; allows a certain number of commands to have some minimal memory + (previous-command :initform nil :accessor previous-command) + ;; for next-line and previous-line commands + (goal-column :initform nil) + ;; for dynamic abbrev expansion + (original-prefix :initform nil) + (prefix-start-offset :initform nil) + (dabbrev-expansion-mark :initform nil))) (defmethod initialize-instance :after ((pane climacs-pane) &rest args) (declare (ignore args)) @@ -178,8 +186,6 @@ (t (unread-gesture gesture :stream stream) (values 1 nil))))) -(defvar *previous-command*) - (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -209,9 +215,10 @@ (beep) (format *error-output* "~a~%" condition))) (setf gestures '()) - (setf *previous-command* (if (consp command) - (car command) - command)))) + (setf (previous-command *standard-output*) + (if (consp command) + (car command) + command)))) (t nil))) (let ((buffer (buffer (win frame)))) (when (modified-p buffer) @@ -320,21 +327,21 @@ (insert-sequence point line) (insert-object point #\Newline)))) -(defvar *goal-column*) - (define-named-command com-previous-line () - (let ((point (point (win *application-frame*)))) - (unless (or (eq *previous-command* 'com-previous-line) - (eq *previous-command* 'com-next-line)) - (setf *goal-column* (column-number point))) - (previous-line point *goal-column*))) + (let* ((win (win *application-frame*)) + (point (point win))) + (unless (or (eq (previous-command win) 'com-previous-line) + (eq (previous-command win) 'com-next-line)) + (setf (slot-value win 'goal-column) (column-number point))) + (previous-line point (slot-value win 'goal-column)))) (define-named-command com-next-line () - (let ((point (point (win *application-frame*)))) - (unless (or (eq *previous-command* 'com-previous-line) - (eq *previous-command* 'com-next-line)) - (setf *goal-column* (column-number point))) - (next-line point *goal-column*))) + (let* ((win (win *application-frame*)) + (point (point win))) + (unless (or (eq (previous-command win) 'com-previous-line) + (eq (previous-command win) 'com-next-line)) + (setf (slot-value win 'goal-column) (column-number point))) + (next-line point (slot-value win 'goal-column)))) (define-named-command com-open-line () (open-line (point (win *application-frame*)))) @@ -596,6 +603,43 @@ :test (lambda (a b) (and (characterp b) (char-equal a b))))) +(define-named-command com-dabbrev-expand () + (let* ((win (win *application-frame*)) + (point (point win))) + (with-slots (original-prefix prefix-start-offset dabbrev-expansion-mark) win + (flet ((move () (cond ((beginning-of-buffer-p dabbrev-expansion-mark) + (setf (offset dabbrev-expansion-mark) + (offset point)) + (forward-word dabbrev-expansion-mark)) + ((mark< dabbrev-expansion-mark point) + (backward-object dabbrev-expansion-mark)) + (t (forward-object dabbrev-expansion-mark))))) + (unless (or (beginning-of-buffer-p point) + (not (constituentp (object-before point)))) + (unless (and (eq (previous-command win) 'com-dabbrev-expand) + (not (null prefix-start-offset))) + (setf dabbrev-expansion-mark (clone-mark point)) + (backward-word dabbrev-expansion-mark) + (setf prefix-start-offset (offset dabbrev-expansion-mark)) + (setf original-prefix (region-to-sequence prefix-start-offset point)) + (move)) + (loop until (or (end-of-buffer-p dabbrev-expansion-mark) + (and (or (beginning-of-buffer-p dabbrev-expansion-mark) + (not (constituentp (object-before dabbrev-expansion-mark)))) + (looking-at dabbrev-expansion-mark original-prefix))) + do (move)) + (if (end-of-buffer-p dabbrev-expansion-mark) + (progn (delete-region prefix-start-offset point) + (insert-sequence point original-prefix) + (setf prefix-start-offset nil)) + (progn (delete-region prefix-start-offset point) + (insert-sequence point + (let ((offset (offset dabbrev-expansion-mark))) + (prog2 (forward-word dabbrev-expansion-mark) + (region-to-sequence offset dabbrev-expansion-mark) + (setf (offset dabbrev-expansion-mark) offset)))) + (move)))))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Global command table @@ -638,6 +682,7 @@ (global-set-key '(#\m :meta) 'com-back-to-indentation) (global-set-key '(#\d :meta) 'com-delete-word) (global-set-key '(#\Backspace :meta) 'com-backward-delete-word) +(global-set-key '(#\/ :meta) 'com-dabbrev-expand) (global-set-key '(:up) 'com-previous-line) (global-set-key '(:down) 'com-next-line) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.20 climacs/packages.lisp:1.21 --- climacs/packages.lisp:1.20 Wed Jan 5 06:09:04 2005 +++ climacs/packages.lisp Fri Jan 7 08:26:24 2005 @@ -52,7 +52,8 @@ #:name-mixin #:name #:buffer-lookin-at #:looking-at #:buffer-search-forward #:buffer-search-backward - #:search-forward #:search-backward)) + #:search-forward #:search-backward + #:buffer-search-word-backward #:buffer-search-word-forward)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base)

1 0

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

06 Jan '05

Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv22737/Doc Modified Files: climacs-internals.texi Log Message: protocol update for kill ring Date: Thu Jan 6 18:56:43 2005 Author: ejohnson Index: climacs/Doc/climacs-internals.texi diff -u climacs/Doc/climacs-internals.texi:1.5 climacs/Doc/climacs-internals.texi:1.6 --- climacs/Doc/climacs-internals.texi:1.5 Wed Dec 29 07:58:55 2004 +++ climacs/Doc/climacs-internals.texi Thu Jan 6 18:56:42 2005 @@ -1649,6 +1649,85 @@ @deftp {initarg} :records @end deftp +@chapter Kill Ring Protocol + +@section Overview + +During the process of text editing it may become necessary for regions of text +to be manipulated non-sequentially. The kill ring and its surrounding protocol +offers both a temporary location for data to be stored, as well as methods for +stored data to be accessed. + +Conceptually, the kill ring is a stack of bounded depth, so that when elements +are pushed beyond that depth, the oldest element is removed. All newly added +data is attached to a single point at the ``start of ring position'' or SORP. + +This protocol provides two methods which govern how data is to be attached to the +SORP. The first method moves the current SORP to a new position, on to which a new +object is attached. The second conserves the current position and replaces its +contents with a sequence constructed of new and pre-existing SORP objects. This +latter method is refered to as a ``concatenating push''. + +For data retrievial the kill ring class provides a ``yank point'' which +allows focus to be shifted from the SORP to other positions within the kill ring. +The yank point is limited to two types of motition, one being a rotation away from the SORP +and the other being an immediate return or ``reset'' to the start position. + +@section General + +@deftp {class} kill-ring +A class for all kill rings. +@end deftp + +@deftp {init-arg} :max-size +A limitation placed upon the number of elements held by a kill ring. Once the maximum size +has been reached, older entries must first be removed before new ones can be added. +@end deftp + +@deffn {generic function} kill-ring-max-size kill-ring +Returns the value of a kill ring's maximum size. +@end deffn + +@deffn {generic function} {(setf kill-ring-max-size)} kill-ring size +Alters the maximum size of a kill ring even if it means dropping +elements to do so. +@end deffn + +@deffn {generic function} kill-ring-length kill-ring +Returns the current length of a kill-ring. Note this is different than +kill-ring-max-size. +@end deffn + +@deffn {generic function} kill-ring-standard-push kill-ring vector +Pushes a vector of objects onto a given kill ring creating a new start of ring +position. This function is much like an everyday lisp push with size considerations. +If the length of the kill ring is greater than its maximum size, ``older'' elements +will be removed from the ring until the maximum size is reached. +@end deffn + +@deffn {generic function} kill-ring-concatenating-push kill-ring vector +Concatenates the contents of vector onto the end of the contents of +the current top of the kill-ring. If the kill-ring is empty, a new +entry is pushed.. +@end deffn + +@deffn {generic function} rotate-yank-position kill-ring &optional times +Moves the yank point associated with a kill-ring one or times many positions +away from the start of ring position. If times is greater than the current length +then the cursor will wrap to the start of ring position and continue rotating. +@end deffn + +@deffn {generic function} reset-yank-position kill-ring +Moves the current position of the yank point associated with a kill ring back to +the start of ring position. +@end deffn + +@deffn {generic function} kill-ring-yank kill-ring &optional reset +Returns the vector of objects currently pointed to by the cursor. If reset is T, then a +call to reset-yank-position is called before the object is yanked. The default for reset +is NIL. +@end deffn + @node Index @unnumbered Index

1 0

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

06 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18560 Modified Files: gui.lisp Log Message: Improved next- and previous-line commands so that a sequence of such commands tries to preserve the original column. Date: Thu Jan 6 17:41:11 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.47 climacs/gui.lisp:1.48 --- climacs/gui.lisp:1.47 Wed Jan 5 06:09:04 2005 +++ climacs/gui.lisp Thu Jan 6 17:41:11 2005 @@ -178,6 +178,8 @@ (t (unread-gesture gesture :stream stream) (values 1 nil))))) +(defvar *previous-command*) + (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -206,7 +208,10 @@ (error (condition) (beep) (format *error-output* "~a~%" condition))) - (setf gestures '()))) + (setf gestures '()) + (setf *previous-command* (if (consp command) + (car command) + command)))) (t nil))) (let ((buffer (buffer (win frame)))) (when (modified-p buffer) @@ -315,11 +320,21 @@ (insert-sequence point line) (insert-object point #\Newline)))) +(defvar *goal-column*) + (define-named-command com-previous-line () - (previous-line (point (win *application-frame*)))) + (let ((point (point (win *application-frame*)))) + (unless (or (eq *previous-command* 'com-previous-line) + (eq *previous-command* 'com-next-line)) + (setf *goal-column* (column-number point))) + (previous-line point *goal-column*))) (define-named-command com-next-line () - (next-line (point (win *application-frame*)))) + (let ((point (point (win *application-frame*)))) + (unless (or (eq *previous-command* 'com-previous-line) + (eq *previous-command* 'com-next-line)) + (setf *goal-column* (column-number point))) + (next-line point *goal-column*))) (define-named-command com-open-line () (open-line (point (win *application-frame*))))

1 0

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

06 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18516 Modified Files: base.lisp Log Message: modified previous-line and next-line to take an optional column argument. Date: Thu Jan 6 17:38:55 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.10 climacs/base.lisp:1.11 --- climacs/base.lisp:1.10 Wed Jan 5 06:09:04 2005 +++ climacs/base.lisp Thu Jan 6 17:38:54 2005 @@ -28,29 +28,31 @@ (in-package :climacs-base) -(defun previous-line (mark) +(defun previous-line (mark &optional column) "Move a mark up one line conserving horizontal position." - (let ((column (column-number mark))) - (beginning-of-line mark) - (if (beginning-of-buffer-p mark) - (incf (offset mark) column) - (progn (decf (offset mark)) - (when (> (column-number mark) column) - (beginning-of-line mark) - (incf (offset mark) column)))))) + (unless column + (setf column (column-number mark))) + (beginning-of-line mark) + (if (beginning-of-buffer-p mark) + (incf (offset mark) column) + (progn (decf (offset mark)) + (when (> (column-number mark) column) + (beginning-of-line mark) + (incf (offset mark) column))))) -(defun next-line (mark) +(defun next-line (mark &optional column) "Move a mark down one line conserving horizontal position." - (let ((column (column-number mark))) - (end-of-line mark) - (if (end-of-buffer-p mark) - (progn (beginning-of-line mark) - (incf (offset mark) column)) - (progn (incf (offset mark)) - (end-of-line mark) - (when (> (column-number mark) column) - (beginning-of-line mark) - (incf (offset mark) column)))))) + (unless column + (setf column (column-number mark))) + (end-of-line mark) + (if (end-of-buffer-p mark) + (progn (beginning-of-line mark) + (incf (offset mark) column)) + (progn (incf (offset mark)) + (end-of-line mark) + (when (> (column-number mark) column) + (beginning-of-line mark) + (incf (offset mark) column))))) (defun open-line (mark) "Create a new line in a buffer."

1 0

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

05 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv24863 Modified Files: buffer.lisp Log Message: Fixed some code that was not great, and modified the name of a reader function of the no-such-offset condition that made a bug in CMUCL manifest itself and made it impossible to run Climacs. Date: Wed Jan 5 22:39:24 2005 Author: rstrandh Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.15 climacs/buffer.lisp:1.16 --- climacs/buffer.lisp:1.15 Wed Jan 5 00:07:34 2005 +++ climacs/buffer.lisp Wed Jan 5 22:39:23 2005 @@ -76,10 +76,10 @@ (cursor :reader cursor)) (:documentation "A mixin class used in the initialization of a mark.")) -(defmethod offset (mark) +(defmethod offset ((mark mark-mixin)) (cursor-pos (cursor mark))) -(defmethod (setf offset) (new-offset mark) +(defmethod (setf offset) (new-offset (mark mark-mixin)) (assert (<= 0 new-offset (size (buffer mark))) () (make-condition 'no-such-offset :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) @@ -129,9 +129,9 @@ (make-instance type :buffer (buffer mark) :offset (offset mark))) (define-condition no-such-offset (simple-error) - ((offset :reader offset :initarg :offset)) + ((offset :reader condition-offset :initarg :offset)) (:report (lambda (condition stream) - (format stream "No such offset: ~a" (offset condition)))) + (format stream "No such offset: ~a" (condition-offset condition)))) (:documentation "This condition is signaled whenever an attempt is made at an operation that is before the beginning or after the end of the buffer."))

1 0

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

05 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7326 Modified Files: base.lisp gui.lisp packages.lisp Log Message: Added (non-incremental for now) search functions. Date: Wed Jan 5 06:09:04 2005 Author: rstrandh Index: climacs/base.lisp diff -u climacs/base.lisp:1.9 climacs/base.lisp:1.10 --- climacs/base.lisp:1.9 Sat Jan 1 10:34:25 2005 +++ climacs/base.lisp Wed Jan 5 06:09:04 2005 @@ -144,3 +144,53 @@ (defclass name-mixin () ((name :initarg :name :accessor name))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Search + +(defun buffer-looking-at (buffer offset vector &key (test #'eql)) + "return true if and only if BUFFER contains VECTOR at OFFSET" + (and (<= (+ offset (length vector)) (size buffer)) + (loop for i from offset + for obj across vector + unless (funcall test (buffer-object buffer i) obj) + return nil + finally (return t)))) + +(defun looking-at (mark vector &key (test #'eql)) + "return true if and only if BUFFER contains VECTOR after MARK" + (buffer-looking-at (buffer mark) (offset mark) vector :test test)) + + +(defun buffer-search-forward (buffer offset vector &key (test #'eql)) + "return the smallest offset of BUFFER >= OFFSET containing VECTOR +or NIL if no such offset exists" + (loop for i from offset to (size buffer) + when (buffer-looking-at buffer i vector :test test) + return i + finally (return nil))) + + +(defun buffer-search-backward (buffer offset vector &key (test #'eql)) + "return the largest offset of BUFFER <= (- OFFSET (length VECTOR)) +containing VECTOR or NIL if no such offset exists" + (loop for i downfrom (- offset (length vector)) to 0 + when (buffer-looking-at buffer i vector :test test) + return i + finally (return nil))) + +(defun search-forward (mark vector &key (test #'eql)) + "move MARK forward after the first occurence of VECTOR after MARK" + (let ((offset (buffer-search-forward + (buffer mark) (offset mark) vector :test test))) + (when offset + (setf (offset mark) (+ offset (length vector)))))) + +(defun search-backward (mark vector &key (test #'eql)) + "move MARK backward before the first occurence of VECTOR before MARK" + (let ((offset (buffer-search-backward + (buffer mark) (offset mark) vector :test test))) + (when offset + (setf (offset mark) offset)))) + + Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.46 climacs/gui.lisp:1.47 --- climacs/gui.lisp:1.46 Mon Jan 3 14:36:34 2005 +++ climacs/gui.lisp Wed Jan 5 06:09:04 2005 @@ -129,19 +129,37 @@ (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) :test #'event-matches-gesture-name-p)) +(defun climacs-read-gesture () + (loop for gesture = (read-gesture :stream *standard-input*) + when (event-matches-gesture-name-p gesture '(#\g :control)) + do (throw 'outer-loop nil) + until (or (characterp gesture) + (and (typep gesture 'keyboard-event) + (or (keyboard-event-character gesture) + (not (member (keyboard-event-key-name + gesture) + '(:control-left :control-right + :shift-left :shift-right + :meta-left :meta-right + :super-left :super-right + :hyper-left :hyper-right + :shift-lock :caps-lock + :alt-left :alt-right)))))) + finally (return gesture))) + (defun read-numeric-argument (&key (stream *standard-input*)) - (let ((gesture (read-gesture :stream stream))) + (let ((gesture (climacs-read-gesture))) (cond ((event-matches-gesture-name-p gesture '(#\u :control)) (let ((numarg 4)) - (loop for gesture = (read-gesture :stream stream) + (loop for gesture = (climacs-read-gesture) while (event-matches-gesture-name-p gesture '(#\u :control)) do (setf numarg (* 4 numarg)) finally (unread-gesture gesture :stream stream)) - (let ((gesture (read-gesture :stream stream))) + (let ((gesture (climacs-read-gesture))) (cond ((and (characterp gesture) (digit-char-p gesture 10)) (setf numarg (- (char-code gesture) (char-code #\0))) - (loop for gesture = (read-gesture :stream stream) + (loop for gesture = (climacs-read-gesture) while (and (characterp gesture) (digit-char-p gesture 10)) do (setf gesture (+ (* 10 numarg) @@ -152,7 +170,7 @@ (values numarg t)))))) ((meta-digit gesture) (let ((numarg (meta-digit gesture))) - (loop for gesture = (read-gesture :stream stream) + (loop for gesture = (climacs-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) finally (unread-gesture gesture :stream stream) @@ -170,40 +188,35 @@ (*print-pretty* nil) (*abort-gestures* nil)) (redisplay-frame-panes frame :force-p t) - (loop with gestures = '() - with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*) - do (setf *current-gesture* (read-gesture :stream *standard-input*)) - (when (or (characterp *current-gesture*) - (and (typep *current-gesture* 'keyboard-event) - (or (keyboard-event-character *current-gesture*) - (not (member (keyboard-event-key-name - *current-gesture*) - '(:control-left :control-right - :shift-left :shift-right - :meta-left :meta-right - :super-left :super-right - :hyper-left :hyper-right - :shift-lock :caps-lock)))))) - (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-table))) - (cond ((not item) - (beep) (setf gestures '())) - ((eq (command-menu-item-type item) :command) - (let ((command (command-menu-item-value item))) - (unless (consp command) - (setf command (list command))) - (setf command (substitute-numeric-argument-marker command numarg)) - (handler-case - (execute-frame-command frame command) - (error (condition) - (beep) - (format *error-output* "~a~%" condition))) - (setf gestures '()))) - (t nil)))) - (let ((buffer (buffer (win frame)))) - (when (modified-p buffer) - (setf (needs-saving buffer) t))) - (redisplay-frame-panes frame)))) + (loop (catch 'outer-loop + (loop with gestures = '() + with numarg = 1 ; FIXME (read-numeric-argument :stream *standard-input*) + do (setf *current-gesture* (climacs-read-gesture)) + (setf gestures (nconc gestures (list *current-gesture*))) + (let ((item (find-gestures gestures 'global-climacs-table))) + (cond ((not item) + (beep) (setf gestures '())) + ((eq (command-menu-item-type item) :command) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (handler-case + (execute-frame-command frame command) + (error (condition) + (beep) + (format *error-output* "~a~%" condition))) + (setf gestures '()))) + (t nil))) + (let ((buffer (buffer (win frame)))) + (when (modified-p buffer) + (setf (needs-saving buffer) t))) + (redisplay-frame-panes frame))) + (beep) + (let ((buffer (buffer (win frame)))) + (when (modified-p buffer) + (setf (needs-saving buffer) t))) + (redisplay-frame-panes frame)))) (defmacro define-named-command (command-name args &body body) `(define-climacs-command ,(if (listp command-name) `(,@command-name :name t) `(,command-name :name t)) ,args ,@body)) @@ -555,6 +568,18 @@ (define-named-command com-kr-resize () (let ((size (accept 'integer :prompt "New kill ring size"))) (kr-resize *kill-ring* size))) + +(define-named-command com-search-forward () + (search-forward (point (win *application-frame*)) + (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*)) + (accept 'string :prompt "Search Backward") + :test (lambda (a b) + (and (characterp b) (char-equal a b))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.19 climacs/packages.lisp:1.20 --- climacs/packages.lisp:1.19 Sat Jan 1 11:43:39 2005 +++ climacs/packages.lisp Wed Jan 5 06:09:04 2005 @@ -49,7 +49,10 @@ #:forward-word #:backward-word #:delete-word #:backward-delete-word #:input-from-stream #:output-to-stream - #:name-mixin #:name)) + #:name-mixin #:name + #:buffer-lookin-at #:looking-at + #:buffer-search-forward #:buffer-search-backward + #:search-forward #:search-backward)) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base)

1 0

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

05 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv21195 Modified Files: buffer.lisp Log Message: Removed a duplicate defclass. Date: Wed Jan 5 00:07:34 2005 Author: abakic Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.14 climacs/buffer.lisp:1.15 --- climacs/buffer.lisp:1.14 Mon Jan 3 19:15:41 2005 +++ climacs/buffer.lisp Wed Jan 5 00:07:34 2005 @@ -90,8 +90,6 @@ (defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) () (:documentation "A right-sticky-mark subclass suitable for use in a standard-buffer")) -(defclass standard-right-sticky-mark (right-sticky-mark mark-mixin) ()) - (defmethod initialize-instance :after ((mark left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer it was created for." (declare (ignore args))

1 0

[climacs-cvs] CVS update: climacs/climacs.asd
by abakic＠common-lisp.net 04 Jan '05

04 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14958 Modified Files: climacs.asd Log Message: asdf::input-files is not external (in my version). Date: Tue Jan 4 00:55:17 2005 Author: abakic Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.8 climacs/climacs.asd:1.9 --- climacs/climacs.asd:1.8 Mon Jan 3 11:25:42 2005 +++ climacs/climacs.asd Tue Jan 4 00:55:16 2005 @@ -63,7 +63,7 @@ (defmethod asdf:perform :around ((o asdf:compile-op) (c (eql (asdf:find-component (asdf:find-system :climacs) "skiplist-package")))) (cond - ((null (probe-file (first (asdf:input-files o c)))) + ((null (probe-file (first (asdf::input-files o c)))) (cerror "Retry loading climacs." "~@<You need to download & install Flexichain ~ separately! See the file INSTALL in the Climacs distribution ~

1 0

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

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29335 Modified Files: buffer.lisp Log Message: Very minor, cosmetic changes. Date: Mon Jan 3 19:15:41 2005 Author: abakic Index: climacs/buffer.lisp diff -u climacs/buffer.lisp:1.13 climacs/buffer.lisp:1.14 --- climacs/buffer.lisp:1.13 Wed Dec 29 07:58:53 2004 +++ climacs/buffer.lisp Mon Jan 3 19:15:41 2005 @@ -339,7 +339,7 @@ (defmethod insert-object ((mark mark-mixin) object) (insert-buffer-object (buffer mark) (offset mark) object)) -(defgeneric insert-sequence (mark string) +(defgeneric insert-sequence (mark sequence) (:documentation "Insert the objects in the sequence at the mark. This function simply calls insert-buffer-sequence with the buffer and the position of the mark.")) @@ -482,7 +482,7 @@ (min (offset (low-mark buffer)) offset)) (setf (offset (high-mark buffer)) (max (offset (high-mark buffer)) (+ offset n))) -(setf (slot-value buffer 'modified) t)) + (setf (slot-value buffer 'modified) t)) (defgeneric clear-modify (buffer))

1 0

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

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19246 Modified Files: syntax.lisp Log Message: Redisplay is much faster. Date: Mon Jan 3 16:07:09 2005 Author: rstrandh Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.18 climacs/syntax.lisp:1.19 --- climacs/syntax.lisp:1.18 Mon Jan 3 13:21:20 2005 +++ climacs/syntax.lisp Mon Jan 3 16:07:09 2005 @@ -265,10 +265,19 @@ (with-slots (top bot scan cache cursor-x cursor-y) syntax (position-window pane syntax) (compute-cache pane syntax) - (setf scan (offset top)) - (loop for id from 0 below (nb-elements cache) - do (updating-output (pane :unique-id id) - (display-line pane syntax (element* cache id)))) + (loop with start-offset = (offset top) + for id from 0 below (nb-elements cache) + do (setf scan start-offset) + (updating-output + (pane :unique-id id + :cache-value (if (<= start-offset + (offset (point pane)) + (+ start-offset (length (element* cache id)))) + (cons nil nil) + (element* cache id)) + :cache-test #'eq) + (display-line pane syntax (element* cache id))) + (incf start-offset (1+ (length (element* cache id))))) (when (mark= scan (point pane)) (multiple-value-bind (x y) (stream-cursor-position pane) (setf cursor-x x

1 0

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

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14784 Modified Files: gui.lisp Log Message: a very small fix. Fixnum was a bad choice here. Integer works much nicer Date: Mon Jan 3 14:36:34 2005 Author: ejohnson Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.45 climacs/gui.lisp:1.46 --- climacs/gui.lisp:1.45 Mon Jan 3 13:21:19 2005 +++ climacs/gui.lisp Mon Jan 3 14:36:34 2005 @@ -553,7 +553,7 @@ ;; Not bound to a key yet (define-named-command com-kr-resize () - (let ((size (accept 'fixnum :prompt "New kill ring size: "))) + (let ((size (accept 'integer :prompt "New kill ring size"))) (kr-resize *kill-ring* size))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

1 0

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

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10659 Modified Files: gui.lisp syntax.lisp Log Message: 2005-01-02 Lawrence Mitchell <wence(a)gmx.li> * gui.lisp ((define-application-frame climacs)): Add a without-interactor clause to the frame :layout. This is a layout without a minibuffer pane. (com-toggle-layout): Toggle layout between 'default and 'without-interactor. Note the without-interactor layout no longer allows you to enter extended commands (there's nowhere for *standard-input* to go) so I'm not sure how useful it is. (com-set-mark): Fix indentation. (com-exchange-point-and-mark): New command, exchange the positions of point and mark, bound to C-x C-x. (com-transpose-lines): New command, bound to C-x C-t. * syntax.lisp (present-contents): Fix typo in argument list. Date: Mon Jan 3 13:21:20 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.44 climacs/gui.lisp:1.45 --- climacs/gui.lisp:1.44 Mon Jan 3 11:25:43 2005 +++ climacs/gui.lisp Mon Jan 3 13:21:19 2005 @@ -77,7 +77,11 @@ (vertically (:scroll-bars nil) (scrolling (:width 900 :height 400) win) info - int))) + int)) + (without-interactor + (vertically (:scroll-bars nil) + (scrolling (:width 900 :height 400) win) + info))) (:top-level (climacs-top-level))) (defmethod redisplay-frame-panes :after ((frame climacs) &rest args) @@ -275,6 +279,29 @@ (insert-sequence point w2) (forward-word point))))) +(define-named-command com-transpose-lines () + (let ((point (point (win *application-frame*)))) + (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. + (when (progn (end-of-line point) + (end-of-buffer-p point)) + (insert-object point #\Newline)) + (next-line point) + (insert-sequence point line) + (insert-object point #\Newline)))) + (define-named-command com-previous-line () (previous-line (point (win *application-frame*)))) @@ -302,7 +329,7 @@ (define-named-command com-toggle-layout () (setf (frame-current-layout *application-frame*) (if (eq (frame-current-layout *application-frame*) 'default) - 'with-interactor + 'without-interactor 'default))) (define-command com-extended-command () @@ -474,7 +501,12 @@ (define-named-command com-set-mark () (with-slots (point mark) (win *application-frame*) - (setf mark (clone-mark point)))) + (setf mark (clone-mark point)))) + +(define-named-command com-exchange-point-and-mark () + (with-slots (point mark) (win *application-frame*) + (psetf (offset mark) (offset point) + (offset point) (offset mark)))) (define-named-command com-set-syntax () (setf (syntax (win *application-frame*)) @@ -597,7 +629,9 @@ (c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (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) +(c-x-set-key '(#\x :control) 'com-exchange-point-and-mark) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -634,8 +668,6 @@ (dead-acute-set-key '(#\y) '(com-insert-charcode 253)) (dead-acute-set-key '(#\C) '(com-insert-charcode 199)) (dead-acute-set-key '(#\c) '(com-insert-charcode 231)) -(dead-acute-set-key '(#\B) '(com-insert-charcode 197)) ; not great -(dead-acute-set-key '(#\b) '(com-insert-charcode 229)) ; not great (dead-acute-set-key '(#\x) '(com-insert-charcode 215)) (dead-acute-set-key '(#\-) '(com-insert-charcode 247)) (dead-acute-set-key '(#\T) '(com-insert-charcode 222)) @@ -643,6 +675,18 @@ (dead-acute-set-key '(#\s) '(com-insert-charcode 223)) (dead-acute-set-key '(#\Space) '(com-insert-charcode 39)) +(make-command-table 'dead-acute-dead-accute-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'dead-acute-climacs-table "dead-acute-dead-accute" + :menu 'dead-acute-dead-accute-climacs-table + :keystroke '(:dead--acute)) + +(defun dead-acute-dead-accute-set-key (gesture command) + (add-command-to-command-table command 'dead-acute-dead-accute-climacs-table + :keystroke gesture :errorp nil)) + +(dead-acute-dead-accute-set-key '(#\A) '(com-insert-charcode 197)) +(dead-acute-dead-accute-set-key '(#\a) '(com-insert-charcode 229)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Dead-grave command table Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.17 climacs/syntax.lisp:1.18 --- climacs/syntax.lisp:1.17 Sat Jan 1 11:49:26 2005 +++ climacs/syntax.lisp Mon Jan 3 13:21:20 2005 @@ -88,7 +88,7 @@ (define-presentation-type url () :inherit-from 'string) -(defgeneric present-contents (contenst pane syntax)) +(defgeneric present-contents (contents pane syntax)) (defmethod present-contents (contents pane (syntax basic-syntax)) (unless (null contents)

1 0

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

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5301 Added Files: translate.lisp Log Message: replacement for CLX' and McCLIM's translate functions. Date: Mon Jan 3 11:45:47 2005 Author: rstrandh

1 0

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

03 Jan '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4300 Modified Files: climacs.asd gui.lisp Log Message: Added support for input of latin-1 characters for those who have a keyboard configured as us-international, where the following keys are dead: ' ` " ~ ^ Date: Mon Jan 3 11:25:54 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.7 climacs/climacs.asd:1.8 --- climacs/climacs.asd:1.7 Sat Jan 1 15:39:55 2005 +++ climacs/climacs.asd Mon Jan 3 11:25:42 2005 @@ -49,6 +49,7 @@ "Flexichain/utilities" "Flexichain/flexichain" "Flexichain/flexicursor" + "translate" "packages" "buffer" "base" Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.43 climacs/gui.lisp:1.44 --- climacs/gui.lisp:1.43 Sat Jan 1 20:58:40 2005 +++ climacs/gui.lisp Mon Jan 3 11:25:43 2005 @@ -598,3 +598,152 @@ (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\s :control) 'com-save-buffer) (c-x-set-key '(#\w :control) 'com-write-buffer) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Some Unicode stuff + +(define-named-command com-insert-charcode ((code 'integer :prompt "Code point")) + (insert-object (point (win *application-frame*)) (code-char code))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-acute command table + +(make-command-table 'dead-acute-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-acute" + :menu 'dead-acute-climacs-table + :keystroke '(:dead--acute)) + +(defun dead-acute-set-key (gesture command) + (add-command-to-command-table command 'dead-acute-climacs-table + :keystroke gesture :errorp nil)) + +(dead-acute-set-key '(#\A) '(com-insert-charcode 193)) +(dead-acute-set-key '(#\E) '(com-insert-charcode 201)) +(dead-acute-set-key '(#\I) '(com-insert-charcode 205)) +(dead-acute-set-key '(#\O) '(com-insert-charcode 211)) +(dead-acute-set-key '(#\U) '(com-insert-charcode 218)) +(dead-acute-set-key '(#\Y) '(com-insert-charcode 221)) +(dead-acute-set-key '(#\a) '(com-insert-charcode 225)) +(dead-acute-set-key '(#\e) '(com-insert-charcode 233)) +(dead-acute-set-key '(#\i) '(com-insert-charcode 237)) +(dead-acute-set-key '(#\o) '(com-insert-charcode 243)) +(dead-acute-set-key '(#\u) '(com-insert-charcode 250)) +(dead-acute-set-key '(#\y) '(com-insert-charcode 253)) +(dead-acute-set-key '(#\C) '(com-insert-charcode 199)) +(dead-acute-set-key '(#\c) '(com-insert-charcode 231)) +(dead-acute-set-key '(#\B) '(com-insert-charcode 197)) ; not great +(dead-acute-set-key '(#\b) '(com-insert-charcode 229)) ; not great +(dead-acute-set-key '(#\x) '(com-insert-charcode 215)) +(dead-acute-set-key '(#\-) '(com-insert-charcode 247)) +(dead-acute-set-key '(#\T) '(com-insert-charcode 222)) +(dead-acute-set-key '(#\t) '(com-insert-charcode 254)) +(dead-acute-set-key '(#\s) '(com-insert-charcode 223)) +(dead-acute-set-key '(#\Space) '(com-insert-charcode 39)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-grave command table + +(make-command-table 'dead-grave-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-grave" + :menu 'dead-grave-climacs-table + :keystroke '(:dead--grave)) + +(defun dead-grave-set-key (gesture command) + (add-command-to-command-table command 'dead-grave-climacs-table + :keystroke gesture :errorp nil)) + +(dead-grave-set-key '(#\A) '(com-insert-charcode 192)) +(dead-grave-set-key '(#\E) '(com-insert-charcode 200)) +(dead-grave-set-key '(#\I) '(com-insert-charcode 204)) +(dead-grave-set-key '(#\O) '(com-insert-charcode 210)) +(dead-grave-set-key '(#\U) '(com-insert-charcode 217)) +(dead-grave-set-key '(#\a) '(com-insert-charcode 224)) +(dead-grave-set-key '(#\e) '(com-insert-charcode 232)) +(dead-grave-set-key '(#\i) '(com-insert-charcode 236)) +(dead-grave-set-key '(#\o) '(com-insert-charcode 242)) +(dead-grave-set-key '(#\u) '(com-insert-charcode 249)) +(dead-grave-set-key '(#\Space) '(com-insert-charcode 96)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-diaeresis command table + +(make-command-table 'dead-diaeresis-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-diaeresis" + :menu 'dead-diaeresis-climacs-table + :keystroke '(:dead--diaeresis :shift)) + +(defun dead-diaeresis-set-key (gesture command) + (add-command-to-command-table command 'dead-diaeresis-climacs-table + :keystroke gesture :errorp nil)) + +(dead-diaeresis-set-key '(#\A) '(com-insert-charcode 196)) +(dead-diaeresis-set-key '(#\E) '(com-insert-charcode 203)) +(dead-diaeresis-set-key '(#\I) '(com-insert-charcode 207)) +(dead-diaeresis-set-key '(#\O) '(com-insert-charcode 214)) +(dead-diaeresis-set-key '(#\U) '(com-insert-charcode 220)) +(dead-diaeresis-set-key '(#\a) '(com-insert-charcode 228)) +(dead-diaeresis-set-key '(#\e) '(com-insert-charcode 235)) +(dead-diaeresis-set-key '(#\i) '(com-insert-charcode 239)) +(dead-diaeresis-set-key '(#\o) '(com-insert-charcode 246)) +(dead-diaeresis-set-key '(#\u) '(com-insert-charcode 252)) +(dead-diaeresis-set-key '(#\y) '(com-insert-charcode 255)) +(dead-diaeresis-set-key '(#\Space) '(com-insert-charcode 34)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-tilde command table + +(make-command-table 'dead-tilde-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-tilde" + :menu 'dead-tilde-climacs-table + :keystroke '(:dead--tilde :shift)) + +(defun dead-tilde-set-key (gesture command) + (add-command-to-command-table command 'dead-tilde-climacs-table + :keystroke gesture :errorp nil)) + +(dead-tilde-set-key '(#\A) '(com-insert-charcode 195)) +(dead-tilde-set-key '(#\N) '(com-insert-charcode 209)) +(dead-tilde-set-key '(#\a) '(com-insert-charcode 227)) +(dead-tilde-set-key '(#\n) '(com-insert-charcode 241)) +(dead-tilde-set-key '(#\E) '(com-insert-charcode 198)) +(dead-tilde-set-key '(#\e) '(com-insert-charcode 230)) +(dead-tilde-set-key '(#\D) '(com-insert-charcode 208)) +(dead-tilde-set-key '(#\d) '(com-insert-charcode 240)) +(dead-tilde-set-key '(#\O) '(com-insert-charcode 216)) +(dead-tilde-set-key '(#\o) '(com-insert-charcode 248)) +(dead-tilde-set-key '(#\Space) '(com-insert-charcode 126)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Dead-circumflex command table + +(make-command-table 'dead-circumflex-climacs-table :errorp nil) + +(add-menu-item-to-command-table 'global-climacs-table "dead-circumflex" + :menu 'dead-circumflex-climacs-table + :keystroke '(:dead--circumflex :shift)) + +(defun dead-circumflex-set-key (gesture command) + (add-command-to-command-table command 'dead-circumflex-climacs-table + :keystroke gesture :errorp nil)) + +(dead-circumflex-set-key '(#\A) '(com-insert-charcode 194)) +(dead-circumflex-set-key '(#\E) '(com-insert-charcode 202)) +(dead-circumflex-set-key '(#\I) '(com-insert-charcode 206)) +(dead-circumflex-set-key '(#\O) '(com-insert-charcode 212)) +(dead-circumflex-set-key '(#\U) '(com-insert-charcode 219)) +(dead-circumflex-set-key '(#\a) '(com-insert-charcode 226)) +(dead-circumflex-set-key '(#\e) '(com-insert-charcode 234)) +(dead-circumflex-set-key '(#\i) '(com-insert-charcode 238)) +(dead-circumflex-set-key '(#\o) '(com-insert-charcode 244)) +(dead-circumflex-set-key '(#\u) '(com-insert-charcode 251)) +(dead-circumflex-set-key '(#\Space) '(com-insert-charcode 94))

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs January 2005