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

[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 08 Jul '06

08 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