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

[climacs-cvs] CVS update: climacs/gui.lisp climacs/slidemacs-gui.lisp climacs/syntax.lisp
by crhodes＠common-lisp.net 31 Oct '05

31 Oct '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14852 Modified Files: gui.lisp slidemacs-gui.lisp syntax.lisp Log Message: Fix slidemacs-gui syntax, in a slightly hacky way (but less hacky than CSR climacs-devel 2005-10-30). New function CLIMACS-GUI::NOTE-PANE-SYNTAX-CHANGED, used by (SETF BUFFER) and (SETF SYNTAX), and with methods automatically defined with the :COMMAND-TABLE option to DEFINE-SYNTAX. Don't let slidemacs-gui put stuff in the global command table. Date: Mon Oct 31 14:42:32 2005 Author: crhodes Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.192 climacs/gui.lisp:1.193 --- climacs/gui.lisp:1.192 Wed Oct 19 22:56:59 2005 +++ climacs/gui.lisp Mon Oct 31 14:42:31 2005 @@ -1173,6 +1173,12 @@ (when default (switch-to-buffer default)))) +;;; FIXME: see the comment by (SETF SYNTAX) :AROUND. -- CSR, +;;; 2005-10-31. +(defmethod (setf buffer) :around (buffer (pane extended-pane)) + (call-next-method) + (note-pane-syntax-changed pane (syntax buffer))) + (define-command (com-switch-to-buffer :name t :command-table pane-table) () (let* ((default (second (buffers *application-frame*))) (buffer (if default @@ -1416,7 +1422,16 @@ (defmethod set-syntax ((buffer climacs-buffer) (syntax syntax)) (setf (syntax buffer) syntax)) -;;FIXME - what should this specialise on? +;;; FIXME: This :around method is probably not going to remain here +;;; for ever; it is a symptom of level mixing, I think. See also the +;;; similar method on (SETF BUFFER). -- CSR, 2005-10-31. +(defmethod (setf syntax) :around (syntax (buffer climacs-buffer)) + (call-next-method) + (let ((pane (current-window))) + (assert (eq (buffer pane) buffer)) + (note-pane-syntax-changed pane syntax))) + +;;; FIXME - what should this specialise on? (defmethod set-syntax ((buffer climacs-buffer) syntax) (set-syntax buffer (make-instance syntax :buffer buffer))) Index: climacs/slidemacs-gui.lisp diff -u climacs/slidemacs-gui.lisp:1.20 climacs/slidemacs-gui.lisp:1.21 --- climacs/slidemacs-gui.lisp:1.20 Tue Oct 11 23:20:52 2005 +++ climacs/slidemacs-gui.lisp Mon Oct 31 14:42:31 2005 @@ -28,14 +28,17 @@ ((lexer :reader lexer) (valid-parse :initform 1) (parser)) (:name "Slidemacs-GUI") - (:pathname-types)) + (:pathname-types) + (:command-table slidemacs-table)) (defvar *slidemacs-display* nil) (defvar *current-slideset*) (defvar *did-display-a-slide*) -(make-command-table 'slidemacs-table :errorp nil) +(make-command-table 'slidemacs-table + :errorp nil + :inherit-from '(climacs-gui::global-climacs-table)) (defun slidemacs-entity-string (entity) (coerce (buffer-sequence (buffer entity) @@ -307,7 +310,7 @@ (display-text-with-wrap-for-pane object stream)))) (define-command (com-browse-to-url :name "Browse To URL" - :command-table global-command-table + :command-table slidemacs-table :menu t :provide-output-destination-keyword t) ((url 'slidemacs-url :prompt "url")) @@ -315,7 +318,7 @@ (sb-ext:run-program "/usr/bin/open" (list url))) (define-presentation-to-command-translator browse-url-translator - (slidemacs-url com-browse-to-url global-command-table + (slidemacs-url com-browse-to-url slidemacs-table :gesture :select :documentation "Browse To URL" :pointer-documentation "Browse To URL") Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.58 climacs/syntax.lisp:1.59 --- climacs/syntax.lisp:1.58 Tue Sep 13 21:23:59 2005 +++ climacs/syntax.lisp Mon Oct 31 14:42:31 2005 @@ -167,6 +167,7 @@ (let ((defclass-options nil) (default-initargs nil) (name nil) + (command-table nil) (pathname-types nil)) (dolist (option options) (case (car option) @@ -180,6 +181,11 @@ (error "More than one ~S option provided to ~S" ':pathname-types 'define-syntax) (setf pathname-types (cdr option)))) + ((:command-table) + (if command-table + (error "More than one ~S option provided to ~S" + ':command-table 'define-syntax) + (setf command-table (cadr option)))) ((:default-initargs) (if default-initargs (error "More than one ~S option provided to ~S" @@ -199,7 +205,19 @@ *syntaxes*) (defclass ,class-name ,superclasses ,slots (:default-initargs ,@default-initargs) - ,@defclass-options)))) + ,@defclass-options) + ,@(when command-table + ;; FIXME: double colons? Looks ugly to me. More + ;; importantly, we can't use EXTENDED-PANE as a specializer + ;; here, because that hasn't been defined yet. + `((defmethod climacs-gui::note-pane-syntax-changed + (pane (syntax ,class-name)) + (setf (command-table pane) ',command-table))))))) + +;;; FIXME: see comment in DEFINE-SYNTAX +(defgeneric climacs-gui::note-pane-syntax-changed (pane syntax) + (:method (pane syntax) + (setf (command-table pane) 'climacs-gui::global-climacs-table))) #+nil (defmacro define-syntax (class-name (name superclasses) &body body)

1 0

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

29 Oct '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv30653 Modified Files: lisp-syntax.lisp Log Message: Avoid compilation error on recent SBCL by replacing CASE by ECASE. Date: Sat Oct 29 06:20:47 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.37 climacs/lisp-syntax.lisp:1.38 --- climacs/lisp-syntax.lisp:1.37 Mon Oct 17 19:55:58 2005 +++ climacs/lisp-syntax.lisp Sat Oct 29 06:20:46 2005 @@ -298,7 +298,7 @@ (make-instance 'readtime-evaluation-lexeme)) ((#\B #\b #\O #\o #\X #\x) (let ((radix - (case (object-after scan) + (ecase (object-after scan) ((#\B #\b) 2) ((#\O #\o) 8) ((#\X #\x) 16))))

1 0

[climacs-cvs] CVS update: climacs/esa.lisp
by crhodes＠common-lisp.net 28 Oct '05

28 Oct '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv4530 Modified Files: esa.lisp Log Message: Whoops. Restore JQS's hack for M-% and friends Date: Sat Oct 29 00:16:01 2005 Author: crhodes Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.20 climacs/esa.lisp:1.21 --- climacs/esa.lisp:1.20 Fri Oct 28 18:22:51 2005 +++ climacs/esa.lisp Sat Oct 29 00:16:01 2005 @@ -322,7 +322,16 @@ command table :keystroke gesture :errorp nil) (when (and (listp gesture) (find :meta gesture)) - (set-key command table (list (list :escape) (remove :meta gesture))))) + ;; KLUDGE: this is a workaround for poor McCLIM + ;; behaviour; really this canonization should happen in + ;; McCLIM's input layer. + (set-key command table + (list (list :escape) + (let ((esc-list (remove :meta gesture))) + (if (and (= (length esc-list) 2) + (find :shift esc-list)) + (remove :shift esc-list) + esc-list)))))) (t (set-key command (ensure-subtable table gesture) (cdr gestures))))))

1 0

[climacs-cvs] CVS update: climacs/esa.lisp
by crhodes＠common-lisp.net 28 Oct '05

28 Oct '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11384 Modified Files: esa.lisp Log Message: No-one's complained yet; let's make people complain if necessary. Commit reworking of ESA's toplevel loop (in sync with gsharp) Date: Fri Oct 28 18:22:51 2005 Author: crhodes Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.19 climacs/esa.lisp:1.20 --- climacs/esa.lisp:1.19 Sun Oct 16 15:56:50 2005 +++ climacs/esa.lisp Fri Oct 28 18:22:51 2005 @@ -210,29 +210,32 @@ (defun substitute-numeric-argument-p (command numargp) (substitute numargp *numeric-argument-p* command :test #'eq)) -(defun process-gestures (frame command-table) - (loop - for gestures = '() - do (multiple-value-bind (numarg numargp) - (read-numeric-argument :stream *standard-input*) - (loop - (setf *current-gesture* (esa-read-gesture)) - (setf gestures - (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures-with-inheritance gestures command-table))) - (cond - ((not item) - (beep) (return)) - ((eq (command-menu-item-type item) :command) - (let ((command (command-menu-item-value item))) - (unless (consp command) - (setf command (list command))) - (setf command (substitute-numeric-argument-marker command numarg)) - (setf command (substitute-numeric-argument-p command numargp)) - (execute-frame-command frame command) - (return))) - (t nil))))) - do (redisplay-frame-panes frame))) +(defun process-gestures-or-command (frame command-table) + (with-input-context + (`(command :command-table ,(command-table (car (windows frame))))) + (object) + (let ((gestures '())) + (multiple-value-bind (numarg numargp) + (read-numeric-argument :stream *standard-input*) + (loop + (setf *current-gesture* (esa-read-gesture)) + (setf gestures + (nconc gestures (list *current-gesture*))) + (let ((item (find-gestures-with-inheritance gestures command-table))) + (cond + ((not item) + (beep) (return)) + ((eq (command-menu-item-type item) :command) + (let ((command (command-menu-item-value item))) + (unless (consp command) + (setf command (list command))) + (setf command (substitute-numeric-argument-marker command numarg)) + (setf command (substitute-numeric-argument-p command numargp)) + (execute-frame-command frame command) + (return))) + (t nil)))))) + (t + (execute-frame-command frame object)))) (defmethod redisplay-frame-panes :around ((frame esa-frame-mixin) &key force-p) (declare (ignore force-p)) @@ -261,22 +264,13 @@ (*abort-gestures* `((:keyboard #\g ,(make-modifier-state :control))))) (redisplay-frame-panes frame :force-p t) (loop - for maybe-error = t do (restart-case - (progn - (handler-case - (with-input-context - (`(command :command-table ,(command-table (car (windows frame))))) - (object) - (process-gestures frame (command-table (car (windows frame)))) - (t - (execute-frame-command frame object) - (setq maybe-error nil))) - (abort-gesture () (display-message "Quit"))) - (when maybe-error - (beep)) - (redisplay-frame-panes frame)) - (return-to-climacs () nil)))))) + (progn + (handler-case + (process-gestures-or-command frame (command-table (car (windows frame)))) + (abort-gesture () (display-message "Quit"))) + (redisplay-frame-panes frame)) + (return-to-esa () nil)))))) (defmacro simple-command-loop (command-table loop-condition end-clauses) (let ((gesture (gensym)) @@ -328,13 +322,7 @@ command table :keystroke gesture :errorp nil) (when (and (listp gesture) (find :meta gesture)) - (set-key command table - (list (list :escape) - (let ((esc-list (remove :meta gesture))) - (if (and (= (length esc-list) 2) - (find :shift esc-list)) - (remove :shift esc-list) - esc-list)))))) + (set-key command table (list (list :escape) (remove :meta gesture))))) (t (set-key command (ensure-subtable table gesture) (cdr gestures))))))

1 0

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

19 Oct '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19119 Modified Files: gui.lisp Log Message: Removed formatting-table stuff from info-pane (didn't really add much). Fixed bug when C-x b-ing with only one buffer. Date: Wed Oct 19 22:57:00 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.191 climacs/gui.lisp:1.192 --- climacs/gui.lisp:1.191 Thu Oct 13 11:34:12 2005 +++ climacs/gui.lisp Wed Oct 19 22:56:59 2005 @@ -174,50 +174,44 @@ (size (size buffer)) (top (top master-pane)) (bot (bot master-pane))) - (formatting-table (pane) - (formatting-row (pane) - (formatting-cell (pane :align-x :right :min-width '(5 :character)) - (princ (cond ((and (needs-saving buffer) - (read-only-p buffer) - "%*")) - ((needs-saving buffer) "**") - ((read-only-p buffer) "%%") - (t "--")) - pane)) - (formatting-cell (pane :min-width '(25 :character)) - (princ " " pane) - (with-text-face (pane :bold) - (princ (name buffer) pane))) - (formatting-cell (pane :min-width '(5 :character)) - (princ (cond ((and (mark= size bot) - (mark= 0 top)) - "") - ((mark= size bot) - "Bot") - ((mark= 0 top) - "Top") - (t (format nil "~a%" - (round (* 100 (/ (offset top) - size)))))) - pane)) - (formatting-cell (pane) - (with-text-family (pane :sans-serif) - (princ #\( pane) - (princ (name-for-info-pane (syntax buffer)) pane) - (format pane "~{~:[~*~; ~A~]~}" (list - (slot-value master-pane 'overwrite-mode) - "Ovwrt" - (auto-fill-mode master-pane) - "Fill" - (isearch-mode master-pane) - "Isearch")) - (princ #\) pane))) - (formatting-cell (pane) - (with-text-family (pane :sans-serif) - (princ (if (recordingp *application-frame*) - "Def" - "") - pane))))))) + (princ " " pane) + (princ (cond ((and (needs-saving buffer) + (read-only-p buffer) + "%*")) + ((needs-saving buffer) "**") + ((read-only-p buffer) "%%") + (t "--")) + pane) + (princ " " pane) + (with-text-face (pane :bold) + (format pane "~25A" (name buffer))) + (format pane " ~A " + (cond ((and (mark= size bot) + (mark= 0 top)) + "") + ((mark= size bot) + "Bot") + ((mark= 0 top) + "Top") + (t (format nil "~a%" + (round (* 100 (/ (offset top) + size))))))) + (with-text-family (pane :sans-serif) + (princ #\( pane) + (princ (name-for-info-pane (syntax buffer)) pane) + (format pane "~{~:[~*~; ~A~]~}" (list + (slot-value master-pane 'overwrite-mode) + "Ovwrt" + (auto-fill-mode master-pane) + "Fill" + (isearch-mode master-pane) + "Isearch")) + (princ #\) pane)) + (with-text-family (pane :sans-serif) + (princ (if (recordingp *application-frame*) + "Def" + "") + pane)))) (defun display-window (frame pane) "The display function used by the climacs application frame." @@ -1174,14 +1168,19 @@ (make-buffer name))))) ;;placeholder -(defmethod switch-to-buffer ((symbol (eql 'nil))) - (switch-to-buffer (second (buffers *application-frame*)))) +(defmethod switch-to-buffer ((symbol (eql 'nil))) + (let ((default (second (buffers *application-frame*)))) + (when default + (switch-to-buffer default)))) (define-command (com-switch-to-buffer :name t :command-table pane-table) () - (let ((buffer (accept 'buffer - :prompt "Switch to buffer" - :default (second (buffers *application-frame*)) - :default-type 'buffer))) + (let* ((default (second (buffers *application-frame*))) + (buffer (if default + (accept 'buffer + :prompt "Switch to buffer" + :default default) + (accept 'buffer + :prompt "Switch to buffer")))) (switch-to-buffer buffer))) (set-key 'com-switch-to-buffer

1 0

[climacs-cvs] CVS update: climacs/Doc/climacs-user.texi
by rstrandh＠common-lisp.net 19 Oct '05

19 Oct '05

Update of /project/climacs/cvsroot/climacs/Doc In directory common-lisp.net:/tmp/cvs-serv7293 Modified Files: climacs-user.texi Log Message: Added a chapter describing a proposal to change the buffer/pane relations. This chapter will disappear once the proposal is implemented, and the description of the existing key bindings will be altered. Date: Wed Oct 19 20:03:08 2005 Author: rstrandh Index: climacs/Doc/climacs-user.texi diff -u climacs/Doc/climacs-user.texi:1.6 climacs/Doc/climacs-user.texi:1.7 --- climacs/Doc/climacs-user.texi:1.6 Sat Sep 24 20:53:48 2005 +++ climacs/Doc/climacs-user.texi Wed Oct 19 20:03:07 2005 @@ -44,6 +44,7 @@ * Kill ring:: * Advanced editing commands:: * Getting help:: +* Proposal for new buffer/pane relations:: * Key Index:: * Concept Index:: @end menu @@ -604,6 +605,41 @@ bound to an order, that order will displayed in the minibuffer. Otherwise, a message indicating that the command is not bound to any order will be displayed. + +@node Proposal for new buffer/pane relations +@chapter Proposal for new buffer/pane relations + +There is a proposal on the table to make the way @climacs{} manages +buffers and panes incompatible with that of Emacs, and in the process +thus cleaning up 30 years of baggage. + +The proposal is to no longer allow buffers without panes. Instead, a +buffer will always be associated with at least one pane, though that +pane could be adopted or disowned to make it visible or invisible. +The advantage of this organization is that a buffer will no longer +contain a point. Also, panes can contain other things that buffers +such as buffer lists, debugger applications, etc. + +For this to work, we need to define how the effect of certain +commands related to buffers and windows will be altered. The proposal +is: + +C-x 2 creates an additional pane with its own point and that shares +the buffer of the current pane. It also adopts the new pane by the +same mechanism used now (creating a vbox pane containing the two. C-x +3 is similar except that it uses a hbox instead. + +C-x 0 does not destroy the pane, but just disowns it (by replacing the +rack it is in by the pane itself). + +C-x 1 does the equivalent of C-x 0 on all other visible panes. + +C-x k kills the current pane. If that happens to be the last pane +containing a particular buffer, then the buffer is lost as well. + +C-x b replaces the current pane by some arbitrary pane displaying the +buffer that has been requested (or creates a new buffer and a new pane +if the buffer requested does not exist?). @node Key Index @unnumbered Key Index

1 0

[climacs-cvs] CVS update: climacs/lisp-syntax.lisp
by dmurray＠common-lisp.net 17 Oct '05

17 Oct '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31058 Modified Files: lisp-syntax.lisp Log Message: Changed package finding to recognise cl:in-package etc. Date: Mon Oct 17 19:55:58 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.36 climacs/lisp-syntax.lisp:1.37 --- climacs/lisp-syntax.lisp:1.36 Sun Oct 16 16:02:51 2005 +++ climacs/lisp-syntax.lisp Mon Oct 17 19:55:58 2005 @@ -1072,10 +1072,12 @@ (flet ((test (x) (when (typep x 'complete-list-form) (let ((candidate (second-form (children x)))) - (buffer-looking-at buffer - (start-offset candidate) - "in-package" - :test #'char-equal))))) + (and (typep candidate 'token-mixin) + (eq (parse-symbol (coerce (buffer-sequence (buffer syntax) + (start-offset candidate) + (end-offset candidate)) + 'string)) + 'cl:in-package)))))) (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) (when form

1 0

[climacs-cvs] CVS update: climacs/lisp-syntax.lisp
by dmurray＠common-lisp.net 16 Oct '05

16 Oct '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8819 Modified Files: lisp-syntax.lisp Log Message: Added some more support for literal numbers. Still some work to do, but of decreasing utility. Improved handling of in-package forms. The package slot of a lisp-syntax syntax object will now contain: * NIL if there is no (valid) in-package form; * a package object if there is a valid in-package form and the package exists in the image; * a string if there is a valid in-package form and the package named is not in the image. As usual, the syntax accepted is looser than that required by the reader, except that the case of using a character to name a package is not recognised. If someone wants to name their package #\Backspace they're on their own... Date: Sun Oct 16 16:02:51 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.35 climacs/lisp-syntax.lisp:1.36 --- climacs/lisp-syntax.lisp:1.35 Tue Sep 13 21:23:59 2005 +++ climacs/lisp-syntax.lisp Sun Oct 16 16:02:51 2005 @@ -45,8 +45,10 @@ (defmethod name-for-info-pane ((syntax lisp-syntax)) (format nil "Lisp~@[:~(~A~)~]" - (when (slot-value syntax 'package) - (package-name (slot-value syntax 'package))))) + (let ((package (slot-value syntax 'package))) + (typecase package + (package (package-name package)) + (t package))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -200,6 +202,7 @@ (defclass pathname-start-lexeme (lisp-lexeme) ()) (defclass undefined-reader-macro-lexeme (lisp-lexeme) ()) (defclass bit-vector-lexeme (form-lexeme) ()) +(defclass number-lexeme (form-lexeme) ()) (defclass token-mixin () ()) (defclass complete-token-lexeme (token-mixin form-lexeme) ()) (defclass multiple-escape-start-lexeme (lisp-lexeme) ()) @@ -253,9 +256,13 @@ (cond ((end-of-buffer-p scan) (make-instance 'incomplete-lexeme)) (t - (loop until (end-of-buffer-p scan) - while (digit-char-p (object-after scan)) - do (fo)) + (let ((prefix 0)) + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan)) + do (setf prefix + (+ (* 10 prefix) + (digit-char-p (object-after scan)))) + (fo)) (if (end-of-buffer-p scan) (make-instance 'incomplete-lexeme) (case (object-after scan) @@ -289,10 +296,32 @@ (make-instance 'uninterned-symbol-lexeme)) (#\. (fo) (make-instance 'readtime-evaluation-lexeme)) - ;((#\B #\b) ) - ;((#\O #\o) ) - ;((#\X #\x) ) - ;((#\R #\r) ) + ((#\B #\b #\O #\o #\X #\x) + (let ((radix + (case (object-after scan) + ((#\B #\b) 2) + ((#\O #\o) 8) + ((#\X #\x) 16)))) + (fo) + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan) radix) + do (fo))) + (if (and (not (end-of-buffer-p scan)) + (constituentp (object-after scan))) + (make-instance 'error-lexeme) + (make-instance 'number-lexeme))) + ((#\R #\r) + (fo) + (cond + ((<= 2 prefix 36) + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan) prefix) + do (fo)) + (if (and (not (end-of-buffer-p scan)) + (constituentp (object-after scan))) + (make-instance 'error-lexeme) + (make-instance 'number-lexeme))) + (t (make-instance 'error-lexeme)))) ;((#\C #\c) ) ((#\A #\a) (fo) (make-instance 'array-start-lexeme)) @@ -318,7 +347,7 @@ (make-instance 'long-comment-start-lexeme)) (#\< (fo) (make-instance 'error-lexeme)) - (t (fo) (make-instance 'undefined-reader-macro-lexeme))))))) + (t (fo) (make-instance 'undefined-reader-macro-lexeme)))))))) (#\| (fo) (make-instance 'multiple-escape-start-lexeme)) (t (cond ((or (constituentp object) (eql object #\\)) @@ -1041,27 +1070,48 @@ (defun package-of (syntax) (let ((buffer (buffer syntax))) (flet ((test (x) - (and (typep x 'list-form) - (not (null (cdr (children x)))) - (buffer-looking-at buffer - (start-offset (cadr (children x))) - "in-package" - :test #'char-equal)))) + (when (typep x 'complete-list-form) + (let ((candidate (second-form (children x)))) + (buffer-looking-at buffer + (start-offset candidate) + "in-package" + :test #'char-equal))))) (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) - (and form - (not (null (cddr (children form)))) - (let* ((package-form (caddr (children form))) - (package-name (coerce (buffer-sequence - buffer - (start-offset package-form) - (end-offset package-form)) - 'string)) - (package-symbol - (let ((*package* (find-package :common-lisp))) - (ignore-errors - (read-from-string package-name nil nil))))) - (find-package package-symbol)))))))) + (when form + (let ((package-form (third-form (children form)))) + (when package-form + (let ((package-name + (typecase package-form + (token-mixin + (coerce (buffer-sequence + buffer + (start-offset package-form) + (end-offset package-form)) + 'string)) + (complete-string-form + (coerce (buffer-sequence + buffer + (1+ (start-offset package-form)) + (1- (end-offset package-form))) + 'string)) + (quote-form + (coerce (buffer-sequence + buffer + (start-offset (second-form (children package-form))) + (end-offset (second-form (children package-form)))) + 'string)) + (uninterned-symbol-form + (coerce (buffer-sequence + buffer + (start-offset (second-form (children package-form))) + (end-offset (second-form (children package-form)))) + 'string)) + (t 'nil)))) + (when package-name + (let ((package-symbol (parse-token package-name))) + (or (find-package package-symbol) + package-symbol)))))))))))) (defmethod update-syntax (buffer (syntax lisp-syntax)) (let* ((low-mark (low-mark buffer)) @@ -1738,7 +1788,9 @@ (values nil nil))))) (defun token-to-symbol (syntax token) - (let ((package (or (slot-value syntax 'package) + (let ((package (if (and (slot-value syntax 'package) + (typep (slot-value syntax 'package) 'package)) + (slot-value syntax 'package) (find-package :common-lisp))) (token-string (coerce (buffer-sequence (buffer syntax) (start-offset token)

1 0

[climacs-cvs] CVS update: climacs/esa.lisp
by dmurray＠common-lisp.net 16 Oct '05

16 Oct '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7791 Modified Files: esa.lisp Log Message: Fixed set-key to allow for mcclim's treatment of the :shift modifier in the :esc command tables. Date: Sun Oct 16 15:56:51 2005 Author: dmurray Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.18 climacs/esa.lisp:1.19 --- climacs/esa.lisp:1.18 Tue Sep 13 21:23:59 2005 +++ climacs/esa.lisp Sun Oct 16 15:56:50 2005 @@ -328,7 +328,13 @@ command table :keystroke gesture :errorp nil) (when (and (listp gesture) (find :meta gesture)) - (set-key command table (list (list :escape) (remove :meta gesture))))) + (set-key command table + (list (list :escape) + (let ((esc-list (remove :meta gesture))) + (if (and (= (length esc-list) 2) + (find :shift esc-list)) + (remove :shift esc-list) + esc-list)))))) (t (set-key command (ensure-subtable table gesture) (cdr gestures))))))

1 0

[climacs-cvs] CVS update: climacs/gui.lisp
by crhodes＠common-lisp.net 13 Oct '05

13 Oct '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18560 Modified Files: gui.lisp Log Message: Fix for unintuitive capitalization of replacement string ("X4" replaced by "Xa////" got turned into "XA////"). Date: Thu Oct 13 11:34:12 2005 Author: crhodes Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.190 climacs/gui.lisp:1.191 --- climacs/gui.lisp:1.190 Tue Oct 11 23:20:52 2005 +++ climacs/gui.lisp Thu Oct 13 11:34:12 2005 @@ -1975,10 +1975,11 @@ (insert-sequence point string2) (setf offset2 (+ offset1 (length string2))) (finish-output *error-output*) - (case region-case - (:upper-case (upcase-buffer-region buffer offset1 offset2)) - (:lower-case (downcase-buffer-region buffer offset1 offset2)) - (:capitalized (capitalize-buffer-region buffer offset1 offset2)))) + (unless (find-if #'upper-case-p string1) + (case region-case + (:upper-case (upcase-buffer-region buffer offset1 offset2)) + (:lower-case (downcase-buffer-region buffer offset1 offset2)) + (:capitalized (capitalize-buffer-region buffer offset1 offset2))))) (incf occurrences) (if (query-replace-find-next-match point string1) (display-message "Query Replace ~A with ~A:"

1 0