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

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

21 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7707 Modified Files: lisp-syntax.lisp Log Message: Climacs will now check whether the current argument indices are valid when figuring out which operator to display the arglist for. This permits more intelligent display of arglists. For example (with "|" being point): (with-output-to-string (list |) ) Previously, Swine (and SLIME for that matter) would display the arglist for `list', despite the fact that point is really in the arguments for `with-output-to-string'. It it still not perfect, this, for example, confuses it: (with-input-from-string (with-output-to-string (list |))) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/21 06:15:40 1.91 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/21 09:09:43 1.92 @@ -3137,6 +3137,10 @@ (defparameter +cl-garbage-keywords+ '(&whole &environment)) +(defun arglist-keyword-p (arg) + "Return T if `arg' is an arglist keyword. NIL otherwise." + (member arg +cl-arglist-keywords+)) + (defun split-arglist-on-keywords (arglist) "Return an alist keying lambda list keywords of `arglist' to the symbols affected by the keywords." @@ -3149,7 +3153,7 @@ (push (subseq arglist 0 2) sing-result) (setf arglist (cddr arglist))) (do ((llk '(&mandatory &optional &key &allow-other-keys &aux &rest &body)) - (args (if (member (first arglist) +cl-arglist-keywords+) + (args (if (arglist-keyword-p (first arglist)) arglist (cons '&mandatory arglist)) (cdr args)) @@ -3597,6 +3601,22 @@ ((listp operator) (eq (first operator) 'cl:lambda)))) +(defun indices-match-arglist (arglist arg-indices) + "Check whether the argument indices `arg-indices' could refer + to a direct argument for the operator with the argument list + `arglist'. Returns T if they could, NIL otherwise. This + functions does not care about the argument quantity, only their + structure." + (let* ((index (first arg-indices)) + (pure-arglist (remove-if #'arglist-keyword-p arglist)) + (arg (when (< index (length pure-arglist)) + (elt pure-arglist index)))) + (if (and (not (null arg)) + (listp arg) + (rest arg-indices)) + (indices-match-arglist arg (rest arg-indices)) + (null (rest arg-indices))))) + (defmacro with-code-insight (mark syntax (&key operator preceding-operand form preceding-operand-indices operands) @@ -3609,7 +3629,7 @@ (operands-sym (or operands (gensym))) (form-sym (or form (gensym))) (operand-indices-sym (or preceding-operand-indices (gensym))) - ;; My kingdom for with-gensyms! + ;; My kingdom for with-gensyms (or once-only)! (mark-value-sym (gensym)) (syntax-value-sym (gensym))) `(let* ((,mark-value-sym ,mark) @@ -3626,12 +3646,18 @@ ;; cannot find a form with a valid operator, just ;; return the form `mark' is in. (labels ((recurse (form) - (if (valid-operator-p (form-operator - form - ,syntax-value-sym)) - form - (when (and form (parent form)) - (recurse (parent form)))))) + (if (and (valid-operator-p (form-operator + form + ,syntax-value-sym)) + (indices-match-arglist + (arglist (image syntax) + (form-operator + form + ,syntax-value-sym)) + (second (multiple-value-list (find-operand-info ,mark-value-sym ,syntax-value-sym form))))) + (or (when (and form (parent form)) + (recurse (parent form))) + form)))) (or (recurse (when immediate-form (parent immediate-form))) (when immediate-form (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking @@ -3643,15 +3669,15 @@ ,@body)))) (defun show-arglist-for-form-at-mark (mark syntax) - "Display the argument list for the operator of `form'. The + "Display the argument list for the operator of `form'. The list need not be complete. If an argument list cannot be retrieved for the operator, nothing will be displayed." (with-code-insight mark syntax (:operator operator :preceding-operand preceding-operand :preceding-operand-indices preceding-operand-indices :operands operands) - (when (valid-operator-p operator) - (show-arglist-silent operator preceding-operand-indices preceding-operand operands)))) + (when (valid-operator-p operator) + (show-arglist-silent operator preceding-operand-indices preceding-operand operands)))) ;;; Definition editing

1 0

[climacs-cvs] CVS esa
by thenriksen 21 Jul '06

21 Jul '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv29784 Modified Files: esa.lisp Log Message: `com-extended-command' should not be named. --- /project/climacs/cvsroot/esa/esa.lisp 2006/05/13 16:48:04 1.19 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/07/21 07:58:42 1.20 @@ -650,9 +650,6 @@ (set-key 'com-quit 'global-esa-table '((#\x :control) (#\c :control))) (define-command (com-extended-command - ;; FIXME: I don't think it makes any sense for - ;; Extended Command to be named. - :name t :command-table global-esa-table) () "Prompt for a command name and arguments, then run it." @@ -953,6 +950,7 @@ 'command-table :stream stream) (princ "an unknown command table" stream)) + (format stream ".~%") (when (plusp (length keystrokes)) (princ "It is bound to " stream)

1 0

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

21 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv17972 Modified Files: pane.lisp gui.lisp Log Message: Changed `with-undo' so undo works properly for commands that modify buffers that were not the current buffer when the command loop started. A single undo operation still cannot undo for multiple buffers, however, so the user will have to manually invoke undo for each buffer. --- /project/climacs/cvsroot/climacs/pane.lisp 2006/07/06 17:31:50 1.44 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/07/21 06:25:45 1.45 @@ -103,20 +103,28 @@ :objects (buffer-sequence buffer offset (+ offset n))) (undo-accumulate buffer)))) -(defmacro with-undo ((buffer) &body body) - (let ((buffer-var (gensym))) - `(let ((,buffer-var ,buffer)) - (setf (undo-accumulate ,buffer-var) '()) - (unwind-protect (progn ,@body) - (cond ((null (undo-accumulate ,buffer-var)) nil) - ((null (cdr (undo-accumulate ,buffer-var))) - (add-undo (car (undo-accumulate ,buffer-var)) - (undo-tree ,buffer-var))) - (t - (add-undo (make-instance 'compound-record - :buffer ,buffer-var - :records (undo-accumulate ,buffer-var)) - (undo-tree ,buffer-var)))))))) +(defmacro with-undo ((get-buffers-exp) &body body) + "Evaluate `body', registering any changes to buffer contents in +the undo memory for the respective buffer, permitting individual +undo for each buffer. `get-buffers-exp' should be a form, that +will be evaluated whenever a complete list of buffers is +needed (to set up all buffers to prepare for undo, and to check +them all for changes after `body' has run)." + (let ((buffer-sym (gensym))) + `(progn + (dolist (,buffer-sym ,get-buffers-exp) + (setf (undo-accumulate ,buffer-sym) '())) + (unwind-protect (progn ,@body) + (dolist (,buffer-sym ,get-buffers-exp) + (cond ((null (undo-accumulate ,buffer-sym)) nil) + ((null (cdr (undo-accumulate ,buffer-sym))) + (add-undo (car (undo-accumulate ,buffer-sym)) + (undo-tree ,buffer-sym))) + (t + (add-undo (make-instance 'compound-record + :buffer ,buffer-sym + :records (undo-accumulate ,buffer-sym)) + (undo-tree ,buffer-sym))))))))) (defmethod flip-undo-record :around ((record climacs-undo-record)) (with-slots (buffer) record --- /project/climacs/cvsroot/climacs/gui.lisp 2006/07/11 14:20:20 1.220 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/21 06:25:45 1.221 @@ -299,7 +299,7 @@ (handler-case (progn (if (buffer-pane-p current-window) - (with-undo ((buffer current-window)) + (with-undo ((buffers frame)) (call-next-method)) (call-next-method)) (loop for buffer in (buffers frame)

1 0

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

21 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11851 Modified Files: lisp-syntax.lisp lisp-syntax-commands.lisp Log Message: Fixed issue where the symbol-completer was a bit too eager in deleting the original partial symbol. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/11 20:55:08 1.90 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/21 06:15:40 1.91 @@ -1575,6 +1575,19 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Useful functions for modifying forms based on the mark. + +(defun replace-symbol-at-mark (mark syntax string) + "Replace the symbol at `mark' with `string' and move `mark' to +after `string'." + (let ((token (symbol-at-mark mark syntax))) + (unless (= (offset mark) (start-offset token)) + (backward-expression mark syntax 1 nil)) + (forward-kill-expression mark syntax) + (insert-sequence mark string))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; display (defvar *white-space-start* nil) --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/09 18:44:50 1.8 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/21 06:15:40 1.9 @@ -245,24 +245,22 @@ (clear-completions))) (define-command (com-complete-symbol :name t :command-table lisp-table) () - "Attempt to complete the symbol at mark. + "Attempt to complete the symbol at mark. If successful, move point +to end of symbol. -If more than one completion is available, a list of possible -completions will be displayed." +If more than one completion is available, a list of +possible completions will be displayed." (let* ((pane (current-window)) (buffer (buffer pane)) (syntax (syntax buffer)) - (point-current-window (point pane)) - (name (symbol-name-at-mark point-current-window + (mark (point pane)) + (name (symbol-name-at-mark mark syntax))) (when name - (with-syntax-package syntax point-current-window (package) - (let ((completion (show-completions syntax name package)) - (mark (clone-mark point-current-window))) + (with-syntax-package syntax mark (package) + (let ((completion (show-completions syntax name package))) (unless (= (length completion) 0) - (backward-object mark (length name)) - (delete-region mark point-current-window) - (insert-sequence point-current-window completion))))))) + (replace-symbol-at-mark mark syntax completion))))))) (define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () "Attempt to fuzzily complete the abbreviation at mark. @@ -273,17 +271,14 @@ (let* ((pane (current-window)) (buffer (buffer pane)) (syntax (syntax buffer)) - (point-current-window (point pane)) - (name (symbol-name-at-mark point-current-window + (mark (mark pane)) + (name (symbol-name-at-mark mark syntax))) (when name - (with-syntax-package syntax point-current-window (package) - (let ((completion (show-fuzzy-completions syntax name package)) - (mark (clone-mark point-current-window))) + (with-syntax-package syntax mark (package) + (let ((completion (show-fuzzy-completions syntax name package))) (unless (= (length completion) 0) - (backward-object mark (length name)) - (delete-region mark point-current-window) - (insert-sequence point-current-window completion))))))) + (replace-symbol-at-mark mark syntax completion))))))) (define-presentation-to-command-translator lookup-symbol-arglist (symbol com-lookup-arglist lisp-table

1 0

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

21 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7710 Modified Files: editing.lisp Log Message: Explicitly use the `stream-default-view' function in the CLIM package. This fix is indicative of a larger problem. --- /project/climacs/cvsroot/climacs/editing.lisp 2006/07/07 23:59:38 1.2 +++ /project/climacs/cvsroot/climacs/editing.lisp 2006/07/21 05:08:26 1.3 @@ -303,7 +303,7 @@ "Indent all lines in the region delimited by `mark1' and `mark2' according to the rules of the active syntax in `pane'." (let* ((buffer (buffer pane)) - (view (stream-default-view pane)) + (view (clim:stream-default-view pane)) (tab-space-count (tab-space-count view)) (tab-width (and (indent-tabs-mode buffer) tab-space-count))

1 0

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

20 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv32749 Removed Files: undo.html undo-en.html skeleton.html skeleton-en.html redisplay.html redisplay-en.html pdp.html index.html climacs.html climacs-en.html buffer.html buffer-en.html Log Message: Removed a bunch of no longer needed and possibly outdated HTML files.

1 0

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

11 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv30459 Modified Files: lisp-syntax.lisp Log Message: Added indentation rule for readtime-evaluation-forms. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/05 13:52:17 1.89 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/11 20:55:08 1.90 @@ -2438,6 +2438,11 @@ ((null (cdr path)) (values (first-form (children tree)) 0)))) +(defmethod indent-form ((syntax lisp-syntax) (tree readtime-evaluation-form) path) + (if (null (cdr path)) + (values tree 0) + (indent-form syntax (elt-form (children tree) 0) (cdr path)))) + (defmethod indent-form ((syntax lisp-syntax) (tree list-form) path) (if (= (car path) 1) ;; before first element

1 0

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

11 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv7651 Modified Files: packages.lisp gui.lisp climacs.asd Added Files: climacs.lisp Log Message: Added new CLIMACS package and moved entry points to it. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/09 18:44:50 1.103 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/11 14:20:20 1.104 @@ -4,6 +4,8 @@ ;;; Robert Strandh (strandh(a)labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr) +;;; (c) copyright 2006 by +;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -22,6 +24,8 @@ ;;; Package definitions for the Climacs editor. +(in-package :cl-user) + (defpackage :climacs-buffer (:use :clim-lisp :flexichain :binseq) (:export #:buffer #:standard-buffer @@ -318,33 +322,41 @@ :climacs-kill-ring :climacs-pane :clim-extensions :undo :esa :climacs-editing :climacs-motion) ;;(:import-from :lisp-string) - (:export :climacs ; Main entry point. + (:export #:climacs ; Frame. + ;; GUI functions follow. - :climacs-rv ; Entry point with alternate colors. - :current-window - :current-point - :current-buffer - :current-buffer - :point - :syntax - :mark - :insert-character - :base-table - :buffer-table - :case-table - :comment-table - :deletion-table - :development-table - :editing-table - :fill-table - :indent-table - :info-table - :marking-table - :movement-table - :pane-table - :search-table - :self-insert-table - :window-table)) + #:current-window + #:current-point + #:current-buffer + #:current-buffer + #:point + #:syntax + #:mark + #:insert-character + #:base-table + #:buffer-table + #:case-table + #:comment-table + #:deletion-table + #:development-table + #:editing-table + #:fill-table + #:indent-table + #:info-table + #:marking-table + #:movement-table + #:pane-table + #:search-table + #:self-insert-table + #:window-table + + ;; Some configuration variables + #:*bg-color* + #:*fg-color* + #:*info-bg-color* + #:*info-fg-color* + #:*mini-bg-color* + #:*mini-fg-color*)) (defpackage :climacs-commands (:use :clim-lisp :clim :climacs-base :climacs-buffer @@ -379,4 +391,12 @@ (defpackage :climacs-lisp-syntax (:use :clim-lisp :clim :clim-extensions :climacs-buffer :climacs-base :climacs-syntax :flexichain :climacs-pane :climacs-gui :climacs-motion :climacs-editing) - (:export :lisp-string)) \ No newline at end of file + (:export #:lisp-string + #:edit-definition)) + +(defpackage :climacs + (:use :clim-lisp :clim :clim-sys :clim-extensions :climacs-gui) + (:export #:climacs + #:climacs-rv + #:edit-definition) + (:documentation "Package containing entry points to Climacs.")) \ No newline at end of file --- /project/climacs/cvsroot/climacs/gui.lisp 2006/06/13 11:34:52 1.219 +++ /project/climacs/cvsroot/climacs/gui.lisp 2006/07/11 14:20:20 1.220 @@ -201,33 +201,6 @@ "Return the current buffer." (buffer (current-window))) -(defun climacs (&key new-process (process-name "Climacs") - (width 900) (height 400)) - "Starts up a climacs session" - (let ((frame (make-application-frame 'climacs :width width :height height))) - (flet ((run () - (run-frame-top-level frame))) - (if new-process - (clim-sys:make-process #'run :name process-name) - (run))))) - -(defun climacs-rv (&key new-process (process-name "Climacs") - (width 900) (height 400)) - "Starts up a climacs session" - ;; SBCL doesn't inherit dynamic bindings when starting new - ;; processes, so start a new processes and THEN setup the colors. - (flet ((run () - (let ((*bg-color* +black+) - (*fg-color* +gray+) - (*info-bg-color* +darkslategray+) - (*info-fg-color* +gray+) - (*mini-bg-color* +black+) - (*mini-fg-color* +white+)) - (climacs :new-process nil :width width :height height)))) - (if new-process - (clim-sys:make-process #'run :name process-name) - (run)))) - (define-presentation-type read-only ()) (define-presentation-method highlight-presentation ((type read-only) record stream state) @@ -540,25 +513,6 @@ 'pane-table '((#\x :control) (#\k))) -#+sbcl -(defun ed-in-climacs (thing) - (let ((frame-manager (find-frame-manager))) - (when frame-manager - (let ((climacs-frame (find-if (lambda (x) (typep x 'climacs)) - (frame-manager-frames frame-manager)))) - (when climacs-frame - (typecase thing - ((or pathname string) - (execute-frame-command - climacs-frame `(com-find-file ,(pathname thing))) - t) - ((or symbol cons) - ;; FIXME: do something - nil))))))) - -#+sbcl -(pushnew 'ed-in-climacs sb-ext:*ed-functions*) - ;;; For the ESA help functions. (defmethod help-stream ((frame climacs) title) --- /project/climacs/cvsroot/climacs/climacs.lisp 2004/12/16 06:23:42 1.2 +++ /project/climacs/cvsroot/climacs/climacs.lisp 2006/07/11 14:20:20 1.3 @@ -1,145 +1,58 @@ -(defpackage :climacs - (:use :clim-lisp :clim :climacs-buffer)) +;;; -*- Mode: Lisp; Package: CLIMACS -*- -(in-package :climacs) - -(define-application-frame climacs () - ((buffer :initform (make-instance 'standard-buffer) - :accessor buffer) - (point :initform nil :reader point)) - (:panes - (win :interactor :width 600 :height 200 - :display-function 'display-win)) - (:layouts - (default (vertically () win))) - (:top-level (climacs-top-level))) - -(defmethod initialize-instance :after ((frame climacs) &rest args) - (declare (ignore args)) - (setf (slot-value frame 'point) - (make-instance 'standard-right-sticky-mark - :buffer (buffer frame)))) - -(defun climacs () - (run-frame-top-level (make-application-frame 'climacs))) - -(defun display-win (frame pane) - (let* ((medium (sheet-medium pane)) - (style (medium-text-style medium)) - (height (* 1.1 (text-style-height style medium))) - (width (text-style-width style medium))) - (loop with size = (size (buffer frame)) - with y = height - for x from 0 by width - for offset from 0 below size - do (if (char= (buffer-char (buffer frame) offset) #\Newline) - (setf y (+ y height) - x (- width)) - (draw-text* pane (buffer-char (buffer frame) offset) x y))) - (let* ((line (line-number (point frame))) - (col (column-number (point frame))) - (x (* width col)) - (y (* height (+ line 0.5)))) - (draw-line* pane x (- y (* 0.5 height)) x (+ y (* 0.5 height)) :ink +red+)))) - -(defun find-gestures (gestures start-table) - (loop with table = (find-command-table start-table) - for (gesture . rest) on gestures - for item = (find-keystroke-item gesture table :errorp nil) - while item - do (if (eq (command-menu-item-type item) :command) - (return (if (null rest) item nil)) - (setf table (command-menu-item-value item))) - finally (return item))) - -(defparameter *current-gesture* nil) - -(defun climacs-top-level (frame &key - command-parser command-unparser - partial-command-parser prompt) - (declare (ignore command-parser command-unparser partial-command-parser prompt)) - (let ((*standard-output* (frame-standard-output frame)) - (*standard-input* (frame-standard-input frame)) - (*print-pretty* nil)) - (redisplay-frame-panes frame :force-p t) - (loop with gestures = '() - do (setf *current-gesture* (read-gesture :stream *standard-input*)) - (when (or (characterp *current-gesture*) - (keyboard-event-character *current-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) - (funcall (command-menu-item-value item)) - (setf gestures '())) - (t nil)))) - (redisplay-frame-panes frame :force-p t)))) - -(define-command com-quit () - (frame-exit *application-frame*)) - -(define-command com-self-insert () - (insert-text (point *application-frame*) *current-gesture*)) - -(define-command com-backward-char () - (decf (offset (point *application-frame*)))) - -(define-command com-forward-char () - (incf (offset (point *application-frame*)))) - -(define-command com-beginning-of-line () - (beginning-of-line (point *application-frame*))) - -(define-command com-end-of-line () - (end-of-line (point *application-frame*))) - -(define-command com-delete-char () - (delete-text (point *application-frame*))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; Global command table - -(make-command-table 'global-climacs-table :errorp nil) - -(loop for code from (char-code #\space) to (char-code #\~) - do (add-command-to-command-table - 'com-self-insert - (find-command-table 'global-climacs-table) - :keystroke (code-char code) :errorp nil)) - -(add-command-to-command-table 'com-self-insert (find-command-table 'global-climacs-table) - :keystroke #\newline :errorp nil) - -(add-command-to-command-table 'com-forward-char (find-command-table 'global-climacs-table) - :keystroke '(#\f :control) :errorp nil) - -(add-command-to-command-table 'com-backward-char (find-command-table 'global-climacs-table) - :keystroke '(#\b :control) :errorp nil) - -(add-command-to-command-table 'com-beginning-of-line (find-command-table 'global-climacs-table) - :keystroke '(#\a :control) :errorp nil) - -(add-command-to-command-table 'com-end-of-line (find-command-table 'global-climacs-table) - :keystroke '(#\e :control) :errorp nil) - -(add-command-to-command-table 'com-delete-char (find-command-table 'global-climacs-table) - :keystroke '(#\d :control) :errorp nil) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; -;;; C-x command table - -(make-command-table 'c-x-climacs-table :errorp nil) - -(add-menu-item-to-command-table 'global-climacs-table "C-x" - :menu (find-command-table 'c-x-climacs-table) - :keystroke '(#\x :control)) +;;; (c) copyright 2004-2005 by +;;; Robert Strandh (strandh(a)labri.fr) +;;; (c) copyright 2004-2005 by +;;; Elliott Johnson (ejohnson(a)fasl.info) +;;; (c) copyright 2005 by +;;; Matthieu Villeneuve (matthieu.villeneuve(a)free.fr) +;;; (c) copyright 2005 by +;;; Aleksandar Bakic (a_bakic(a)yahoo.com) +;;; (c) copyright 2006 by +;;; Troels Henriksen (athas(a)sigkill.dk) + +;;; This library is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU Library General Public +;;; License as published by the Free Software Foundation; either +;;; version 2 of the License, or (at your option) any later version. +;;; +;;; This library is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; Library General Public License for more details. +;;; +;;; You should have received a copy of the GNU Library General Public +;;; License along with this library; if not, write to the +;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;;; Boston, MA 02111-1307 USA. -;;; for some reason, C-c does not seem to arrive as far as CLIM. - -(add-command-to-command-table 'com-quit (find-command-table 'c-x-climacs-table) - :keystroke '(#\q :control)) +;;; Entry points for the Climacs editor. +(in-package :climacs) +(defun climacs (&key new-process (process-name "Climacs") + (width 900) (height 400)) + "Starts up a climacs session" + (let ((frame (make-application-frame 'climacs :width width :height height))) + (flet ((run () + (run-frame-top-level frame))) + (if new-process + (clim-sys:make-process #'run :name process-name) + (run))))) + +(defun climacs-rv (&key new-process (process-name "Climacs") + (width 900) (height 400)) + "Starts up a climacs session with alternative colors." + ;; SBCL doesn't inherit dynamic bindings when starting new + ;; processes, so start a new processes and THEN setup the colors. + (flet ((run () + (let ((*bg-color* +black+) + (*fg-color* +gray+) + (*info-bg-color* +darkslategray+) + (*info-fg-color* +gray+) + (*mini-bg-color* +black+) + (*mini-fg-color* +white+)) + (climacs :new-process nil :width width :height height)))) + (if new-process + (clim-sys:make-process #'run :name process-name) + (run)))) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/07/05 13:52:17 1.46 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/11 14:20:20 1.47 @@ -2,6 +2,8 @@ ;;; (c) copyright 2004 by ;;; Robert Strandh (strandh(a)labri.u-bordeaux.fr) +;;; (c) copyright 2006 by +;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public @@ -91,6 +93,7 @@ (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" "kill-ring" "io" "text-syntax" "abbrev" "editing" "motion")) + (:file "climacs" :depends-on ("gui")) ;; (:file "buffer-commands" :depends-on ("gui")) (:file "developer-commands" :depends-on ("gui" "lisp-syntax")) (:file "motion-commands" :depends-on ("gui"))

1 0

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

09 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12893 Modified Files: packages.lisp motion-commands.lisp lisp-syntax-commands.lisp editing-commands.lisp Log Message: Unified CLIMACS-MOTION-COMMANDS and CLIMACS-EDITING-COMMANDS into a CLIMACS-COMMANDS package, added documentation strings to some package definitions to make it more clear what they (are supposed to) contain. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/07 23:59:38 1.102 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/09 18:44:50 1.103 @@ -54,7 +54,10 @@ #:persistent-left-sticky-mark #:persistent-right-sticky-mark #:persistent-left-sticky-line-mark #:persistent-right-sticky-line-mark #:p-line-mark-mixin #:buffer-line-offset - #:delegating-buffer #:implementation)) + #:delegating-buffer #:implementation) + (:documentation "An implementation of the Climacs buffer + protocol. This package is quite low-level, not syntax-aware, + not CLIM-aware and not user-oriented at all.")) (defpackage :climacs-kill-ring (:use :clim-lisp :flexichain) @@ -63,7 +66,8 @@ #:append-next-p #:reset-yank-position #:rotate-yank-position #:kill-ring-yank #:kill-ring-standard-push #:kill-ring-concatenating-push - #:kill-ring-reverse-concatenating-push)) + #:kill-ring-reverse-concatenating-push) + (:documentation "An implementation of a kill ring.")) (defpackage :climacs-base (:use :clim-lisp :climacs-buffer :climacs-kill-ring) @@ -93,7 +97,15 @@ #:capitalize-buffer-region #:capitalize-region #:tabify-region #:untabify-region #:indent-line #:delete-indentation - #:*kill-ring*)) + #:*kill-ring*) + (:documentation "Basic functionality built on top of the buffer + protocol. Here is where we define slightly higher level + functions, that can be directly implemented in terms of the + buffer protocol, but that are not, strictly speaking, part of + that protocol. The functions in this package are not + syntax-aware, and are thus limited in what they can do. They + percieve the buffer as little more than a sequence of + characters.")) (defpackage :climacs-abbrev (:use :clim-lisp :clim :climacs-buffer :climacs-base) @@ -138,10 +150,13 @@ #:word-constituentp #:whitespacep #:page-delimiter - #:paragraph-delimiter)) + #:paragraph-delimiter) + (:documentation "The Climacs syntax protocol. Contains + functions that can be used to implement higher-level operations + on buffer contents.")) (defpackage :undo - (:use :common-lisp) + (:use :clim-lisp) (:export #:no-more-undo #:undo-tree #:standard-undo-tree #:undo-record #:standard-undo-record @@ -174,7 +189,7 @@ #:climacs-textual-view #:+climacs-textual-view+)) (defpackage :climacs-motion - (:use :clim-lisp :clim :climacs-base :climacs-buffer :climacs-syntax) + (:use :clim-lisp :climacs-base :climacs-buffer :climacs-syntax) (:export #:forward-to-word-boundary #:backward-to-word-boundary #:define-motion-fns #:beep-limit-action #:revert-limit-action #:error-limit-action @@ -233,10 +248,16 @@ #:forward-one-sentence #:backward-one-sentence #:forward-sentence - #:backward-sentence)) + #:backward-sentence) + (:documentation "Functions and facilities for moving a mark + around by syntactical elements. The functions in this package + are syntax-aware, and their behavior is based on the semantics + defined by the syntax of the buffer, that the mark they are + manipulating belong to. These functions are also directly used + to implement the motion commands.")) (defpackage :climacs-editing - (:use :clim-lisp :clim :climacs-base :climacs-buffer + (:use :clim-lisp :climacs-base :climacs-buffer :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring) (:export #:transpose-objects @@ -283,7 +304,13 @@ #:indent-region #:fill-line - #:fill-region)) + #:fill-region) + (:documentation "Functions and facilities for changing the + buffer contents by syntactical elements. The functions in this package + are syntax-aware, and their behavior is based on the semantics + defined by the syntax of the buffer, that the mark they are + manipulating belong to. These functions are also directly used + to implement the editing commands.")) (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base @@ -319,17 +346,16 @@ :self-insert-table :window-table)) -(defpackage :climacs-motion-commands - (:use :clim-lisp :clim :climacs-base :climacs-buffer - :climacs-syntax :climacs-motion :climacs-gui :esa) - (:export #:define-motion-commands)) - -(defpackage :climacs-editing-commands +(defpackage :climacs-commands (:use :clim-lisp :clim :climacs-base :climacs-buffer - :climacs-syntax :climacs-motion :climacs-gui - :esa :climacs-editing :climacs-kill-ring) - (:export #:define-deletion-commands - #:define-editing-commands)) + :climacs-syntax :climacs-motion :climacs-editing + :climacs-gui :esa :climacs-kill-ring) + (:export #:define-motion-commands + #:define-deletion-commands + #:define-editing-commands) + (:documentation "This package is meant to contain Climacs' + command definitions, as well as some useful automatic + command-defining facilities.")) (defpackage :climacs-fundamental-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base --- /project/climacs/cvsroot/climacs/motion-commands.lisp 2006/06/12 19:10:58 1.1 +++ /project/climacs/cvsroot/climacs/motion-commands.lisp 2006/07/09 18:44:50 1.2 @@ -42,7 +42,7 @@ ;;; forward by N <plural>.' ;;; -(in-package :climacs-motion-commands) +(in-package :climacs-commands) (defmacro define-motion-commands (unit command-table &key noun --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/05 13:52:17 1.7 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/09 18:44:50 1.8 @@ -31,18 +31,18 @@ (in-package :climacs-lisp-syntax) ;; Movement commands. -(climacs-motion-commands:define-motion-commands expression lisp-table) -(climacs-motion-commands:define-motion-commands definition lisp-table) -(climacs-motion-commands:define-motion-commands up lisp-table +(climacs-commands:define-motion-commands expression lisp-table) +(climacs-commands:define-motion-commands definition lisp-table) +(climacs-commands:define-motion-commands up lisp-table :noun "nesting level up" :plural "levels") -(climacs-motion-commands:define-motion-commands down lisp-table +(climacs-commands:define-motion-commands down lisp-table :noun "nesting level down" :plural "levels") -(climacs-motion-commands:define-motion-commands list lisp-table) +(climacs-commands:define-motion-commands list lisp-table) -(climacs-editing-commands:define-editing-commands expression lisp-table) -(climacs-editing-commands:define-deletion-commands expression lisp-table) +(climacs-commands:define-editing-commands expression lisp-table) +(climacs-commands:define-deletion-commands expression lisp-table) (define-command (com-eval-defun :name t :command-table lisp-table) () (let* ((pane (current-window)) --- /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/07/02 15:43:48 1.2 +++ /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/07/09 18:44:50 1.3 @@ -43,7 +43,7 @@ ;;; This file also holds command definitions for other functions ;;; defined in the CLIMACS-EDITING package. -(in-package :climacs-editing-commands) +(in-package :climacs-commands) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

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

07 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv12036 Modified Files: buffer-test.lisp base-test.lisp Log Message: Updated the unit tests to be valid again, commented out a few tests that are based on now-invalid assumptions. These will become part of a new set of tests once I have time. --- /project/climacs/cvsroot/climacs/buffer-test.lisp 2005/08/04 22:07:44 1.21 +++ /project/climacs/cvsroot/climacs/buffer-test.lisp 2006/07/08 00:11:22 1.22 @@ -4,7 +4,7 @@ ;;; (cl:defpackage :climacs-tests - (:use :cl :rtest :climacs-buffer :climacs-base :automaton)) + (:use :cl :rtest :climacs-buffer :climacs-base :climacs-motion :climacs-editing :automaton)) (cl:in-package :climacs-tests) @@ -1055,7 +1055,7 @@ for i from 0 below 1000 for f = t then (not b) do (if f - (next-line m 0 100000) + (forward-line m 0 100000) (previous-line m 0 100000)) finally (return (number-of-lines b)))))) 100000) \ No newline at end of file --- /project/climacs/cvsroot/climacs/base-test.lisp 2005/08/27 22:07:45 1.16 +++ /project/climacs/cvsroot/climacs/base-test.lisp 2006/07/08 00:11:22 1.17 @@ -190,59 +190,59 @@ "climacs " 7) -(defmultitest kill-line.test-1 +(defmultitest delete-line.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (clone-mark (low-mark buffer) :left))) (setf (offset mark) 0) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) #() 0) -(defmultitest kill-line.test-2 +(defmultitest delete-line.test-2 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (clone-mark (low-mark buffer) :right))) (setf (offset mark) 0) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) #() 0) -(defmultitest kill-line.test-3 +(defmultitest delete-line.test-3 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (clone-mark (low-mark buffer) :left))) (setf (offset mark) 7) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacs" 7) -(defmultitest kill-line.test-4 +(defmultitest delete-line.test-4 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs") (let ((mark (clone-mark (low-mark buffer) :right))) (setf (offset mark) 7) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacs" 7) -(defmultitest kill-line.test-5 +(defmultitest delete-line.test-5 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (clone-mark (low-mark buffer) :left))) (setf (offset mark) 7) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacsclimacs" 7) -(defmultitest kill-line.test-6 +(defmultitest delete-line.test-6 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 "climacs climacs") (let ((mark (clone-mark (low-mark buffer) :right))) (setf (offset mark) 7) - (kill-line mark) + (delete-line mark) (values (buffer-sequence buffer 0 (size buffer)) (offset mark)))) "climacsclimacs" 7) @@ -459,16 +459,19 @@ (constituentp #\Null)) t nil nil nil nil #-sbcl nil #+sbcl t) -(defmultitest whitespacep.test-1 +(defmultitest buffer-whitespacep.test-1 (values - (not (null (whitespacep #\a))) - (not (null (whitespacep #\Newline))) - (not (null (whitespacep #\Space))) - (not (null (whitespacep #\Tab))) - (not (null (whitespacep " "))) - (not (null (whitespacep #\Null)))) + (not (null (buffer-whitespacep #\a))) + (not (null (buffer-whitespacep #\Newline))) + (not (null (buffer-whitespacep #\Space))) + (not (null (buffer-whitespacep #\Tab))) + (not (null (buffer-whitespacep " "))) + (not (null (buffer-whitespacep #\Null)))) nil t t t nil nil) +;; Words are not recognized by CLIMACS-BASE, setup syntax-aware +;; tests. Until then, these are disabled. +#|| (defmultitest forward-to-word-boundary.test-1 (let ((buffer (make-instance %%buffer))) (insert-buffer-sequence buffer 0 " climacs @@ -627,6 +630,7 @@ (climacs-base::previous-word m1) (climacs-base::previous-word m2)))) "climacs" #() "cl") +||# (defmultitest downcase-buffer-region.test-1 (let ((buffer (make-instance %%buffer))) @@ -664,16 +668,16 @@ (buffer-sequence buffer 0 (size buffer)))) "_cli mac5_") -(defmultitest downcase-word.test-1 - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 "CLI MA CS CLIMACS") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 0) - (downcase-word m 3) - (values - (buffer-sequence buffer 0 (size buffer)) - (offset m)))) - "cli ma cs CLIMACS" 9) +#+(or)(defmultitest downcase-word.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "CLI MA CS CLIMACS") + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 0) + (downcase-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "cli ma cs CLIMACS" 9) (defmultitest upcase-buffer-region.test-1 (let ((buffer (make-instance %%buffer))) @@ -711,16 +715,16 @@ (buffer-sequence buffer 0 (size buffer)))) "_CLI MAC5_") -(defmultitest upcase-word.test-1 - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 "cli ma cs climacs") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 0) - (upcase-word m 3) - (values - (buffer-sequence buffer 0 (size buffer)) - (offset m)))) - "CLI MA CS climacs" 9) +#+(or)(defmultitest upcase-word.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs climacs") + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 0) + (upcase-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "CLI MA CS climacs" 9) (defmultitest capitalize-buffer-region.test-1 (let ((buffer (make-instance %%buffer))) @@ -765,16 +769,16 @@ (buffer-sequence buffer 0 (size buffer)))) "_Cli Mac5_") -(defmultitest capitalize-word.test-1 - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 "cli ma cs climacs") - (let ((m (clone-mark (low-mark buffer) :right))) - (setf (offset m) 0) - (capitalize-word m 3) - (values - (buffer-sequence buffer 0 (size buffer)) - (offset m)))) - "Cli Ma Cs climacs" 9) +#+(or)(defmultitest capitalize-word.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "cli ma cs climacs") + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) 0) + (capitalize-word m 3) + (values + (buffer-sequence buffer 0 (size buffer)) + (offset m)))) + "Cli Ma Cs climacs" 9) (defmultitest tabify-buffer-region.test-1 (let ((buffer (make-instance %%buffer))) @@ -960,7 +964,7 @@ (insert-buffer-sequence buffer 0 "climacs climacs climacs climacs") (let ((m (clone-mark (low-mark buffer) :right))) (setf (offset m) 25) - (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8) + (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 t) (values (offset m) (buffer-sequence buffer 0 (size buffer))))) @@ -973,7 +977,7 @@ (insert-buffer-sequence buffer 0 "climacs climacs climacs climacs") (let ((m (clone-mark (low-mark buffer) :right))) (setf (offset m) 25) - (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 nil) + (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 t nil) (values (offset m) (buffer-sequence buffer 0 (size buffer))))) @@ -986,7 +990,7 @@ (insert-buffer-sequence buffer 0 "climacs climacs climacs climacs") (let ((m (clone-mark (low-mark buffer) :left))) (setf (offset m) 25) - (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8) + (fill-line m #'(lambda (m) (declare (ignore m)) 8) 10 8 t) (values (offset m) (buffer-sequence buffer 0 (size buffer))))) @@ -1012,7 +1016,7 @@ (insert-buffer-sequence buffer 0 "c l i m a c s") (let ((m (clone-mark (low-mark buffer) :right))) (setf (offset m) 1) - (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8) + (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8 t) (values (offset m) (buffer-sequence buffer 0 (size buffer))))) @@ -1023,7 +1027,7 @@ (insert-buffer-sequence buffer 0 "c l i m a c s") (let ((m (clone-mark (low-mark buffer) :right))) (setf (offset m) 1) - (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8 nil) + (fill-line m #'(lambda (m) (declare (ignore m)) 8) 0 8 t nil) (values (offset m) (buffer-sequence buffer 0 (size buffer))))) @@ -1253,26 +1257,26 @@ (offset m))) 3) -(defmultitest buffer-search-word-forward.test-1 - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 " +#+(or)(defmultitest buffer-search-word-forward.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 " climacs") - (values - (climacs-base::buffer-search-word-forward buffer 0 "climacs") - (climacs-base::buffer-search-word-forward buffer 3 "climacs") - (climacs-base::buffer-search-word-forward buffer 0 "clim") - (climacs-base::buffer-search-word-forward buffer 5 "macs") - (climacs-base::buffer-search-word-forward buffer 0 ""))) - 2 nil nil nil 0) - -(defmultitest buffer-search-word-backward.test-1 - (let ((buffer (make-instance %%buffer))) - (insert-buffer-sequence buffer 0 "climacs + (values + (climacs-base::buffer-search-word-forward buffer 0 "climacs") + (climacs-base::buffer-search-word-forward buffer 3 "climacs") + (climacs-base::buffer-search-word-forward buffer 0 "clim") + (climacs-base::buffer-search-word-forward buffer 5 "macs") + (climacs-base::buffer-search-word-forward buffer 0 ""))) + 2 nil nil nil 0) + +#+(or)(defmultitest buffer-search-word-backward.test-1 + (let ((buffer (make-instance %%buffer))) + (insert-buffer-sequence buffer 0 "climacs ") - (values - (climacs-base::buffer-search-word-backward buffer 8 "climacs") - (climacs-base::buffer-search-word-backward buffer 5 "climacs") - (climacs-base::buffer-search-word-backward buffer 4 "clim") - (climacs-base::buffer-search-word-backward buffer 8 "macs") - (climacs-base::buffer-search-word-backward buffer 8 ""))) - 0 nil nil nil 8) \ No newline at end of file + (values + (climacs-base::buffer-search-word-backward buffer 8 "climacs") + (climacs-base::buffer-search-word-backward buffer 5 "climacs") + (climacs-base::buffer-search-word-backward buffer 4 "clim") + (climacs-base::buffer-search-word-backward buffer 8 "macs") + (climacs-base::buffer-search-word-backward buffer 8 ""))) + 0 nil nil nil 8) \ No newline at end of file

1 0

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

07 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv10216 Modified Files: packages.lisp editing.lisp base.lisp Log Message: A number of major changes, involving moving a bit of stuff back from editing.lisp (and CLIMACS EDITING) to base.lisp (and CLIMACS-BASE). * Reintroduced primitive, non-syntax-aware `previous-line' and `next-line' generic functions. * Moved `open-line' back to base.lisp and added a primitive `delete-line' function for deleting lines at a given mark. * Moved most of the character casing, tabyfying and indentation code back from editing.lisp to base.lisp. I'm still not sure it belongs there, but it will have to do for now. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/07/03 15:46:53 1.101 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/07 23:59:38 1.102 @@ -70,12 +70,15 @@ (:export #:do-buffer-region #:do-buffer-region-lines #:previous-line #:next-line + #:open-line + #:delete-line #:empty-line-p #:line-indentation #:buffer-display-column #:number-of-lines-in-region #:constituentp #:just-n-spaces + #:buffer-whitespacep #:forward-word #:backward-word #:buffer-region-case #:input-from-stream #:output-to-stream @@ -85,6 +88,11 @@ #:buffer-re-search-forward #:buffer-re-search-backward #:search-forward #:search-backward #:re-search-forward #:re-search-backward + #:downcase-buffer-region #:downcase-region + #:upcase-buffer-region #:upcase-region + #:capitalize-buffer-region #:capitalize-region + #:tabify-region #:untabify-region + #:indent-line #:delete-indentation #:*kill-ring*)) (defpackage :climacs-abbrev @@ -231,7 +239,6 @@ (:use :clim-lisp :clim :climacs-base :climacs-buffer :climacs-syntax :climacs-motion :climacs-pane :climacs-kill-ring) (:export #:transpose-objects - #:open-line ;; Lines #:forward-delete-line #:backward-delete-line @@ -271,15 +278,10 @@ #:forward-kill-sentence #:backward-kill-sentence #:transpose-sentences - #:downcase-buffer-region #:downcase-region - #:upcase-buffer-region #:upcase-region - #:downcase-word #:upcase-word - #:capitalize-buffer-region #:capitalize-region - #:capitalize-word - #:tabify-region #:untabify-region - #:indent-line + + #:downcase-word #:upcase-word #:capitalize-word + #:indent-region - #:delete-indentation #:fill-line #:fill-region)) --- /project/climacs/cvsroot/climacs/editing.lisp 2006/06/12 19:10:58 1.1 +++ /project/climacs/cvsroot/climacs/editing.lisp 2006/07/07 23:59:38 1.2 @@ -211,17 +211,6 @@ ;;; ;;; Line editing -(defmethod open-line ((mark left-sticky-mark) &optional (count 1)) - "Create a new line in a buffer after the mark." - (loop repeat count - do (insert-object mark #\Newline))) - -(defmethod open-line ((mark right-sticky-mark) &optional (count 1)) - "Create a new line in a buffer after the mark." - (loop repeat count - do (insert-object mark #\Newline) - (decf (offset mark)))) - (define-edit-fns line) (define-edit-fns line-start) @@ -280,38 +269,6 @@ ;;; ;;; Character case -;;; I'd rather have update-buffer-range methods spec. on buffer for this, -;;; for performance and history-size reasons --amb -(defun downcase-buffer-region (buffer offset1 offset2) - (do-buffer-region (object offset buffer offset1 offset2) - (when (and (constituentp object) (upper-case-p object)) - (setf object (char-downcase object))))) - -(defgeneric downcase-region (mark1 mark2) - (:documentation "Convert all characters after mark1 and before mark2 to -lowercase. 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 downcase-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod downcase-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod downcase-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark1) offset1 offset2))) - (defun downcase-word (mark &optional (n 1)) "Convert the next N words to lowercase, leaving mark after the last word." (let ((syntax (syntax (buffer mark)))) @@ -321,36 +278,6 @@ (forward-word mark syntax 1 nil) (downcase-region offset mark))))) -(defun upcase-buffer-region (buffer offset1 offset2) - (do-buffer-region (object offset buffer offset1 offset2) - (when (and (constituentp object) (lower-case-p object)) - (setf object (char-upcase object))))) - -(defgeneric upcase-region (mark1 mark2) - (:documentation "Convert all characters after mark1 and before mark2 to -uppercase. 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 upcase-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod upcase-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod upcase-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark1) offset1 offset2))) - (defun upcase-word (mark syntax &optional (n 1)) "Convert the next N words to uppercase, leaving mark after the last word." (loop repeat n @@ -359,42 +286,6 @@ (forward-word mark syntax 1 nil) (upcase-region offset mark)))) -(defun capitalize-buffer-region (buffer offset1 offset2) - (let ((previous-char-constituent-p nil)) - (do-buffer-region (object offset buffer offset1 offset2) - (when (constituentp object) - (if previous-char-constituent-p - (when (upper-case-p object) - (setf object (char-downcase object))) - (when (lower-case-p object) - (setf object (char-upcase object))))) - (setf previous-char-constituent-p (constituentp object))))) - -(defgeneric capitalize-region (mark1 mark2) - (:documentation "Capitalize all words after mark1 and before 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 capitalize-region ((mark1 mark) (mark2 mark)) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark1) offset1 offset2))) - -(defmethod capitalize-region ((offset1 integer) (mark2 mark)) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark2) offset1 offset2))) - -(defmethod capitalize-region ((mark1 mark) (offset2 integer)) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark1) offset1 offset2))) - (defun capitalize-word (mark &optional (n 1)) "Capitalize the next N words, leaving mark after the last word." (let ((syntax (syntax (buffer mark)))) @@ -406,134 +297,8 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Tabify - -(defun tabify-buffer-region (buffer offset1 offset2 tab-width) - (flet ((looking-at-spaces (buffer offset count) - (loop for i from offset - repeat count - unless (char= (buffer-object buffer i) #\Space) - return nil - finally (return t)))) - (loop for offset = offset1 then (1+ offset) - until (>= offset offset2) - do (let* ((column (buffer-display-column - buffer offset tab-width)) - (count (- tab-width (mod column tab-width)))) - (when (looking-at-spaces buffer offset count) - (finish-output) - (delete-buffer-range buffer offset count) - (insert-buffer-object buffer offset #\Tab) - (decf offset2 (1- count))))))) - -(defgeneric tabify-region (mark1 mark2 tab-width) - (:documentation "Replace sequences of tab-width spaces with tabs -in the region delimited by mark1 and mark2.")) - -(defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) - -(defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defun untabify-buffer-region (buffer offset1 offset2 tab-width) - (loop for offset = offset1 then (1+ offset) - until (>= offset offset2) - when (char= (buffer-object buffer offset) #\Tab) - 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 - do (insert-buffer-object buffer offset #\Space)) - (incf offset (1- count)) - (incf offset2 (1- count))))) - -(defgeneric untabify-region (mark1 mark2 tab-width) - (:documentation "Replace tabs with tab-width spaces in the region -delimited by mark1 and mark2.")) - -(defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width) - (assert (eq (buffer mark1) (buffer mark2))) - (let ((offset1 (offset mark1)) - (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -(defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width) - (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) - -(defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width) - (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Indentation -(defgeneric indent-line (mark indentation tab-width) - (:documentation "Indent the line containing mark with indentation -spaces. Use tabs and spaces if tab-width is not nil, otherwise use -spaces only.")) - -(defun indent-line* (mark indentation tab-width left) - (let ((mark2 (clone-mark mark))) - (beginning-of-line mark2) - (loop until (end-of-buffer-p mark2) - as object = (object-after mark2) - while (or (eql object #\Space) (eql object #\Tab)) - do (delete-range mark2 1)) - (loop until (zerop indentation) - do (cond ((and tab-width (>= indentation tab-width)) - (insert-object mark2 #\Tab) - (when left ; spaces must follow tabs - (forward-object mark2)) - (decf indentation tab-width)) - (t - (insert-object mark2 #\Space) - (decf indentation)))))) - -(defmethod indent-line ((mark left-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width t)) - -(defmethod indent-line ((mark right-sticky-mark) indentation tab-width) - (indent-line* mark indentation tab-width nil)) - -(defun delete-indentation (mark syntax) - (beginning-of-line mark) - (unless (beginning-of-buffer-p mark) - (delete-range mark -1) - (loop until (end-of-buffer-p mark) - while (whitespacep syntax (object-after mark)) - do (delete-range mark 1)) - (loop until (beginning-of-buffer-p mark) - while (whitespacep syntax (object-before mark)) - do (delete-range mark -1)) - (when (and (not (beginning-of-buffer-p mark)) - (constituentp (object-before mark))) - (insert-object mark #\Space)))) - (defun indent-region (pane mark1 mark2) "Indent all lines in the region delimited by `mark1' and `mark2' according to the rules of the active syntax in `pane'." --- /project/climacs/cvsroot/climacs/base.lisp 2006/07/03 15:46:53 1.53 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/07 23:59:38 1.54 @@ -63,6 +63,81 @@ (unless (end-of-buffer-p ,mark-sym) (forward-object ,mark-sym))))))) +(defgeneric previous-line (mark &optional column count) + (:documentation "Move a mark up `count' lines conserving + horizontal position. This is a relatively low-level function, + you should probably use `climacs-motion:backward-line' + instead.")) + +(defmethod previous-line (mark &optional column (count 1)) + (unless column + (setf column (column-number mark))) + (loop repeat count + do (beginning-of-line mark) + until (beginning-of-buffer-p mark) + do (backward-object mark)) + (end-of-line mark) + (when (> (column-number mark) column) + (beginning-of-line mark) + (incf (offset mark) column))) + +(defmethod previous-line ((mark p-line-mark-mixin) &optional column (count 1)) + (unless column + (setf column (column-number mark))) + (let* ((line (line-number mark)) + (goto-line (max 0 (- line count)))) + (setf (offset mark) + (+ column (buffer-line-offset (buffer mark) goto-line))))) + +(defgeneric next-line (mark &optional column count) + (:documentation "Move a mark down `count' lines conserving + horizontal position. This is a relatively low-level function, + you should probably use `climacs-motion:forward-line' + instead.")) + +(defmethod next-line (mark &optional column (count 1)) + (unless column + (setf column (column-number mark))) + (loop repeat count + do (end-of-line mark) + until (end-of-buffer-p mark) + do (forward-object mark)) + (end-of-line mark) + (when (> (column-number mark) column) + (beginning-of-line mark) + (incf (offset mark) column))) + +(defmethod next-line ((mark p-line-mark-mixin) &optional column (count 1)) + (unless column + (setf column (column-number mark))) + (let* ((line (line-number mark)) + (goto-line (min (number-of-lines (buffer mark)) + (+ line count)))) + (setf (offset mark) + (+ column (buffer-line-offset (buffer mark) goto-line))))) + +(defgeneric open-line (mark &optional count) + (:documentation "Create a new line in a buffer after the mark.")) + +(defmethod open-line ((mark left-sticky-mark) &optional (count 1)) + (loop repeat count + do (insert-object mark #\Newline))) + +(defmethod open-line ((mark right-sticky-mark) &optional (count 1)) + (loop repeat count + do (insert-object mark #\Newline) + (decf (offset mark)))) + +(defun delete-line (mark &optional (count 1)) + "Delete `count' lines at `mark' from the buffer." + (dotimes (i count) + (if (end-of-line-p mark) + (unless (end-of-buffer-p mark) + (delete-range mark)) + (let ((offset (offset mark))) + (end-of-line mark) + (delete-region offset mark))))) + (defun empty-line-p (mark) "Check whether the mark is in an empty line." (and (beginning-of-line-p mark) (end-of-line-p mark))) @@ -381,6 +456,238 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Character case + +;;; I'd rather have update-buffer-range methods spec. on buffer for this, +;;; for performance and history-size reasons --amb +(defun downcase-buffer-region (buffer offset1 offset2) + (do-buffer-region (object offset buffer offset1 offset2) + (when (and (constituentp object) (upper-case-p object)) + (setf object (char-downcase object))))) + +(defgeneric downcase-region (mark1 mark2) + (:documentation "Convert all characters after mark1 and before mark2 to +lowercase. 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 downcase-region ((mark1 mark) (mark2 mark)) + (assert (eq (buffer mark1) (buffer mark2))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (downcase-buffer-region (buffer mark1) offset1 offset2))) + +(defmethod downcase-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (downcase-buffer-region (buffer mark2) offset1 offset2))) + +(defmethod downcase-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (downcase-buffer-region (buffer mark1) offset1 offset2))) + +(defun upcase-buffer-region (buffer offset1 offset2) + (do-buffer-region (object offset buffer offset1 offset2) + (when (and (constituentp object) (lower-case-p object)) + (setf object (char-upcase object))))) + +(defgeneric upcase-region (mark1 mark2) + (:documentation "Convert all characters after mark1 and before mark2 to +uppercase. 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 upcase-region ((mark1 mark) (mark2 mark)) + (assert (eq (buffer mark1) (buffer mark2))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (upcase-buffer-region (buffer mark1) offset1 offset2))) + +(defmethod upcase-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (upcase-buffer-region (buffer mark2) offset1 offset2))) + +(defmethod upcase-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (upcase-buffer-region (buffer mark1) offset1 offset2))) + +(defun capitalize-buffer-region (buffer offset1 offset2) + (let ((previous-char-constituent-p nil)) + (do-buffer-region (object offset buffer offset1 offset2) + (when (constituentp object) + (if previous-char-constituent-p + (when (upper-case-p object) + (setf object (char-downcase object))) + (when (lower-case-p object) + (setf object (char-upcase object))))) + (setf previous-char-constituent-p (constituentp object))))) + +(defgeneric capitalize-region (mark1 mark2) + (:documentation "Capitalize all words after mark1 and before 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 capitalize-region ((mark1 mark) (mark2 mark)) + (assert (eq (buffer mark1) (buffer mark2))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (capitalize-buffer-region (buffer mark1) offset1 offset2))) + +(defmethod capitalize-region ((offset1 integer) (mark2 mark)) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (capitalize-buffer-region (buffer mark2) offset1 offset2))) + +(defmethod capitalize-region ((mark1 mark) (offset2 integer)) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (capitalize-buffer-region (buffer mark1) offset1 offset2))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Tabify + +(defun tabify-buffer-region (buffer offset1 offset2 tab-width) + (flet ((looking-at-spaces (buffer offset count) + (loop for i from offset + repeat count + unless (char= (buffer-object buffer i) #\Space) + return nil + finally (return t)))) + (loop for offset = offset1 then (1+ offset) + until (>= offset offset2) + do (let* ((column (buffer-display-column + buffer offset tab-width)) + (count (- tab-width (mod column tab-width)))) + (when (looking-at-spaces buffer offset count) + (finish-output) + (delete-buffer-range buffer offset count) + (insert-buffer-object buffer offset #\Tab) + (decf offset2 (1- count))))))) + +(defgeneric tabify-region (mark1 mark2 tab-width) + (:documentation "Replace sequences of tab-width spaces with tabs +in the region delimited by mark1 and mark2.")) + +(defmethod tabify-region ((mark1 mark) (mark2 mark) tab-width) + (assert (eq (buffer mark1) (buffer mark2))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + +(defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) + +(defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + +(defun untabify-buffer-region (buffer offset1 offset2 tab-width) + (loop for offset = offset1 then (1+ offset) + until (>= offset offset2) + when (char= (buffer-object buffer offset) #\Tab) + 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 + do (insert-buffer-object buffer offset #\Space)) + (incf offset (1- count)) + (incf offset2 (1- count))))) + +(defgeneric untabify-region (mark1 mark2 tab-width) + (:documentation "Replace tabs with tab-width spaces in the region +delimited by mark1 and mark2.")) + +(defmethod untabify-region ((mark1 mark) (mark2 mark) tab-width) + (assert (eq (buffer mark1) (buffer mark2))) + (let ((offset1 (offset mark1)) + (offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + +(defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width) + (let ((offset2 (offset mark2))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) + +(defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width) + (let ((offset1 (offset mark1))) + (when (> offset1 offset2) + (rotatef offset1 offset2)) + (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Indentation + +(defgeneric indent-line (mark indentation tab-width) + (:documentation "Indent the line containing mark with indentation +spaces. Use tabs and spaces if tab-width is not nil, otherwise use +spaces only.")) + +(defun indent-line* (mark indentation tab-width left) + (let ((mark2 (clone-mark mark))) + (beginning-of-line mark2) + (loop until (end-of-buffer-p mark2) + as object = (object-after mark2) + while (or (eql object #\Space) (eql object #\Tab)) + do (delete-range mark2 1)) + (loop until (zerop indentation) + do (cond ((and tab-width (>= indentation tab-width)) + (insert-object mark2 #\Tab) + (when left ; spaces must follow tabs + (forward-object mark2)) + (decf indentation tab-width)) + (t + (insert-object mark2 #\Space) + (decf indentation)))))) + +(defmethod indent-line ((mark left-sticky-mark) indentation tab-width) + (indent-line* mark indentation tab-width t)) + +(defmethod indent-line ((mark right-sticky-mark) indentation tab-width) + (indent-line* mark indentation tab-width nil)) + +(defun delete-indentation (mark) + (beginning-of-line mark) + (unless (beginning-of-buffer-p mark) + (delete-range mark -1) + (loop until (end-of-buffer-p mark) + while (buffer-whitespacep (object-after mark)) + do (delete-range mark 1)) + (loop until (beginning-of-buffer-p mark) + while (buffer-whitespacep (object-before mark)) + do (delete-range mark -1)) + (when (and (not (beginning-of-buffer-p mark)) + (constituentp (object-before mark))) + (insert-object mark #\Space)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Kill ring -(defvar *kill-ring* (make-instance 'kill-ring :max-size 7)) \ No newline at end of file +(defvar *kill-ring* (make-instance 'kill-ring :max-size 7))

1 0

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

07 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv6679 Modified Files: syntax.lisp Log Message: Make `whitespacep' just return T on success. --- /project/climacs/cvsroot/climacs/syntax.lisp 2006/06/12 19:10:58 1.66 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/07/07 23:23:10 1.67 @@ -742,7 +742,8 @@ (:method (syntax obj) nil) (:method (syntax (obj character)) - (member obj '(#\Space #\Tab #\Newline #\Page #\Return)))) + (when (member obj '(#\Space #\Tab #\Newline #\Page #\Return)) + t))) (defgeneric page-delimiter (syntax) (:documentation "Return the object sequence used as a page

1 0

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

07 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv17361 Removed Files: colors.lisp Log Message: Removed colors.lisp, it's in ESA now and no longer used in Climacs.

1 0

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

06 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv5211 Modified Files: pane.lisp Log Message: Protect the undo history, even if an error is signalled somewhere. --- /project/climacs/cvsroot/climacs/pane.lisp 2006/05/14 20:35:44 1.43 +++ /project/climacs/cvsroot/climacs/pane.lisp 2006/07/06 17:31:50 1.44 @@ -107,16 +107,16 @@ (let ((buffer-var (gensym))) `(let ((,buffer-var ,buffer)) (setf (undo-accumulate ,buffer-var) '()) - ,@body - (cond ((null (undo-accumulate ,buffer-var)) nil) - ((null (cdr (undo-accumulate ,buffer-var))) - (add-undo (car (undo-accumulate ,buffer-var)) - (undo-tree ,buffer-var))) - (t - (add-undo (make-instance 'compound-record - :buffer ,buffer-var - :records (undo-accumulate ,buffer-var)) - (undo-tree ,buffer-var))))))) + (unwind-protect (progn ,@body) + (cond ((null (undo-accumulate ,buffer-var)) nil) + ((null (cdr (undo-accumulate ,buffer-var))) + (add-undo (car (undo-accumulate ,buffer-var)) + (undo-tree ,buffer-var))) + (t + (add-undo (make-instance 'compound-record + :buffer ,buffer-var + :records (undo-accumulate ,buffer-var)) + (undo-tree ,buffer-var)))))))) (defmethod flip-undo-record :around ((record climacs-undo-record)) (with-slots (buffer) record

1 0

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

05 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25453 Modified Files: lisp-syntax.lisp lisp-syntax-commands.lisp climacs.asd Added Files: lisp-syntax-swank.lisp Log Message: Added conditionally loaded Swine-functionality to the Lisp syntax. Please report any breakage. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/13 14:58:37 1.88 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/05 13:52:17 1.89 @@ -24,6 +24,30 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Convenience functions and macros: + +(defun unlisted (obj) + (if (listp obj) + (first obj) + obj)) + +(defun listed (obj) + (if (listp obj) + obj + (list obj))) + +(defun usable-package (package-designator) + "Return a usable package based on `package-designator'." + (or (find-package package-designator) + *package*)) + +(defmacro evaluating-interactively (&body body) + `(handler-case (progn ,@body) + (end-of-file () + (esa:display-message "Unbalanced parentheses in form.")))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; The command table. (make-command-table 'lisp-table @@ -57,7 +81,12 @@ :documentation "The package specified in the attribute line (may be overridden - by (in-package) forms).")) + by (in-package) forms).") + (image :accessor image + :initform nil + :documentation "An image object (or NIL) that + determines where and how Lisp code in the buffer of the + syntax should be run.")) (:name "Lisp") (:pathname-types "lisp" "lsp" "cl") (:command-table lisp-table)) @@ -80,6 +109,106 @@ (format nil "Lisp~@[:~(~A~)~]" (package-name (package-at-mark syntax (point pane))))) +(defgeneric default-image () + (:documentation "The default image for when the current syntax + does not mandate anything itself (for example if it is not a + Lisp syntax).") + (:method () + t)) + +(defgeneric get-usable-image (syntax) + (:documentation "Get usable image object from `syntax'.") + (:method (syntax) + (default-image)) + (:method ((syntax lisp-syntax)) + (or (image syntax) + (default-image)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Swank interface functions: + +(defgeneric eval-string-for-climacs (image string package) + (:documentation "Evaluate `string' in `package'. A single value +is returned: The result of evaluating `string'.") + (:method (image string package) + (let ((*package* package)) + (eval-form-for-climacs image (read-from-string string))))) + +(defgeneric eval-form-for-climacs (image form) + (:documentation "Evaluate `string' in `package'. A single value +is returned: The result of evaluating `string'.") + (:method (image form) + (declare (ignore image)) + (eval form))) + +(defgeneric compile-string-for-climacs (image string package buffer buffer-mark) + (:documentation "Compile and evaluate `string' in +`package'. Two values are returned: The result of evaluating +`string' and a list of compiler notes. `Buffer' and `buffer-mark' +will be used for hyperlinking the compiler notes to the source +code.") + (:method (image string package buffer buffer-mark) + (declare (ignore image string package buffer buffer-mark)) + (error "Backend insufficient for this operation"))) + +(defgeneric compile-form-for-climacs (image form buffer buffer-mark) + (:documentation "Compile and evaluate `form', which must be a +valid Lisp form. Two values are returned: The result of +evaluating `string' and a list of compiler notes. `Buffer' and +`buffer-mark' will be used for hyperlinking the compiler notes to +the source code.") + (:method (image form buffer buffer-mark) + (compile-string-for-climacs image + (write-to-string form) + *package* buffer buffer-mark))) + +(defgeneric compile-file-for-climacs (image filepath package &optional load-p) + (:documentation "Compile the file at `filepath' in +`package'. If `load-p' is non-NIL, also load the file at +`filepath'. Two values will be returned: the result of compiling +the file and a list of compiler notes.") + (:method (image filepath package &optional load-p) + (declare (ignore image filepath package load-p)) + (error "Backend insufficient for this operation"))) + +(defgeneric macroexpand-for-climacs (image form &optional full-p) + (:documentation "Macroexpand `form' and return result.") + (:method (image form &optional full-p) + (declare (ignore image)) + (funcall (if full-p + #'macroexpand + #'macroexpand-1) + form))) + +(defgeneric find-definitions-for-climacs (image symbol) + (:documentation "Return list of definitions for `symbol'.") + (:method (image symbol) + (declare (ignore image symbol)))) + +(defgeneric get-class-keyword-parameters (image class) + (:documentation "Get a list of keyword parameters (possibly +along with any default values) that can be used in a +`make-instance' form for `class'.") + (:method (image class) + (declare (ignore image class)))) + +(defgeneric arglist (image symbol) + (:documentation "Get plain arglist for symbol.") + (:method (image symbol) + (declare (ignore image symbol)))) + +(defgeneric simple-completions (image string default-package) + (:documentation "Return a list of simple symbol-completions for +`string' in `default-package'.") + (:method (image string default-package) + (declare (ignore image string default-package)))) + +(defgeneric fuzzy-completions (image symbol-name default-package &optional limit) + (:documentation "Return a list of fuzzy completions for `symbol-name'.") + (:method (image symbol-name default-package &optional limit) + (declare (ignore image symbol-name default-package limit)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; lexer @@ -1416,6 +1545,34 @@ form)))) (unwrap-form (expression-at-mark mark syntax)))) +(defun this-form (mark syntax) + "Return a form at mark. This function defines which + forms the COM-FOO-this commands affect." + (or (form-around syntax (offset mark)) + (form-before syntax (offset mark)))) + +(defun preceding-form (mark syntax) + "Return a form at mark." + (or (form-before syntax (offset mark)) + (form-around syntax (offset mark)))) + +(defun text-of-definition-at-mark (mark syntax) + "Return the text of the definition at mark." + (let ((definition (definition-at-mark mark syntax))) + (buffer-substring (buffer mark) + (start-offset definition) + (end-offset definition)))) + +(defun text-of-expression-at-mark (mark syntax) + "Return the text of the expression at mark." + (let ((expression (expression-at-mark mark syntax))) + (token-string syntax expression))) + +(defun symbol-name-at-mark (mark syntax) + "Return the text of the symbol at mark." + (let ((token (symbol-at-mark mark syntax))) + (when token (token-string syntax token)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display @@ -1462,7 +1619,7 @@ (let ((space-width (space-width pane)) (tab-width (tab-width pane))) (loop while (< start end) - do (ecase (buffer-object buffer start) + do (case (buffer-object buffer start) (#\Newline (terpri pane) (setf (aref *cursor-positions* (incf *current-line*)) (multiple-value-bind (x y) (stream-cursor-position pane) @@ -1826,16 +1983,16 @@ (defmethod backward-one-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-before syntax (offset mark)) (form-around syntax (offset mark))))) - (if potential-form - (setf (offset mark) (start-offset potential-form)) - (error 'no-expression)))) + (when (and (not (null potential-form)) + (not (= (offset mark) (start-offset potential-form)))) + (setf (offset mark) (start-offset potential-form))))) (defmethod forward-one-expression (mark (syntax lisp-syntax)) (let ((potential-form (or (form-after syntax (offset mark)) (form-around syntax (offset mark))))) - (if potential-form - (setf (offset mark) (end-offset potential-form)) - (error 'no-expression)))) + (when (and (not (null potential-form)) + (not (= (offset mark) (end-offset potential-form)))) + (setf (offset mark) (end-offset potential-form))))) (defgeneric forward-one-list (mark syntax) (:documentation @@ -1917,8 +2074,9 @@ (loop for form in (children stack-top) when (and (mark<= (start-offset form) mark) (mark<= mark (end-offset form))) - do (return (eval (read-from-string - (token-string syntax form))))))) + do (return (eval-form-for-climacs + (get-usable-image syntax) + (token-to-object syntax form :read t)))))) (defmethod backward-one-definition (mark (syntax lisp-syntax)) (with-slots (stack-top) syntax @@ -2139,7 +2297,7 @@ (flet ((act () (with-syntax-package syntax (start-offset token) (syntax-package) - (let ((*package* syntax-package)) + (let ((*package* (or package syntax-package))) (cond (read (read-from-string (token-string syntax token))) (quote @@ -2350,11 +2508,25 @@ (defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) (if (null (cdr path)) ;; top level - (if (= (car path) 2) - ;; indent like first child - (values (elt-noncomment (children tree) 1) 0) - ;; indent like second child - (values (elt-noncomment (children tree) 2) 0)) + (let* ((arglist (when (fboundp symbol) (arglist (get-usable-image syntax) symbol))) + (body-or-rest-pos (or (position '&body arglist) + (position '&rest arglist)))) + (if (and (or (macro-function symbol) + (special-operator-p symbol)) + (and (not (null body-or-rest-pos)) + (plusp body-or-rest-pos))) + ;; macro-form with "interesting" arguments. + (if (>= (- (car path) 2) body-or-rest-pos) + ;; &body arg. + (values (elt-noncomment (children tree) 1) 1) + ;; non-&body-arg. + (values (elt-noncomment (children tree) 1) 3)) + ;; normal form. + (if (= (car path) 2) + ;; indent like first child + (values (elt-noncomment (children tree) 1) 0) + ;; indent like second child + (values (elt-noncomment (children tree) 2) 0)))) ;; inside a subexpression (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) @@ -2607,3 +2779,1002 @@ (defmethod uncomment-region ((syntax lisp-syntax) mark1 mark2) (line-uncomment-region syntax mark1 mark2)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Swine + +;;; Compiler note hyperlinking code + +(defun make-compiler-note (note-list) + (let ((severity (getf note-list :severity)) + (message (getf note-list :message)) + (location (getf note-list :location)) + (references (getf note-list :references)) + (short-message (getf note-list :short-message))) + (make-instance + (ecase severity + (:error 'error-compiler-note) + (:read-error 'read-error-compiler-note) + (:warning 'warning-compiler-note) + (:style-warning 'style-warning-compiler-note) + (:note 'note-compiler-note)) + :message message :location location + :references references :short-message short-message))) + +(defclass compiler-note () + ((message :initarg :message :initform nil :accessor message) + (location :initarg :location :initform nil :accessor location) + (references :initarg :references :initform nil :accessor references) + (short-message :initarg :short-message :initform nil :accessor short-message)) + (:documentation "The base for all compiler-notes.")) + +(defclass error-compiler-note (compiler-note) ()) + +(defclass read-error-compiler-note (compiler-note) ()) + +(defclass warning-compiler-note (compiler-note) ()) + +(defclass style-warning-compiler-note (compiler-note) ()) + +(defclass note-compiler-note (compiler-note) ()) + +(defclass location ()() + (:documentation "The base for all locations.")) + +(defclass error-location (location) + ((error-message :initarg :error-message :accessor error-message))) + +(defclass actual-location (location) + ((source-position :initarg :position :accessor source-position) + (snippet :initarg :snippet :accessor snippet :initform nil)) + (:documentation "The base for all non-error locations.")) + +(defclass buffer-location (actual-location) + ((buffer-name :initarg :buffer :accessor buffer-name))) + +(defclass file-location (actual-location) + ((file-name :initarg :file :accessor file-name))) + +(defclass source-location (actual-location) + ((source-form :initarg :source-form :accessor source-form))) + +(defclass basic-position () () + (:documentation "The base for all positions.")) + +(defclass char-position (basic-position) + ((char-position :initarg :position :accessor char-position) + (align-p :initarg :align-p :initform nil :accessor align-p))) + +(defun make-char-position (position-list) + (make-instance 'char-position :position (second position-list) + :align-p (third position-list))) + +(defclass line-position (basic-position) + ((start-line :initarg :line :accessor start-line) + (end-line :initarg :end-line :initform nil :accessor end-line))) + +(defun make-line-position (position-list) + (make-instance 'line-position :line (second position-list) + :end-line (third position-list))) + +(defclass function-name-position (basic-position) + ((function-name :initarg :function-name))) + +(defun make-function-name-position (position-list) + (make-instance 'function-name-position :function-name (second position-list))) + +(defclass source-path-position (basic-position) + ((path :initarg :source-path :accessor path) + (start-position :initarg :start-position :accessor start-position))) + +(defun make-source-path-position (position-list) + (make-instance 'source-path-position :source-path (second position-list) + :start-position (third position-list))) + +(defclass text-anchored-position (basic-position) + ((start :initarg :text-anchored :accessor start) + (text :initarg :text :accessor text) + (delta :initarg :delta :accessor delta))) + +(defun make-text-anchored-position (position-list) + (make-instance 'text-anchored-position :text-anchored (second position-list) + :text (third position-list) + :delta (fourth position-list))) + +(defclass method-position (basic-position) + ((name :initarg :method :accessor name) + (specializers :initarg :specializers :accessor specializers) + (qualifiers :initarg :qualifiers :accessor qualifiers))) + +(defun make-method-position (position-list) + (make-instance 'method-position :method (second position-list) + :specializers (third position-list) + :qualifiers (last position-list))) + +(defun make-location (location-list) + (ecase (first location-list) + (:error (make-instance 'error-location :error-message (second location-list))) + (:location + (destructuring-bind (l buf pos hints) location-list + (declare (ignore l)) + (let ((location + (apply #'make-instance + (ecase (first buf) + (:file 'file-location) + (:buffer 'buffer-location) [876 lines skipped] --- /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/06/12 19:10:58 1.6 +++ /project/climacs/cvsroot/climacs/lisp-syntax-commands.lisp 2006/07/05 13:52:17 1.7 @@ -96,6 +96,209 @@ (loop repeat (- count) do (backward-expression mark syntax))) (climacs-editing:indent-region pane (clone-mark point) mark))) +(define-command (com-eval-last-expression :name t :command-table lisp-table) + ((insertp 'boolean :prompt "Insert?")) + "Evaluate the expression before point in the local Lisp image." + (let* ((syntax (syntax (buffer (current-window)))) + (mark (point (current-window))) + (token (form-before syntax (offset mark)))) + (if token + (with-syntax-package syntax mark (package) + (let ((*package* package)) + (climacs-gui::com-eval-expression + (token-to-object syntax token :read t) + insertp))) + (esa:display-message "Nothing to evaluate.")))) + +(define-command (com-macroexpand-1 :name t :command-table lisp-table) + () + "Macroexpand-1 the expression at point. + +The expanded expression will be displayed in a +\"*Macroexpansion*\"-buffer." + (let* ((syntax (syntax (buffer (current-window)))) + (token (expression-at-mark (point (current-window)) syntax))) + (if token + (macroexpand-token syntax token) + (esa:display-message "Nothing to expand at point.")))) + +(define-command (com-macroexpand-all :name t :command-table lisp-table) + () + "Completely macroexpand the expression at point. + +The expanded expression will be displayed in a +\"*Macroexpansion*\"-buffer." + (let* ((syntax (syntax (buffer (current-window)))) + (token (expression-at-mark (point (current-window)) syntax))) + (if token + (macroexpand-token syntax token t) + (esa:display-message "Nothing to expand at point.")))) + +(define-command (com-eval-region :name t :command-table lisp-table) + () + "Evaluate the current region." + (let ((mark (mark (current-window))) + (point (point (current-window)))) + (when (mark> mark point) + (rotatef mark point)) + (evaluating-interactively + (eval-region mark point + (syntax (buffer (current-window))))))) + +(define-command (com-compile-definition :name t :command-table lisp-table) + () + "Compile and load definition at point." + (evaluating-interactively + (compile-definition-interactively (point (current-window)) + (syntax (buffer (current-window)))))) + +(define-command (com-compile-and-load-file :name t :command-table lisp-table) + () + "Compile and load the current file. + +Compiler notes will be displayed in a seperate buffer." + (compile-file-interactively (buffer (current-window)) t)) + +(define-command (com-compile-file :name t :command-table lisp-table) + () + "Compile the file open in the current buffer. + +This command does not load the file after it has been compiled." + (compile-file-interactively (buffer (current-window)) nil)) + +(define-command (com-goto-location :name t :command-table lisp-table) + ((note 'compiler-note)) + "Move point to the part of a given file that caused the +compiler note. + +If the file is not already open, a new buffer will be opened with +that file." + (goto-location (location note))) + +(define-presentation-to-command-translator compiler-note-to-goto-location-translator + (compiler-note com-goto-location lisp-table) + (presentation) + (list (presentation-object presentation))) + +(define-command (com-goto-xref :name t :command-table lisp-table) + ((xref 'xref)) + "Go to the referenced location of a code cross-reference." + (goto-location xref)) + +(define-presentation-to-command-translator xref-to-goto-location-translator + (xref com-goto-xref lisp-table) + (presentation) + (list (presentation-object presentation))) + +(define-command (com-edit-this-definition :command-table lisp-table) + () + "Edit definition of the symbol at point. +If there is no symbol at point, this is a no-op." + (let* ((buffer (buffer (current-window))) + (point (point (current-window))) + (syntax (syntax buffer)) + (token (this-form point syntax)) + (this-symbol (when token (token-to-object syntax token)))) + (when (and this-symbol (symbolp this-symbol)) + (edit-definition this-symbol)))) + +(define-command (com-return-from-definition :name t :command-table lisp-table) + () + "Return point to where it was before the previous Edit +Definition command was issued." + (pop-find-definition-stack)) + +(define-command (com-lookup-arglist-for-this-symbol :command-table lisp-table) + () + "Show argument list for symbol at point." + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (mark (point pane)) + (token (this-form mark syntax))) + (if (and token (typep token 'complete-token-lexeme)) + (com-lookup-arglist (token-to-object syntax token)) + (esa:display-message "Could not find symbol at point.")))) + +(define-command (com-lookup-arglist :name t :command-table lisp-table) + ((symbol 'symbol :prompt "Symbol")) + "Show argument list for a given symbol." + (show-arglist symbol)) + +(define-command (com-space :command-table lisp-table) + () + "Insert a space and display argument hints in the minibuffer." + (let* ((window (current-window)) + (mark (point window)) + (syntax (syntax (buffer window)))) + ;; It is important that the space is inserted before we look up + ;; any symbols, but at the same time, there must not be a space + ;; between the mark and the symbol. + (insert-character #\Space) + (backward-object mark) + ;; We must update the syntax in order to reflect any changes to + ;; the parse tree our insertion of a space character may have + ;; done. + (update-syntax (buffer syntax) syntax) + (show-arglist-for-form-at-mark mark syntax) + (forward-object mark) + (clear-completions))) + +(define-command (com-complete-symbol :name t :command-table lisp-table) () + "Attempt to complete the symbol at mark. + +If more than one completion is available, a list of possible +completions will be displayed." + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (point-current-window (point pane)) + (name (symbol-name-at-mark point-current-window + syntax))) + (when name + (with-syntax-package syntax point-current-window (package) + (let ((completion (show-completions syntax name package)) + (mark (clone-mark point-current-window))) + (unless (= (length completion) 0) + (backward-object mark (length name)) + (delete-region mark point-current-window) + (insert-sequence point-current-window completion))))))) + +(define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () + "Attempt to fuzzily complete the abbreviation at mark. + +Fuzzy completion tries to guess which symbol is abbreviated. If +the abbreviation is ambiguous, a list of possible completions +will be displayed." + (let* ((pane (current-window)) + (buffer (buffer pane)) + (syntax (syntax buffer)) + (point-current-window (point pane)) + (name (symbol-name-at-mark point-current-window + syntax))) + (when name + (with-syntax-package syntax point-current-window (package) + (let ((completion (show-fuzzy-completions syntax name package)) + (mark (clone-mark point-current-window))) + (unless (= (length completion) 0) + (backward-object mark (length name)) + (delete-region mark point-current-window) + (insert-sequence point-current-window completion))))))) + +(define-presentation-to-command-translator lookup-symbol-arglist + (symbol com-lookup-arglist lisp-table + :gesture :describe + :tester ((object presentation) + (declare (ignore object)) + (not (eq (presentation-type presentation) 'unknown-symbol))) + :documentation "Lookup arglist") + (object) + (list object)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Gesture bindings + (esa:set-key 'com-fill-paragraph 'lisp-table '((#\q :meta))) @@ -142,4 +345,61 @@ (esa:set-key `(com-kill-expression ,*numeric-argument-marker*) 'lisp-table - '((#\k :control :meta))) \ No newline at end of file + '((#\k :control :meta))) + +(esa:set-key `(com-eval-last-expression ,esa:*numeric-argument-p*) + 'lisp-table + '((#\c :control) (#\e :control))) + +(esa:set-key 'com-macroexpand-1 + 'lisp-table + '((#\c :control) (#\Newline))) + +(esa:set-key 'com-macroexpand-1 + 'lisp-table + '((#\c :control) (#\m :control))) + +(esa:set-key 'com-eval-region + 'lisp-table + '((#\c :control) (#\r :control))) + +(esa:set-key 'com-compile-definition + 'lisp-table + '((#\c :control) (#\c :control))) + +(esa:set-key 'com-compile-and-load-file + 'lisp-table + '((#\c :control) (#\k :control))) + +(esa:set-key 'com-compile-file + 'lisp-table + '((#\c :control) (#\k :meta))) + +(esa:set-key `(com-edit-this-definition) + 'lisp-table + '((#\. :meta))) + +(esa:set-key 'com-return-from-definition + 'lisp-table + '((#\, :meta))) + +(esa:set-key 'com-hyperspec-lookup + 'lisp-table + '((#\c :control) (#\d :control) (#\h))) + +(esa:set-key `(com-lookup-arglist-for-this-symbol) + 'lisp-table + '((#\c :control) (#\d :control) (#\a))) + +(esa:set-key 'com-space + 'lisp-table + '((#\Space))) + +(esa:set-key 'com-complete-symbol + 'lisp-table + '((#\Tab :meta))) + +(esa:set-key 'com-fuzzily-complete-symbol + 'lisp-table + '((#\c :control) (#\i :meta))) + --- /project/climacs/cvsroot/climacs/climacs.asd 2006/06/12 19:10:58 1.45 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/07/05 13:52:17 1.46 @@ -27,8 +27,18 @@ (defparameter *climacs-directory* (directory-namestring *load-truename*)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun find-swank-package () + (find-package :swank)) + (defun find-swank-system () + (handler-case (asdf:find-system :swank) + (asdf:missing-component ()))) + (defun find-swank () + (or (find-swank-package) + (find-swank-system)))) + (defsystem :climacs - :depends-on (:mcclim :flexichain :esa :split-sequence) + :depends-on (:mcclim :flexichain :esa #.(if (find-swank-system) :swank (values))) :components ((:module "cl-automaton" :components ((:file "automaton-package") @@ -73,8 +83,11 @@ (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane" - "gui")) - (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands")) + "window-commands" "gui")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax" "motion" "gui" "motion-commands" "editing-commands" "misc-commands" "window-commands" "file-commands")) + #.(if (find-swank) + '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) + (values)) (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" "kill-ring" "io" "text-syntax" "abbrev" "editing" "motion")) --- /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/07/05 13:52:17 NONE +++ /project/climacs/cvsroot/climacs/lisp-syntax-swank.lisp 2006/07/05 13:52:17 1.1 ;;; -*- Mode: Lisp; Package: CLIMACS-LISP-SYNTAX; -*- ;;; (c) copyright 2005-2006 by ;;; Robert Strandh (strandh(a)labri.fr) ;;; David Murray (splittist(a)yahoo.com) ;;; Troels Henriksen (athas(a)sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; An implementation of some of the editor-centric functionality of ;;; the Lisp syntax using calls to Swank functions. (in-package :climacs-lisp-syntax) (defclass swank-local-image () ()) ;; If this file is loaded, make local Swank the default way of ;; interacting with the image. (defmethod shared-initialize :after ((obj lisp-syntax) slot-names &key) (declare (ignore slot-names)) (setf (image obj) (make-instance 'swank-local-image))) (defmethod default-image () (make-instance 'swank-local-image)) (define-command (com-enable-swank-for-buffer :name t :command-table lisp-table) () (unless (find-package :swank) (let ((*standard-output* *terminal-io*)) (handler-case (asdf:oos 'asdf:load-op :swank) (asdf:missing-component () (esa:display-message "Swank not available."))))) (setf (image (syntax (current-buffer))) (make-instance 'swank-local-image))) (defmethod compile-string-for-climacs ((image swank-local-image) string package buffer buffer-mark) (declare (ignore image)) (let* ((buffer-name (name buffer)) (buffer-file-name (filepath buffer)) ;; swank::compile-string-for-emacs binds *compile-verbose* to t ;; so we need to do this to avoid scribbles on the pane (*standard-output* *debug-io*) (swank::*buffer-package* package) (swank::*buffer-readtable* *readtable*)) (let ((result (swank::compile-string-for-emacs string buffer-name (offset buffer-mark) buffer-file-name)) (notes (loop for note in (swank::compiler-notes-for-emacs) collect (make-compiler-note note)))) (values result notes)))) (defmethod compile-file-for-climacs ((image swank-local-image) filepath package &optional load-p) (declare (ignore image)) (let* ((swank::*buffer-package* package) (swank::*buffer-readtable* *readtable*) (*compile-verbose* nil) (result (swank::compile-file-for-emacs filepath load-p)) (notes (loop for note in (swank::compiler-notes-for-emacs) collect (make-compiler-note note)))) (values result notes))) (defmethod find-definitions-for-climacs ((image swank-local-image) symbol) (declare (ignore image)) (flet ((fully-qualified-symbol-name (symbol) (let ((*package* (find-package :keyword))) (format nil "~S" symbol)))) (let* ((name (fully-qualified-symbol-name symbol)) (swank::*buffer-package* *package*) (swank::*buffer-readtable* *readtable*)) (swank::find-definitions-for-emacs name)))) (defmethod get-class-keyword-parameters ((image swank-local-image) class) (declare (ignore image)) (loop for arg in (swank::extra-keywords/make-instance 'make-instance class) if (swank::keyword-arg.default-arg arg) collect (list (swank::keyword-arg.arg-name arg) (swank::keyword-arg.default-arg arg)) else collect (swank::keyword-arg.arg-name arg))) (defmethod arglist ((image swank-local-image) symbol) (declare (ignore image)) (swank::arglist symbol)) (defmethod simple-completions ((image swank-local-image) string default-package) (declare (ignore image)) (swank::completions string (package-name default-package))) (defmethod fuzzy-completions ((image swank-local-image) symbol-name default-package &optional limit) (declare (ignore image)) (swank::fuzzy-completions symbol-name (package-name default-package) limit))

1 0

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

03 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv9935 Modified Files: packages.lisp base.lisp Log Message: Added `just-n-spaces' function. --- /project/climacs/cvsroot/climacs/packages.lisp 2006/06/12 19:10:58 1.100 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/07/03 15:46:53 1.101 @@ -75,6 +75,7 @@ #:buffer-display-column #:number-of-lines-in-region #:constituentp + #:just-n-spaces #:forward-word #:backward-word #:buffer-region-case #:input-from-stream #:output-to-stream --- /project/climacs/cvsroot/climacs/base.lisp 2006/06/29 14:23:26 1.52 +++ /project/climacs/cvsroot/climacs/base.lisp 2006/07/03 15:46:53 1.53 @@ -144,6 +144,29 @@ function does not respect the current syntax." (member obj '(#\Space #\Tab #\Newline #\Page #\Return))) +(defun just-n-spaces (mark1 n) + "Remove all spaces around `mark', leaving behind `n' +spaces. `Mark' will be moved to after any spaces inserted." + (let ((mark2 (clone-mark mark1))) + (loop + while (not (beginning-of-buffer-p mark2)) + while (eql (object-before mark2) #\Space) + do (backward-object mark2)) + (loop + while (not (end-of-buffer-p mark1)) + while (eql (object-after mark1) #\Space) + do (forward-object mark1)) + (let ((existing-spaces (- (offset mark1) + (offset mark2)))) + (cond ((= n existing-spaces)) + ((> n existing-spaces) + (insert-sequence mark1 (make-array (- n existing-spaces) + :initial-element #\Space))) + ((< n existing-spaces) + (delete-region (- (offset mark1) + (- existing-spaces n)) + mark1)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Character case

1 0

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

02 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv994/Doc Modified Files: climacs-user.texi Log Message: Fleshed out the definitions for the buffer and pane concepts. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:34:15 1.11 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:55:45 1.12 @@ -108,9 +108,16 @@ A @climacs{} @emph{buffer} @cindex buffer -is an editable sequence of arbitrary @cl{} objects. If the buffer +is a named, editable sequence of arbitrary @cl{} objects. If the buffer contains text, most of those objects will be @emph{Unicode -characters}. +characters}. When editing a file, the contents of the file will be +loaded into a buffer with a name corresponding to the name of the file +(creating the buffer in the process), and all editing operations will be +performed on the buffer. Upon saving, the contents of the buffer will be +written to the file associated with it. @xref{Editing the contents of a +file}. A buffer does not necessarily have a file associated with it, for +example, the @emph{*scratch*} buffer automatically created upon +@climacs{} startup is not associated with any file. @cindex character @cindex Unicode @@ -118,10 +125,15 @@ @section Window and pane A @climacs{} buffer may or may not be on display. If it is, it is on -display in a @emph{pane} +display in a @emph{pane} @cindex pane or a @emph{window}. @cindex window +A pane does not necessarily contain a buffer, it may just be a pane +containing output from Climacs. These panes are known as @emph{typeout +panes}, +@cindex typeout pane +and their contents are lost when they are destroyed. @node Mark and point @section Mark and point @@ -731,8 +743,8 @@ To get documentation about a particular command, use the order @kbd{C-h f} @kindex C-h f -(@command{Describe Command}). You will be prompted for -the name of a command, and if you provide a valid command name, a pane +(@command{Describe Command}). You will be prompted for the name of a +command, and if you provide a valid command name, a typeout pane containing information about which function the command calls, which gestures the command can be invoked through, as well as a description of the command, will be displayed. @@ -762,20 +774,21 @@ (@command{Describe Key}). You will be prompted for a key sequence, and if the key sequence you provide is bound to a command, documentation for that command, as well as any arguments the given key binding calls the -command with, will be shown. +command with, will be shown in a typeout pane. @node Help finding a command -@section Help findind a command +@section Help finding a command If you do not know which commands are applicable to a given situation, you can use the order @kbd{C-h a} @kindex C-h a (@command{Apropos Command}) to perform a keyword-based search for -commands. You will be prompted for a keyword, after which @climacs{} will -search through the available commands for commands that are connected to -the keyword. If commands are found, they will be displayed in a pane -along with the gestures you can use to invoke them. You can also click -on the names of the commands to get more thorough documentation. +commands. You will be prompted for a keyword, after which @climacs{} +will search through the available commands for commands that are +connected to the keyword. If commands are found, they will be displayed +in a typeout pane along with the gestures you can use to invoke +them. You can also click on the names of the commands to get more +thorough documentation. @node Help finding an order for a command @section Help finding an order for a command

1 0

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

02 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv31495/Doc Modified Files: climacs-user.texi Log Message: Climacs => @climacs{} (but why?) --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:01:33 1.10 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:34:15 1.11 @@ -556,7 +556,7 @@ @node Searching and replacing @section Searching and replacing -Climacs has a number of useful searching and replacing commands. The +@climacs{} has a number of useful searching and replacing commands. The replacing commands come in two flavors - querying commands and non-querying commands. The former will unconditionally replace all matches, while the latter will query before each replacement. Note that @@ -619,7 +619,7 @@ @subsection The isearch command loop The isearch command loop consists of the user typing in characters for -the search string, and Climacs moving point ahead to the most immediate +the search string, and @climacs{} moving point ahead to the most immediate instance of the provided string, while the user is typing. Apart from simply entering text, the user can manipulate the command loop by entering the following orders: @@ -669,7 +669,7 @@ with one command - for instance, you might want to replace all occurrences of ``foo'' with ``bar'' and all occurrences of ``bar'' with ``baz'', without having the replacements affect each other. For this, -Climacs provides the command @command{Multiple Query Replace}, which +@climacs{} provides the command @command{Multiple Query Replace}, which will prompt for pairs of strings, replacing the first with the second. Entering an empty search string stops the prompting and starts the query-replace command loop. It is also possible to use @command{Multiple @@ -771,7 +771,7 @@ you can use the order @kbd{C-h a} @kindex C-h a (@command{Apropos Command}) to perform a keyword-based search for -commands. You will be prompted for a keyword, after which Climacs will +commands. You will be prompted for a keyword, after which @climacs{} will search through the available commands for commands that are connected to the keyword. If commands are found, they will be displayed in a pane along with the gestures you can use to invoke them. You can also click

1 0

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

02 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv27509/Doc Modified Files: climacs-user.texi Log Message: Added documentation for the search/replace-commands to the Climacs User Guide. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/01 23:11:19 1.9 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/02 19:01:33 1.10 @@ -556,6 +556,156 @@ @node Searching and replacing @section Searching and replacing +Climacs has a number of useful searching and replacing commands. The +replacing commands come in two flavors - querying commands and +non-querying commands. The former will unconditionally replace all +matches, while the latter will query before each replacement. Note that +the searching and replacing commands only affect the buffer contents +after point. + +@menu +* Simple search:: +* Incremental search:: +* The isearch command loop:: +* Replacing single strings:: +* Replacing multiple different strings:: +* The query-replace command loop:: +@end menu + +@node Simple search +@subsection Simple search + +The simplest search command is @command{String Search}. It prompts for a +string and moves point to after the next occurrence of the +string. @command{Reverse String Search} is similar, but searches +backwards from point, and puts point before the first occurrence of the +string. + +The commands @command{Word Search} and @command{Reverse Word Search} are +very similar to @command{String Search} and @command{Reverse String +Search}, but only finds matches that are whole words. + +The commands @command{Regex Search Forward} and @command{Regex Search +Backward} are similar to @command{String Search} and @command{Reverse +Word Search}, but do not search for plain strings. Instead, they ask the +user to enter a regular expression and attempts to find a match in the +buffer. + +You can use the command @command{How Many} to count the number of +matches in the buffer for a given regular expression. When invoked, the +command will ask for a regular expression, and then proceed to search +through the buffer, counting each match for the regular expression, and +finally print the number of matches to the minibuffer. + +@node Incremental search +@subsection Incremental search + +Incremental search, or @emph{isearch} in common speech, is different +from string search, in that point is moved to matches in the buffer, +while the search string is being entered, thus, the user receives +immediate feedback while entering the search string. Incremental search +is controlled through a command loop. @xref{The isearch command loop}. + +Incremental search can be entered via two orders, @kbd{C-s} +@kindex C-s +(@command{Isearch Forward}) and @kbd{C-r} +@kindex C-r +(@command{Isearch Backward}). These commands starts a command loop that +searches forwards and backwards by default, respectively. Note that the +search direction can be changed from inside the command loop, no matter +which of these commands were used to start it. + +@node The isearch command loop +@subsection The isearch command loop + +The isearch command loop consists of the user typing in characters for +the search string, and Climacs moving point ahead to the most immediate +instance of the provided string, while the user is typing. Apart from +simply entering text, the user can manipulate the command loop by +entering the following orders: + +@table @kbd +@item C-s +Move to next match for current search string and set the search +direction to forward. +@item C-r +Move to previous match for current search string and set the search +direction to backward. +@item C-j +Append a ``newline'' character to the current search string. +@item C-w +Append the word at point to the current search string. +@item C-y +Append the line at point to the current search string. +@item M-y +Append the head of the kill ring to the search string. +@item @key{Backspace} +Delete the last element of the search string. This is not the same as +deleting the last character - for example, if the word at point has been +appended to the search string via @kbd{C-w}, this order will delete the +entire word, not just the last character of the word. +@item @key{Newline} +Exit the isearch command loop. +@end table + +@node Replacing single strings +@subsection Replacing single strings + +The basic string-replacement command can be accessed through the order +@kbd{C-x e} +@kindex C-x e +(@command{Replace String}). This command will prompt for two strings, +and replace all instances of the first string following point in the +current buffer, with the second string. This command is not querying, +and will thus not prompt before each replacement, so if you desire this +behavior, use the order @kbd{M-%} +@kindex M-% +(@command{Query Replace}) instead. @xref{The query-replace command loop}. + +@node Replacing multiple different strings +@subsection Replacing multiple different strings + +It is often desirable to be able to replace multiple, different strings +with one command - for instance, you might want to replace all +occurrences of ``foo'' with ``bar'' and all occurrences of ``bar'' with +``baz'', without having the replacements affect each other. For this, +Climacs provides the command @command{Multiple Query Replace}, which +will prompt for pairs of strings, replacing the first with the second. +Entering an empty search string stops the prompting and starts the +query-replace command loop. It is also possible to use @command{Multiple +Query Replace From Buffer}, which will read the string pairs from a +buffer provided by the user. + +If you wish to exchange two strings for one another, use the command +@command{Query Exchange}, which will prompt for two strings, and replace +them for each other in the current buffer. + +@node The query-replace command loop +@subsection The query-replace command loop + +When invoking one of the querying replace commands, you will enter a +command loop with specialized commands for manipulating the replacement +process. + +The command loop will loop across the buffer, and for each match, the +command loop will read an order from the user. The following orders and +their corresponding commands are available: + +@table @kbd +@item y, @key{Space} +Replace the current match with the provided string, go to next +match. +@item n, @key{Rubout}, @key{Backspace} +Do not replace the current match, go to next match. +@item q, @key{Newline} +Quit the command loop, preserving all replacements already made. +@item . +Replace the current match with the provided string and quit the +command loop. +@item ! +Replace all matches with the provided replacement strings. +@end table + @node Getting help @chapter Getting help @@ -568,8 +718,10 @@ information is displayed. @menu +* Help with a command:: * Help with a key binding:: * Help with a particular key sequence:: +* Help finding a command:: * Help finding an order for a command:: @end menu @@ -598,7 +750,7 @@ @section Help with a particular key sequence To obtain a description of what some putative order will do, use the -order @kbd{C-h c} +order @kbd{C-h c}p @kindex C-h c (@command{Describe Key Briefly}). You will be prompted for a key sequence. If the key sequence you type is bound to a command, the

1 0

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

02 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv22006 Modified Files: search-commands.lisp Log Message: Fixed `com-isearch-append-word' to work with the new motion methods. --- /project/climacs/cvsroot/climacs/search-commands.lisp 2006/06/12 19:10:58 1.7 +++ /project/climacs/cvsroot/climacs/search-commands.lisp 2006/07/02 18:42:28 1.8 @@ -199,7 +199,9 @@ (isearch-from-mark pane mark string forwardp)))) (define-command (com-isearch-append-word :name t :command-table isearch-climacs-table) () - (isearch-append-text #'forward-word)) + (let ((syntax (syntax (current-buffer)))) + (isearch-append-text #'(lambda (mark) + (forward-word mark syntax))))) (define-command (com-isearch-append-line :name t :command-table isearch-climacs-table) () (isearch-append-text #'end-of-line))

1 0

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

02 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv26319 Modified Files: misc-commands.lisp editing-commands.lisp Log Message: Moved the Kill Line command into editing-commands.lisp. --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/06/12 19:10:58 1.15 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/07/02 15:43:48 1.16 @@ -150,53 +150,6 @@ 'editing-table '((#\o :control))) -(defun kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil)) - (let ((start (offset mark))) - (cond ((= 0 count) - (beginning-of-line mark)) - ((< count 0) - (loop repeat (- count) - until (beginning-of-buffer-p mark) - do (beginning-of-line mark) - until (beginning-of-buffer-p mark) - do (backward-object mark))) - ((or whole-lines-p (> count 1)) - (loop repeat count - until (end-of-buffer-p mark) - do (end-of-line mark) - until (end-of-buffer-p mark) - do (forward-object mark))) - (t - (cond ((end-of-buffer-p mark) nil) - ((end-of-line-p mark) (forward-object mark)) - (t (end-of-line mark))))) - (unless (mark= mark start) - (if concatenate-p - (kill-ring-concatenating-push *kill-ring* - (region-to-sequence start mark)) - (kill-ring-standard-push *kill-ring* - (region-to-sequence start mark))) - (delete-region start mark)))) - -(define-command (com-kill-line :name t :command-table deletion-table) - ((numarg 'integer :prompt "Kill how many lines?") - (numargp 'boolean :prompt "Kill entire lines?")) - "Kill the objects on the current line after point. -When at the end of a line, kill the #\\Newline. -With a numeric argument of 0, kill the objects on the current line before point. -With a non-zero numeric argument, kill that many lines forward (backward, -if negative) from point. - -Successive kills append to the kill ring." - (let* ((pane (current-window)) - (point (point pane)) - (concatenate-p (eq (previous-command pane) 'com-kill-line))) - (kill-line point numarg numargp concatenate-p))) - -(set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*) - 'deletion-table - '((#\k :control))) - (defmacro define-mark-unit-command (unit command-table &key move-point noun --- /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/06/12 19:10:58 1.1 +++ /project/climacs/cvsroot/climacs/editing-commands.lisp 2006/07/02 15:43:48 1.2 @@ -195,13 +195,57 @@ (region-to-sequence mark point))) (delete-region mark point))) +;; We require somewhat special behavior from Kill Line, so define a +;; new function and use that to implement the Kill Line command. +(defun user-kill-line (mark &optional (count 1) (whole-lines-p nil) (concatenate-p nil)) + (let ((start (offset mark))) + (cond ((= 0 count) + (beginning-of-line mark)) + ((< count 0) + (loop repeat (- count) + until (beginning-of-buffer-p mark) + do (beginning-of-line mark) + until (beginning-of-buffer-p mark) + do (backward-object mark))) + ((or whole-lines-p (> count 1)) + (loop repeat count + until (end-of-buffer-p mark) + do (end-of-line mark) + until (end-of-buffer-p mark) + do (forward-object mark))) + (t + (cond ((end-of-buffer-p mark) nil) + ((end-of-line-p mark) (forward-object mark)) + (t (end-of-line mark))))) + (unless (mark= mark start) + (if concatenate-p + (kill-ring-concatenating-push *kill-ring* + (region-to-sequence start mark)) + (kill-ring-standard-push *kill-ring* + (region-to-sequence start mark))) + (delete-region start mark)))) + +(define-command (com-kill-line :name t :command-table deletion-table) + ((numarg 'integer :prompt "Kill how many lines?") + (numargp 'boolean :prompt "Kill entire lines?")) + "Kill the objects on the current line after point. +When at the end of a line, kill the #\\Newline. +With a numeric argument of 0, kill the objects on the current line before point. +With a non-zero numeric argument, kill that many lines forward (backward, +if negative) from point. + +Successive kills append to the kill ring." + (let* ((pane (current-window)) + (point (point pane)) + (concatenate-p (eq (previous-command pane) 'com-kill-line))) + (user-kill-line point numarg numargp concatenate-p))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Autogenerate commands (define-deletion-commands word deletion-table) (define-editing-commands word editing-table) -(define-deletion-commands line deletion-table) (define-editing-commands line editing-table) (define-deletion-commands definition deletion-table) (define-editing-commands definition editing-table) @@ -247,3 +291,6 @@ 'editing-table '((#\t :control))) +(set-key `(com-kill-line ,*numeric-argument-marker* ,*numeric-argument-p*) + 'deletion-table + '((#\k :control))) \ No newline at end of file

1 0

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

01 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv23856/Doc Modified Files: climacs-user.texi Log Message: Added mention of new documentation commands to the user manual. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/01 22:41:05 1.8 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/01 23:11:19 1.9 @@ -564,7 +564,7 @@ with. Most of these topics are obtained by some order using the @kbd{C-h} @kindex C-h -prefex key. The key following @kbd{C-h} determines what kind of help +prefix key. The key following @kbd{C-h} determines what kind of help information is displayed. @menu @@ -573,6 +573,18 @@ * Help finding an order for a command:: @end menu +@node Help with a command +@section Help with a command + +To get documentation about a particular command, use the order @kbd{C-h +f} +@kindex C-h f +(@command{Describe Command}). You will be prompted for +the name of a command, and if you provide a valid command name, a pane +containing information about which function the command calls, which +gestures the command can be invoked through, as well as a description of +the command, will be displayed. + @node Help with a key binding @section Help with a key binding @@ -593,6 +605,26 @@ command name will be displayed in the minibuffer. Otherwise, a message indicating that the key is not bound to a command will be displayed. +For more detailed information, use the order @kbd{C-h c} +@kindex C-h k +(@command{Describe Key}). You will be prompted for a key sequence, and +if the key sequence you provide is bound to a command, documentation for +that command, as well as any arguments the given key binding calls the +command with, will be shown. + +@node Help finding a command +@section Help findind a command + +If you do not know which commands are applicable to a given situation, +you can use the order @kbd{C-h a} +@kindex C-h a +(@command{Apropos Command}) to perform a keyword-based search for +commands. You will be prompted for a keyword, after which Climacs will +search through the available commands for commands that are connected to +the keyword. If commands are found, they will be displayed in a pane +along with the gestures you can use to invoke them. You can also click +on the names of the commands to get more thorough documentation. + @node Help finding an order for a command @section Help finding an order for a command

1 0

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

01 Jul '06

Update of /project/climacs/cvsroot/climacs/Doc In directory clnet:/tmp/cvs-serv20213/Doc Modified Files: climacs-user.texi Log Message: The entry point is in the CLIMACS-GUI package. --- /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2005/10/19 18:03:07 1.7 +++ /project/climacs/cvsroot/climacs/Doc/climacs-user.texi 2006/07/01 22:41:05 1.8 @@ -195,7 +195,7 @@ @emph{expression} at the prompt of a @cl{} @emph{listener} such as: @lisp -CL-USER> (climacs:climacs) +CL-USER> (climacs-gui:climacs) @end lisp You exit from @climacs{} by typing @kbd{C-x C-c} (@command{Quit}).

1 0