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

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

24 Jul '06

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

1 0

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

24 Jul '06

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

1 0

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

24 Jul '06

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

1 0

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

24 Jul '06

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

1 0

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

24 Jul '06

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

1 0

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

24 Jul '06

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

1 0

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

23 Jul '06

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

1 0

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

23 Jul '06

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

1 0

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

23 Jul '06

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

1 0

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

22 Jul '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv25909 Modified Files: lisp-syntax.lisp Log Message: Fixed some more issues regarding intelligent parameter hinting. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/22 16:48:20 1.95 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/07/22 22:12:04 1.96 @@ -2526,7 +2526,8 @@ (defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) (if (null (cdr path)) ;; top level - (let* ((arglist (when (fboundp symbol) (arglist (get-usable-image syntax) symbol))) + (let* ((arglist (when (fboundp symbol) + (arglist-for-form symbol))) (body-or-rest-pos (or (position '&body arglist) (position '&rest arglist)))) (if (and (or (macro-function symbol) @@ -3325,66 +3326,47 @@ for arg-name = (unlisted arg-element) for index from 0 - with in-&aux ; If non-NIL, we are in the - ; &aux parameters that should - ; not be displayed. - - with in-garbage ; If non-NIL, the next - ; argument is a garbage - ; parameter that should not be - ; displayed. - if (eq arg-element '&aux) - do (setf in-&aux t) - else if (member arg-element +cl-garbage-keywords+ :test #'eq) - do (setf in-garbage t) - else if (and (listp arg-element) + if (and (listp arg-element) (> mandatory-argument-count - index) - (not in-garbage) - (not in-&aux)) - collect (multiple-value-bind (arglist - sublist-emphasized-symbols - sublist-highlighted-symbols) - (analyze-arglist arg-element - (rest current-arg-indices) - preceding-arg - (when (< index (length provided-args)) - (listed (elt provided-args index)))) - ;; Unless our `current-arg-index' - ;; actually refers to this sublist, its - ;; highlighted and emphasized symbols - ;; are ignored. Also, if - ;; `current-arg-indices' is nil, we do - ;; not have enough information to - ;; properly highlight symbols in the - ;; arglist. - (when (and current-arg-indices - (= index current-arg-index)) - (if (and (rest current-arg-indices)) - (setf emphasized-symbols - (union (mapcar #'unlisted - sublist-emphasized-symbols) - emphasized-symbols) - highlighted-symbols - (union sublist-highlighted-symbols - highlighted-symbols)) - (setf emphasized-symbols + index)) + collect (multiple-value-bind (arglist + sublist-emphasized-symbols + sublist-highlighted-symbols) + (analyze-arglist arg-element + (rest current-arg-indices) + preceding-arg + (when (< index (length provided-args)) + (listed (elt provided-args index)))) + ;; Unless our `current-arg-index' + ;; actually refers to this sublist, its + ;; highlighted and emphasized symbols + ;; are ignored. Also, if + ;; `current-arg-indices' is nil, we do + ;; not have enough information to + ;; properly highlight symbols in the + ;; arglist. + (when (and current-arg-indices + (= index current-arg-index)) + (if (and (rest current-arg-indices)) + (setf emphasized-symbols + (union (mapcar #'unlisted + sublist-emphasized-symbols) + emphasized-symbols) + highlighted-symbols + (union sublist-highlighted-symbols + highlighted-symbols)) + (setf emphasized-symbols (union (mapcar #'unlisted arg-element) emphasized-symbols)))) - arglist) - else if (and (assoc arg-name user-supplied-arg-values) - (not in-garbage) - (not in-&aux)) - collect (list arg-name - (rest (assoc - arg-name - user-supplied-arg-values))) + arglist) + else if (assoc arg-name user-supplied-arg-values) + collect (list arg-name + (rest (assoc + arg-name + user-supplied-arg-values))) else - if in-garbage - do (setf in-garbage nil) - else if (not in-&aux) - collect arg-element))) + collect arg-element))) (setf ret-arglist (generate-arglist arglist))) (list ret-arglist emphasized-symbols highlighted-symbols))) @@ -3411,12 +3393,35 @@ preceding-arg provided-args))) +(defun cleanup-arglist (arglist) + "Remove elements of `arglist' that we are not interested in." + (loop + for arg in arglist + with in-&aux ; If non-NIL, we are in the + ; &aux parameters that should + ; not be displayed. + + with in-garbage ; If non-NIL, the next + ; argument is a garbage + ; parameter that should not be + ; displayed. + if in-garbage + do (setf in-garbage nil) + else if (not in-&aux) + if (eq arg '&aux) + do (setf in-&aux t) + else if (member arg +cl-garbage-keywords+ :test #'eq) + do (setf in-garbage t) + else + collect arg)) + (defgeneric arglist-for-form (operator &optional arguments) (:documentation "Return an arglist for `operator'") (:method (operator &optional arguments) (declare (ignore arguments)) - (arglist (get-usable-image (syntax (current-buffer))) operator))) + (cleanup-arglist + (arglist (get-usable-image (syntax (current-buffer))) operator)))) ;; Proof of concept, just to make sure it can be done. Also, we need a ;; more elegant interface. Perhaps it could be integrated with the @@ -3440,7 +3445,7 @@ (defmethod arglist-for-form ((operator list) &optional arguments) (declare (ignore arguments)) (case (first operator) - ('cl:lambda (second operator)))) + ('cl:lambda (cleanup-arglist (second operator))))) (defgeneric operator-for-display (operator) (:documentation "Return what should be displayed whenever @@ -3621,7 +3626,7 @@ (listp arg) (rest arg-indices)) (indices-match-arglist arg (rest arg-indices))) - (t (null (rest arg-indices)))))) + (t t)))) (defun direct-arg-p (form syntax) "Check whether `form' is a direct argument to one of its @@ -3679,21 +3684,26 @@ ;; return the form `mark' is in. (unless (null immediate-form) (labels ((recurse (form) - (unless (null form) - (if (and (valid-operator-p (form-operator + (unless (null (parent form)) + (or (unless (eq (first-form (children (parent form))) + form) + (recurse (parent form))) + (and (valid-operator-p (form-operator form ,syntax-value-sym)) (indices-match-arglist - (arglist (image ,syntax-value-sym) - (form-operator - form - ,syntax-value-sym)) + (arglist-for-form + (form-operator + form + ,syntax-value-sym) + (form-operands + form + ,syntax-value-sym)) (second (multiple-value-list - (find-operand-info ,mark-value-sym ,syntax-value-sym form))))) - (or (recurse (parent form)) - (unless (direct-arg-p form ,syntax-value-sym) - form)))))) + (find-operand-info ,mark-value-sym ,syntax-value-sym form)))) + (not (direct-arg-p form ,syntax-value-sym)) + form))))) (or (recurse (parent immediate-form)) (parent immediate-form)))))) ;; If we cannot find a form, there's no point in looking

1 0