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

[climacs-cvs] CVS update: climacs/gui.lisp climacs/lisp-syntax.lisp climacs/packages.lisp
by dmurray＠common-lisp.net 28 Jul '05

28 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16463 Modified Files: gui.lisp lisp-syntax.lisp packages.lisp Log Message: Change climacs application frame to use global-climacs-table Date: Thu Jul 28 22:36:36 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.166 climacs/gui.lisp:1.167 --- climacs/gui.lisp:1.166 Tue Jul 26 07:28:39 2005 +++ climacs/gui.lisp Thu Jul 28 22:36:36 2005 @@ -52,6 +52,8 @@ (define-application-frame climacs (standard-application-frame esa-frame-mixin) ((buffers :initform '() :accessor buffers)) + (:command-table (global-climacs-table :inherit-from (global-esa-table))) + (:menu-bar nil) (:panes (win (let* ((extended-pane (make-pane 'extended-pane @@ -159,9 +161,6 @@ do (when (modified-p buffer) (setf (needs-saving buffer) t)))) -(make-command-table 'global-climacs-table :errorp nil - :inherit-from '(global-esa-table keyboard-macro-table)) - (defmacro define-named-command (command-name args &body body) `(define-command ,(if (listp command-name) `(,@command-name :name t :command-table global-climacs-table) @@ -1232,7 +1231,7 @@ :gesture :select-other :tester-definitive t :menu nil - :priority 11) + :priority 10) (object) object) @@ -1243,7 +1242,7 @@ (display-message (format nil "~s" (accept 'symbol)))) (define-named-command com-accept-lisp-string () - (display-message (format nil "~s" (accept 'climacs-lisp-syntax::lisp-string)))) + (display-message (format nil "~s" (accept 'lisp-string)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.17 climacs/lisp-syntax.lisp:1.18 --- climacs/lisp-syntax.lisp:1.17 Tue Jul 26 07:28:39 2005 +++ climacs/lisp-syntax.lisp Thu Jul 28 22:36:36 2005 @@ -1143,9 +1143,6 @@ (define-presentation-type lisp-string () :description "lisp string") -;(define-presentation-method presentation-typep (object (type lisp-string)) -; (stringp object)) - (defmethod display-parse-tree ((parse-symbol complete-string-form) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) (if (third children) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.70 climacs/packages.lisp:1.71 --- climacs/packages.lisp:1.70 Tue Jul 26 07:28:39 2005 +++ climacs/packages.lisp Thu Jul 28 22:36:36 2005 @@ -164,7 +164,7 @@ (defpackage :climacs-lisp-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-syntax :flexichain :climacs-pane) - (:export)) + (:export :lisp-string)) (defpackage :esa (:use :clim-lisp :clim) @@ -179,5 +179,6 @@ (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax - :climacs-kill-ring :climacs-pane :clim-extensions :undo :esa)) + :climacs-kill-ring :climacs-pane :clim-extensions :undo :esa) + (:import-from :climacs-lisp-syntax :lisp-string))

1 0

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

26 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv29912 Modified Files: gui.lisp lisp-syntax.lisp packages.lisp Log Message: Improvements to Lisp syntax. (thanks to John Q Splittist) Here is his own description of these improvements: This patch: * fixes presentations of multi-token symbols and strings * introduces a new presentation type, the 'unknown-symbol, for symbol tokens that haven't got a package in the image (because, eg. the file hasn't been loaded) * introduces a new presentation type, the 'lisp-string, for strings in the file surrounded by #\"s * presents every token as a 'string. Also included is a presentation translator from 'lisp-string to 'string that doesn't work. It ought to, and I seem to have got back into the gesture/pointer-event code with things still making (to me) sense, so I'd be grateful if someone could check whether it works for them. Things to play with: * M-x Accept String (most things mouseable) * M-x Accept Symbol (see what the system can find, and where - 'symbols are returned as the actual symbol; 'unknown-symbols are returned as strings * M-x Accept Lisp String (source code strings are mouseable) * M-% [being Query Replace], then mouse and click to choose the strings! Things to think about: * Should 'string be for actual lisp strings, and (say) ESA-string (or editor-string) be for sequences of objects in the buffer? This makes sense to me, as some commands that accept a sequence of objects from the buffer might be usable in non-text-editor contexts. (Simply changing commands like com-query-replace from (accept 'string ...) to (accept 'esa-string ...), and changing a couple of things in lisp-syntax, would work.) * What other things might it be useful to mouse around with? * Is there a natural meaning for simply clicking on something in the buffer? Things to do: * (still!) Numbers * work out why the presentation translator isn't working... Date: Tue Jul 26 07:28:40 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.165 climacs/gui.lisp:1.166 --- climacs/gui.lisp:1.165 Mon Jul 25 05:41:13 2005 +++ climacs/gui.lisp Tue Jul 26 07:28:39 2005 @@ -1225,11 +1225,25 @@ (package (climacs-lisp-syntax::package-of syntax))) (display-message (format nil "~s" package)))) +(define-gesture-name :select-other :pointer-button-press (:left :meta) :unique nil) + +(define-presentation-translator lisp-string-to-string + (climacs-lisp-syntax::lisp-string string global-climacs-table + :gesture :select-other + :tester-definitive t + :menu nil + :priority 11) + (object) + object) + (define-named-command com-accept-string () (display-message (format nil "~s" (accept 'string)))) (define-named-command com-accept-symbol () (display-message (format nil "~s" (accept 'symbol)))) + +(define-named-command com-accept-lisp-string () + (display-message (format nil "~s" (accept 'climacs-lisp-syntax::lisp-string)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.16 climacs/lisp-syntax.lisp:1.17 --- climacs/lisp-syntax.lisp:1.16 Mon Jul 25 13:04:30 2005 +++ climacs/lisp-syntax.lisp Tue Jul 26 07:28:39 2005 @@ -1088,15 +1088,31 @@ (with-drawing-options (pane :ink +red+) (call-next-method))) +(define-presentation-type unknown-symbol () :inherit-from 'symbol + :description "unknown symbol") + +(define-presentation-method presentation-typep (object (type unknown-symbol)) + (or (symbolp object) (stringp object))) + (defmethod display-parse-tree ((parse-symbol token-mixin) (syntax lisp-syntax) pane) (if (> (end-offset parse-symbol) (start-offset parse-symbol)) - (cond ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\:) - (with-drawing-options (pane :ink +dark-violet+) - (call-next-method))) - ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) - (with-drawing-options (pane :ink +dark-green+) - (call-next-method))) - (t (call-next-method))) + (let ((string (coerce (buffer-sequence (buffer syntax) + (start-offset parse-symbol) + (end-offset parse-symbol)) + 'string))) + (multiple-value-bind (symbol status) + (token-to-symbol syntax parse-symbol) + (with-output-as-presentation + (pane (if status symbol string) (if status 'symbol 'unknown-symbol) + :single-box :highlighting) + (cond ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\:) + (with-drawing-options (pane :ink +dark-violet+) + (call-next-method))) + ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) + (with-drawing-options (pane :ink +dark-green+) + (call-next-method))) + (t (call-next-method))) + ))) (call-next-method))) (defmethod display-parse-tree ((parser-symbol lisp-lexeme) (syntax lisp-syntax) pane) @@ -1118,31 +1134,49 @@ (start-offset parser-symbol) (end-offset parser-symbol)) 'string))) - (multiple-value-bind (symbol status) - (token-to-symbol syntax parser-symbol) - (declare (ignore symbol)) - (if (and status (typep parser-symbol 'form)) - (present string 'symbol :stream pane) - (present string 'string :stream pane)))))))) - + (present string 'string :stream pane)))))) + (defmethod display-parse-tree :before ((parse-symbol lisp-lexeme) (syntax lisp-syntax) pane) (handle-whitespace pane (buffer pane) *white-space-start* (start-offset parse-symbol)) (setf *white-space-start* (end-offset parse-symbol))) +(define-presentation-type lisp-string () + :description "lisp string") + +;(define-presentation-method presentation-typep (object (type lisp-string)) +; (stringp object)) + (defmethod display-parse-tree ((parse-symbol complete-string-form) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) - (display-parse-tree (pop children) syntax pane) - (with-text-face (pane :italic) - (loop until (null (cdr children)) - do (display-parse-tree (pop children) syntax pane))) - (display-parse-tree (pop children) syntax pane))) + (if (third children) + (let ((string (coerce (buffer-sequence (buffer syntax) + (start-offset (second children)) + (end-offset (car (last children 2)))) + 'string))) + (with-output-as-presentation (pane string 'lisp-string + :single-box :highlighting) + (display-parse-tree (pop children) syntax pane) + (with-text-face (pane :italic) + (loop until (null (cdr children)) + do (display-parse-tree (pop children) syntax pane))) + (display-parse-tree (pop children) syntax pane))) + (progn (display-parse-tree (pop children) syntax pane) + (display-parse-tree (pop children) syntax pane))))) (defmethod display-parse-tree ((parse-symbol incomplete-string-form) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) - (display-parse-tree (pop children) syntax pane) - (with-text-face (pane :italic) - (loop until (null children) - do (display-parse-tree (pop children) syntax pane))))) + (if (second children) + (let ((string (coerce (buffer-sequence (buffer syntax) + (start-offset (second children)) + (end-offset (car (last children)))) + 'string))) + (with-output-as-presentation (pane string 'lisp-string + :single-box :highlighting) + (display-parse-tree (pop children) syntax pane) + (with-text-face (pane :italic) + (loop until (null children) + do (display-parse-tree (pop children) syntax pane))))) + (display-parse-tree (pop children) syntax pane)))) (defmethod display-parse-tree ((parse-symbol line-comment-form) (syntax lisp-syntax) pane) (with-drawing-options (pane :ink +maroon+) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.69 climacs/packages.lisp:1.70 --- climacs/packages.lisp:1.69 Mon Jul 25 05:41:13 2005 +++ climacs/packages.lisp Tue Jul 26 07:28:39 2005 @@ -174,7 +174,8 @@ #:esa-frame-mixin #:windows #:recordingp #:executingp #:*numeric-argument-p* #:*current-gesture* #:esa-top-level #:simple-command-loop - #:global-esa-table #:keyboard-macro-table)) + #:global-esa-table #:keyboard-macro-table + #:set-key)) (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax

1 0

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

25 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv23335 Modified Files: lisp-syntax.lisp Log Message: Fixed multiple escape tokenising and interim indent Date: Mon Jul 25 13:04:30 2005 Author: dmurray Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.15 climacs/lisp-syntax.lisp:1.16 --- climacs/lisp-syntax.lisp:1.15 Sun Jul 24 10:06:50 2005 +++ climacs/lisp-syntax.lisp Mon Jul 25 13:04:30 2005 @@ -394,7 +394,7 @@ (tagbody start (when (end-of-buffer-p scan) - (return-from lex (make-instance 'error-lexeme))) + (return-from lex (make-instance 'text-lexeme))) (when (eql (object-after scan) #\\) (fo) (when (end-of-buffer-p scan) @@ -405,9 +405,13 @@ (incf bars-seen) (fo) (go start)) - (unless (whitespacep (object-after scan)) - (fo) - (go start)) + (if (evenp bars-seen) + (unless (whitespacep (object-after scan)) + (fo) + (go start)) + (when (constituentp (object-after scan)) + (fo) + (go start))) (return-from lex (if (oddp bars-seen) (make-instance 'multiple-escape-end-lexeme) @@ -1456,6 +1460,9 @@ (defmethod indent-form ((syntax lisp-syntax) (tree string-form) path) (values tree 1)) + +(defmethod indent-form ((syntax lisp-syntax) (tree token-form) path) + (values tree 0)) (defmethod indent-binding ((syntax lisp-syntax) tree path) (if (null (cdr path))

1 0

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

25 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv26310 Modified Files: esa.lisp gui.lisp packages.lisp Log Message: Moved keyboard macros to esa.lisp and to a new command table: keyboard-macro-table. Date: Mon Jul 25 05:41:14 2005 Author: rstrandh Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.10 climacs/esa.lisp:1.11 --- climacs/esa.lisp:1.10 Sun Jul 24 07:10:47 2005 +++ climacs/esa.lisp Mon Jul 25 05:41:13 2005 @@ -331,6 +331,42 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Keyboard macros + +(define-command-table keyboard-macro-table) + +(define-command (com-start-kbd-macro + :name t + :command-table keyboard-macro-table) + () + (setf (recordingp *application-frame*) t) + (setf (recorded-keys *application-frame*) '())) + +(set-key 'com-start-kbd-macro 'keyboard-macro-table '((#\x :control) #\()) + +(define-command (com-end-kbd-macro + :name t + :command-table keyboard-macro-table) + () + (setf (recordingp *application-frame*) nil) + (setf (recorded-keys *application-frame*) + ;; this won't work if the command was invoked in any old way + (reverse (cddr (recorded-keys *application-frame*))))) + +(set-key 'com-end-kbd-macro 'keyboard-macro-table '((#\x :control) #\))) + +(define-command (com-call-last-kbd-macro + :name t + :command-table keyboard-macro-table) + () + (setf (remaining-keys *application-frame*) + (recorded-keys *application-frame*)) + (setf (executingp *application-frame*) t)) + +(set-key 'com-call-last-kbd-macro 'keyboard-macro-table '((#\x :control) #\e)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; example application (defclass example-info-pane (info-pane) @@ -393,5 +429,6 @@ ;;; ;;; Commands and key bindings -(define-command-table global-example-table :inherit-from (global-esa-table)) +(define-command-table global-example-table + :inherit-from (global-esa-table keyboard-macro-table)) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.164 climacs/gui.lisp:1.165 --- climacs/gui.lisp:1.164 Sun Jul 24 07:10:47 2005 +++ climacs/gui.lisp Mon Jul 25 05:41:13 2005 @@ -159,7 +159,8 @@ do (when (modified-p buffer) (setf (needs-saving buffer) t)))) -(make-command-table 'global-climacs-table :errorp nil :inherit-from '(global-esa-table)) +(make-command-table 'global-climacs-table :errorp nil + :inherit-from '(global-esa-table keyboard-macro-table)) (defmacro define-named-command (command-name args &body body) `(define-command ,(if (listp command-name) @@ -740,25 +741,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Keyboard macros - -(define-named-command com-start-kbd-macro () - (setf (recordingp *application-frame*) t) - (setf (recorded-keys *application-frame*) '())) - -(define-named-command com-end-kbd-macro () - (setf (recordingp *application-frame*) nil) - (setf (recorded-keys *application-frame*) - ;; this won't work if the command was invoked in any old way - (reverse (cddr (recorded-keys *application-frame*))))) - -(define-named-command com-call-last-kbd-macro () - (setf (remaining-keys *application-frame*) - (recorded-keys *application-frame*)) - (setf (executingp *application-frame*) t)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; Commands for splitting windows (defun replace-constellation (constellation additional-constellation vertical-p) @@ -1361,10 +1343,7 @@ (c-x-set-key '(#\1) 'com-single-window) (c-x-set-key '(#\2) 'com-split-window-vertically) (c-x-set-key '(#\3) 'com-split-window-horizontally) -(c-x-set-key '(#\() 'com-start-kbd-macro) -(c-x-set-key '(#\)) 'com-end-kbd-macro) (c-x-set-key '(#\b) 'com-switch-to-buffer) -(c-x-set-key '(#\e) 'com-call-last-kbd-macro) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\i) 'com-insert-file) (c-x-set-key '(#\k) 'com-kill-buffer) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.68 climacs/packages.lisp:1.69 --- climacs/packages.lisp:1.68 Sun Jul 24 07:10:48 2005 +++ climacs/packages.lisp Mon Jul 25 05:41:13 2005 @@ -174,9 +174,7 @@ #:esa-frame-mixin #:windows #:recordingp #:executingp #:*numeric-argument-p* #:*current-gesture* #:esa-top-level #:simple-command-loop - #:global-esa-table - ;; remove these when kbd macros move to esa - #:recorded-keys #:remaining-keys)) + #:global-esa-table #:keyboard-macro-table)) (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax

1 0

[climacs-cvs] CVS update: climacs/climacs.asd
by afuchs＠common-lisp.net 24 Jul '05

24 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv16774 Modified Files: climacs.asd Log Message: Fix dependency of packages.lisp on the Persistent module in climacs.asd. Thanks to John Q Splittist for discovering that bug. Date: Sun Jul 24 18:44:48 2005 Author: afuchs Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.34 climacs/climacs.asd:1.35 --- climacs/climacs.asd:1.34 Sun Jul 24 12:42:36 2005 +++ climacs/climacs.asd Sun Jul 24 18:44:48 2005 @@ -36,7 +36,7 @@ (:file "obinseq" :depends-on ("binseq-package" "binseq")) (:file "binseq2" :depends-on ("binseq-package" "obinseq" "binseq")))) - (:file "packages") + (:file "packages" :depends-on ("Persistent")) (:file "buffer" :depends-on ("packages")) (:file "persistent-buffer" :pathname #p"Persistent/persistent-buffer.lisp"

1 0

[climacs-cvs] CVS update: climacs/climacs.asd
by rstrandh＠common-lisp.net 24 Jul '05

24 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv20481 Modified Files: climacs.asd Log Message: Entirely new system definition with real dependencies. (thanks to Andreas Fuchs) Date: Sun Jul 24 12:42:37 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.33 climacs/climacs.asd:1.34 --- climacs/climacs.asd:1.33 Thu Jul 21 07:13:51 2005 +++ climacs/climacs.asd Sun Jul 24 12:42:36 2005 @@ -20,61 +20,61 @@ ;;; ASDF system definition for Climacs. -(in-package :common-lisp-user) +(defpackage :climacs.system + (:use :cl :asdf)) + +(in-package :climacs.system) (defparameter *climacs-directory* (directory-namestring *load-truename*)) -(defmacro climacs-defsystem ((module &key depends-on) &rest components) - `(progn - #+mk-defsystem - (mk:defsystem ,module - :source-pathname *climacs-directory* - ,@(and depends-on `(:depends-on ,depends-on)) - :components (:serial ,@components)) - #+asdf - (asdf:defsystem ,module - ,@(and depends-on `(:depends-on ,depends-on)) - :serial t - :components (,@(loop for c in components - for p = (merge-pathnames - (parse-namestring c) - (make-pathname :type "lisp" - :defaults *climacs-directory*)) - collect `(:file ,(pathname-name p) :pathname ,p)))))) - -(climacs-defsystem (:climacs :depends-on (:mcclim :flexichain)) - "Persistent/binseq-package" - "Persistent/binseq" - "Persistent/obinseq" - "Persistent/binseq2" - "translate" - "packages" - "buffer" - "Persistent/persistent-buffer" - "base" - "io" - "abbrev" - "syntax" - "text-syntax" - "kill-ring" - "undo" - "delegating-buffer" - "Persistent/persistent-undo" - "pane" - "fundamental-syntax" - "cl-syntax" - "html-syntax" - "prolog-syntax" - "ttcn3-syntax" - "lisp-syntax" - "esa" - "gui" - "slidemacs" - "slidemacs-gui" - ;;---- optional ---- - "testing/rt" - "buffer-test" - "base-test") +(defsystem :climacs + :depends-on (:mcclim :flexichain) + :components + ((:module "Persistent" + :components ((:file "binseq-package") + (:file "binseq" :depends-on ("binseq-package")) + (:file "obinseq" :depends-on ("binseq-package" "binseq")) + (:file "binseq2" :depends-on ("binseq-package" "obinseq" "binseq")))) + + (:file "packages") + (:file "buffer" :depends-on ("packages")) + (:file "persistent-buffer" + :pathname #p"Persistent/persistent-buffer.lisp" + :depends-on ("packages" "buffer" "Persistent")) + + (:file "base" :depends-on ("packages" "buffer" "persistent-buffer")) + (:file "io" :depends-on ("packages" "buffer")) + (:file "abbrev" :depends-on ("packages" "buffer" "base")) + (:file "syntax" :depends-on ("packages" "buffer" "base")) + (:file "text-syntax" :depends-on ("packages" "base" "buffer" "syntax")) + (:file "delegating-buffer" :depends-on ("packages" "buffer")) + (:file "kill-ring" :depends-on ("packages")) + (:file "undo" :depends-on ("packages")) + (:file "persistent-undo" + :pathname #p"Persistent/persistent-undo.lisp" + :depends-on ("packages" "buffer" "persistent-buffer" "undo")) + (:file "pane" :depends-on ("packages" "syntax" "buffer" "base" + "persistent-undo" "persistent-buffer" "abbrev" + "delegating-buffer" "undo")) + (:file "fundamental-syntax" :depends-on ("packages" "syntax" "buffer" "pane" + "base")) + (:file "cl-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) + (:file "html-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) + (:file "prolog-syntax" :depends-on ("packages" "base" "syntax" "pane" "buffer")) + (:file "ttcn3-syntax" :depends-on ("packages" "buffer" "syntax" "base" "pane")) + (:file "lisp-syntax" :depends-on ("packages" "syntax" "buffer" "base" "pane")) + (:file "esa" :depends-on ("packages")) + (:file "gui" :depends-on ("packages" "syntax" "base" "buffer" "undo" "pane" + "esa" "kill-ring" "io" "text-syntax" "abbrev")) + (:file "slidemacs" :depends-on ("packages" "buffer" "syntax" "base" "pane")) + (:file "slidemacs-gui" :depends-on ("packages" "slidemacs" "pane" "buffer" "syntax")))) + +(defsystem :climacs.tests + :depends-on (:climacs) + :components + ((:file "rt" :pathname #p"testing/rt.lisp") + (:file "buffer-test" :depends-on ("rt")) + (:file "base-test" :depends-on ("rt")))) #+asdf (defmethod asdf:perform :around ((o asdf:compile-op)

1 0

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

24 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10692 Modified Files: lisp-syntax.lisp Log Message: Many improvements to Lisp syntax. (thanks to John Q Splittist) Date: Sun Jul 24 10:06:50 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.14 climacs/lisp-syntax.lisp:1.15 --- climacs/lisp-syntax.lisp:1.14 Wed Jul 20 09:16:37 2005 +++ climacs/lisp-syntax.lisp Sun Jul 24 10:06:50 2005 @@ -94,10 +94,10 @@ (:documentation "In this state, the lexer is working inside a long comment delimited by #| and |#.")) -(define-lexer-state lexer-symbol-state () +(define-lexer-state lexer-escaped-token-state () () - (:documentation "In this state, the lexer is working inside a symbol - delimited by | and |.")) + (:documentation "In this state, the lexer is accumulating a token + and an odd number of multiple escapes have been seen.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; this should go in syntax.lisp or lr-syntax.lisp @@ -164,17 +164,15 @@ (defclass error-lexeme (lisp-lexeme) ()) (defclass left-parenthesis-lexeme (lisp-lexeme) ()) +(defclass simple-vector-start-lexeme (lisp-lexeme) ()) (defclass right-parenthesis-lexeme (lisp-lexeme) ()) (defclass quote-lexeme (lisp-lexeme) ()) (defclass backquote-lexeme (lisp-lexeme) ()) (defclass comma-lexeme (lisp-lexeme) ()) (defclass form-lexeme (form lisp-lexeme) ()) -(defclass token-lexeme (form-lexeme) ()) (defclass character-lexeme (form-lexeme) ()) (defclass function-lexeme (lisp-lexeme) ()) (defclass line-comment-start-lexeme (lisp-lexeme) ()) -(defclass symbol-start-lexeme (lisp-lexeme) ()) -(defclass symbol-end-lexeme (lisp-lexeme) ()) (defclass long-comment-start-lexeme (lisp-lexeme) ()) (defclass comment-end-lexeme (lisp-lexeme) ()) (defclass string-start-lexeme (lisp-lexeme) ()) @@ -182,9 +180,21 @@ (defclass word-lexeme (lisp-lexeme) ()) (defclass delimiter-lexeme (lisp-lexeme) ()) (defclass text-lexeme (lisp-lexeme) ()) +(defclass sharpsign-equals-lexeme (lisp-lexeme) ()) +(defclass sharpsign-sharpsign-lexeme (form-lexeme) ()) (defclass reader-conditional-positive-lexeme (lisp-lexeme) ()) (defclass reader-conditional-negative-lexeme (lisp-lexeme) ()) (defclass uninterned-symbol-lexeme (lisp-lexeme) ()) +(defclass readtime-evaluation-lexeme (lisp-lexeme) ()) +(defclass array-start-lexeme (lisp-lexeme) ()) +(defclass structure-start-lexeme (lisp-lexeme) ()) +(defclass pathname-start-lexeme (lisp-lexeme) ()) +(defclass undefined-reader-macro-lexeme (lisp-lexeme) ()) +(defclass bit-vector-lexeme (form-lexeme) ()) +(defclass token-mixin () ()) +(defclass complete-token-lexeme (token-mixin form-lexeme) ()) +(defclass multiple-escape-start-lexeme (lisp-lexeme) ()) +(defclass multiple-escape-end-lexeme (lisp-lexeme) ()) (defmethod skip-inter ((syntax lisp-syntax) state scan) (macrolet ((fo () `(forward-object scan))) @@ -210,46 +220,89 @@ (let ((object (object-after scan))) (case object (#\( (fo) (make-instance 'left-parenthesis-lexeme)) + ;#\) is an error (#\' (fo) (make-instance 'quote-lexeme)) - (#\` (fo) (make-instance 'backquote-lexeme)) - (#\, (fo) (make-instance 'comma-lexeme)) - (#\" (fo) (make-instance 'string-start-lexeme)) (#\; (fo) (loop until (or (end-of-buffer-p scan) (end-of-line-p scan) (not (eql (object-after scan) #\;))) do (fo)) (make-instance 'line-comment-start-lexeme)) - (#\| (fo) (make-instance 'symbol-start-lexeme)) + (#\" (fo) (make-instance 'string-start-lexeme)) + (#\` (fo) (make-instance 'backquote-lexeme)) + (#\, (fo) (make-instance 'comma-lexeme)) (#\# (fo) - ( if (end-of-buffer-p scan) - (make-instance 'error-lexeme) - (case (object-after scan) - (#\\ (fo) - (cond ((end-of-buffer-p scan) - (make-instance 'error-lexeme)) - ((not (constituentp (object-after scan))) - (fo) (make-instance 'character-lexeme)) - (t (loop until (end-of-buffer-p scan) - while (constituentp (object-after scan)) - do (fo)) - (make-instance 'character-lexeme)))) - (#\' (fo) - (make-instance 'function-lexeme)) - (#\| (fo) - (make-instance 'long-comment-start-lexeme)) - (#\+ (fo) - (make-instance 'reader-conditional-positive-lexeme)) - (#\- (fo) - (make-instance 'reader-conditional-negative-lexeme)) - (#\: (fo) - (make-instance 'uninterned-symbol-lexeme)) - (t (fo) (make-instance 'error-lexeme))))) - (t (cond ((constituentp object) - (loop until (end-of-buffer-p scan) - while (constituentp (object-after scan)) - do (fo)) - (make-instance 'token-lexeme)) + (cond ((end-of-buffer-p scan) + (make-instance 'error-lexeme)) + (t + (loop until (end-of-buffer-p scan) + while (digit-char-p (object-after scan)) + do (fo)) + (if (end-of-buffer-p scan) + (make-instance 'error-lexeme) + (case (object-after scan) + ((#\Backspace #\Tab #\Newline #\Linefeed + #\Page #\Return #\Space #\)) + (fo) + (make-instance 'error-lexeme)) + (#\\ (fo) + (cond ((end-of-buffer-p scan) + (make-instance 'error-lexeme)) + ((not (constituentp (object-after scan))) + (fo) (make-instance 'character-lexeme)) + (t (loop until (end-of-buffer-p scan) + while (constituentp (object-after scan)) + do (fo)) + (make-instance 'character-lexeme)))) + (#\' (fo) + (make-instance 'function-lexeme)) + (#\( (fo) + (make-instance 'simple-vector-start-lexeme)) + (#\* (fo) + (loop until (end-of-buffer-p scan) + while (or (eql (object-after scan) #\1) + (eql (object-after scan) #\0)) + do (fo)) + (if (and (not (end-of-buffer-p scan)) + (constituentp (object-after scan))) + (make-instance 'error-lexeme) + (make-instance 'bit-vector-lexeme))) + (#\: (fo) + (make-instance 'uninterned-symbol-lexeme)) + (#\. (fo) + (make-instance 'readtime-evaluation-lexeme)) + ;((#\B #\b) ) + ;((#\O #\o) ) + ;((#\X #\x) ) + ;((#\R #\r) ) + ;((#\C #\c) ) + ((#\A #\a) (fo) + (make-instance 'array-start-lexeme)) + ((#\S #\s) (fo) + (cond ((and (not (end-of-buffer-p scan)) + (eql (object-after scan) #\()) + (fo) + (make-instance 'structure-start-lexeme)) + (t (make-instance 'error-lexeme)))) + ((#\P #\p) (fo) + (make-instance 'pathname-start-lexeme)) + (#\= (fo) + (make-instance 'sharpsign-equals-lexeme)) + (#\# (fo) + (make-instance 'sharpsign-sharpsign-lexeme)) + (#\+ (fo) + (make-instance 'reader-conditional-positive-lexeme)) + (#\- (fo) + (make-instance 'reader-conditional-negative-lexeme)) + (#\| (fo) + (make-instance 'long-comment-start-lexeme)) + (#\< (fo) + (make-instance 'error-lexeme)) + (t (fo) (make-instance 'undefined-reader-macro-lexeme))))))) + (#\| (fo) (make-instance 'multiple-escape-start-lexeme)) + (t (cond ((or (constituentp object) + (eql object #\\)) + (lex-token scan)) (t (fo) (make-instance 'error-lexeme)))))))) (defmethod lex ((syntax lisp-syntax) (state lexer-list-state) scan) @@ -315,27 +368,50 @@ (make-instance 'word-lexeme)) (t (fo) (make-instance 'delimiter-lexeme))))) -(defmethod skip-inter ((syntax lisp-syntax) (state lexer-symbol-state) scan) +(defun lex-token (scan) (macrolet ((fo () `(forward-object scan))) - (loop while (and (end-of-line-p scan) - (not (end-of-buffer-p scan))) - do (fo))) - (not (end-of-buffer-p scan))) - -(defmethod lex ((syntax lisp-syntax) (state lexer-symbol-state) scan) - (macrolet ((fo () `(forward-object scan))) - (cond ((eql (object-after scan) #\|) + (tagbody + start + (when (end-of-buffer-p scan) + (return-from lex-token (make-instance 'complete-token-lexeme))) + (when (constituentp (object-after scan)) + (fo) + (go start)) + (when (eql (object-after scan) #\\) + (fo) + (when (end-of-buffer-p scan) + (return-from lex-token (make-instance 'error-lexeme))) + (fo) + (go start)) + (when (eql (object-after scan) #\|) + (fo) + (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) + (return-from lex-token (make-instance 'complete-token-lexeme))))) + +(defmethod lex ((syntax lisp-syntax) (state lexer-escaped-token-state) scan) + (let ((bars-seen 0)) + (macrolet ((fo () `(forward-object scan))) + (tagbody + start + (when (end-of-buffer-p scan) + (return-from lex (make-instance 'error-lexeme))) + (when (eql (object-after scan) #\\) + (fo) + (when (end-of-buffer-p scan) + (return-from lex (make-instance 'error-lexeme))) (fo) - (make-instance 'symbol-end-lexeme)) - (t (loop do (cond ((or (end-of-line-p scan) - (eql (object-after scan) #\|)) - (return (make-instance 'text-lexeme))) - ((eql (object-after scan) #\\) - (fo) - (if (end-of-line-p scan) - (return (make-instance 'text-lexeme)) - (fo))) - (t (fo)))))))) + (go start)) + (when (eql (object-after scan) #\|) + (incf bars-seen) + (fo) + (go start)) + (unless (whitespacep (object-after scan)) + (fo) + (go start)) + (return-from lex + (if (oddp bars-seen) + (make-instance 'multiple-escape-end-lexeme) + (make-instance 'text-lexeme))))))) (defmethod lex ((syntax lisp-syntax) (state lexer-error-state) scan) (macrolet ((fo () `(forward-object scan))) @@ -490,6 +566,28 @@ (define-lisp-action (|( form* | (eql nil)) (reduce-until-type incomplete-list-form left-parenthesis-lexeme)) +;;;;;;;;;;;;;;;; Simple Vector + +;;; parse trees +(defclass simple-vector-form (list-form) ()) +(defclass complete-simple-vector-form (complete-list-form) ()) +(defclass incomplete-simple-vector-form (incomplete-list-form) ()) + +(define-parser-state |#( form* | (lexer-list-state form-may-follow) ()) +(define-parser-state |#( form* ) | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow simple-vector-start-lexeme) |#( form* |) +(define-new-lisp-state (|#( form* | form) |#( form* |) +(define-new-lisp-state (|#( form* | right-parenthesis-lexeme) |#( form* ) |) + +;;; reduce according to the rule form -> #( form* ) +(define-lisp-action (|#( form* ) | t) + (reduce-until-type complete-simple-vector-form simple-vector-start-lexeme)) + +;;; reduce at the end of the buffer +(define-lisp-action (|#( form* | (eql nil)) + (reduce-until-type incomplete-simple-vector-form simple-vector-start-lexeme)) + ;;;;;;;;;;;;;;;; String ;;; parse trees @@ -532,8 +630,6 @@ ;;;;;;;;;;;;;;;; Long comment -;; FIXME this does not work for nested comments - ;;; parse trees (defclass long-comment-form (form) ()) (defclass complete-long-comment-form (long-comment-form) ()) @@ -557,27 +653,27 @@ (define-lisp-action (|#\| word* | (eql nil)) (reduce-until-type incomplete-long-comment-form long-comment-start-lexeme)) -;;;;;;;;;;;;;;;; Symbol name surrounded with vertical bars +;;;;;;;;;;;;;;;; Token (number or symbol) ;;; parse trees -(defclass symbol-form (form) ()) -(defclass complete-symbol-form (symbol-form) ()) -(defclass incomplete-symbol-form (symbol-form incomplete-form-mixin) ()) - -(define-parser-state |\| text* | (lexer-symbol-state parser-state) ()) -(define-parser-state |\| text* \| | (lexer-toplevel-state parser-state) ()) - -(define-new-lisp-state (form-may-follow symbol-start-lexeme) |\| text* |) -(define-new-lisp-state (|\| text* | text-lexeme) |\| text* |) -(define-new-lisp-state (|\| text* | symbol-end-lexeme) |\| text* \| |) - -;;; reduce according to the rule form -> | text* | -(define-lisp-action (|\| text* \| | t) - (reduce-until-type complete-symbol-form symbol-start-lexeme)) +(defclass token-form (form token-mixin) ()) +(defclass complete-token-form (token-form) ()) +(defclass incomplete-token-form (token-form) ()) + +(define-parser-state | m-e-start text* | (lexer-escaped-token-state parser-state) ()) +(define-parser-state | m-e-start text* m-e-end | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow multiple-escape-start-lexeme) | m-e-start text* |) +(define-new-lisp-state (| m-e-start text* | text-lexeme) | m-e-start text* |) +(define-new-lisp-state (| m-e-start text* | multiple-escape-end-lexeme) | m-e-start text* m-e-end |) + +;;; reduce according to the rule form -> m-e-start text* m-e-end +(define-lisp-action (| m-e-start text* m-e-end | t) + (reduce-until-type complete-token-form multiple-escape-start-lexeme)) ;;; reduce at the end of the buffer -(define-lisp-action (|\| text* | (eql nil)) - (reduce-until-type incomplete-symbol-form symbol-start-lexeme)) +(define-lisp-action (| m-e-start text* | (eql nil)) + (reduce-until-type incomplete-token-form multiple-escape-start-lexeme)) ;;;;;;;;;;;;;;;; Quote @@ -680,6 +776,106 @@ (define-lisp-action (|#: form | t) (reduce-fixed-number uninterned-symbol-form 2)) +;;;;;;;;;;;;;;;; readtime evaluation + +;;; parse trees +(defclass readtime-evaluation-form (form) ()) + +(define-parser-state |#. | (form-may-follow) ()) +(define-parser-state |#. form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow readtime-evaluation-lexeme) |' |) +(define-new-lisp-state (|#. | form) |#. form |) + +;;; reduce according to the rule form -> #. form +(define-lisp-action (|#. form | t) + (reduce-fixed-number readtime-evaluation-form 2)) + +;;;;;;;;;;;;;;;; sharpsign equals + +;;; parse trees +(defclass sharpsign-equals-form (form) ()) + +(define-parser-state |#= | (form-may-follow) ()) +(define-parser-state |#= form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow sharpsign-equals-lexeme) |' |) +(define-new-lisp-state (|#= | form) |#= form |) + +;;; reduce according to the rule form -> #= form +(define-lisp-action (|#= form | t) + (reduce-fixed-number sharpsign-equals-form 2)) + +;;;;;;;;;;;;;;;; array + +;;; parse trees +(defclass array-form (form) ()) + +(define-parser-state |#A | (form-may-follow) ()) +(define-parser-state |#A form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow array-start-lexeme) |' |) +(define-new-lisp-state (|#A | form) |#A form |) + +;;; reduce according to the rule form -> #A form +(define-lisp-action (|#A form | t) + (reduce-fixed-number array-start-form 2)) + +;;;;;;;;;;;;;;;; structure + +;;; parse trees +(defclass structure-form (list-form) ()) +(defclass complete-structure-form (complete-list-form) ()) +(defclass incomplete-structure-form (incomplete-list-form) ()) + +(define-parser-state |#S( form* | (lexer-list-state form-may-follow) ()) +(define-parser-state |#S( form* ) | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow structure-start-lexeme) |#S( form* |) +(define-new-lisp-state (|#S( form* | form) |#S( form* |) +(define-new-lisp-state (|#S( form* | right-parenthesis-lexeme) |#S( form* ) |) + +;;; reduce according to the rule form -> #S( form* ) +(define-lisp-action (|#S( form* ) | t) + (reduce-until-type complete-structure-form structure-start-lexeme)) + +;;; reduce at the end of the buffer +(define-lisp-action (|#S( form* | (eql nil)) + (reduce-until-type incomplete-structure-form structure-start-lexeme)) + + +;;;;;;;;;;;;;;;; pathname + +;;; FIXME: #P _must_ be followed by a string + +;;; parse trees +(defclass pathname-form (form) ()) + +(define-parser-state |#P | (form-may-follow) ()) +(define-parser-state |#P form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow pathname-start-lexeme) |' |) +(define-new-lisp-state (|#P | form) |#P form |) + +;;; reduce according to the rule form -> #P form +(define-lisp-action (|#P form | t) + (reduce-fixed-number pathname-start-form 2)) + +;;;;;;;;;;;;;;;; undefined reader macro + +;;; parse trees +(defclass undefined-reader-macro-form (form) ()) + +(define-parser-state |#<other> | (form-may-follow) ()) +(define-parser-state |#<other> form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow undefined-reader-macro-lexeme) |' |) +(define-new-lisp-state (|#<other> | form) |#<other> form |) + +;;; reduce according to the rule form -> #: form +(define-lisp-action (|#: form | t) + (reduce-fixed-number uninterned-symbol-form 2)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -888,11 +1084,15 @@ (with-drawing-options (pane :ink +red+) (call-next-method))) -(defmethod display-parse-tree ((parse-symbol token-lexeme) (syntax lisp-syntax) pane) - (if (and (> (end-offset parse-symbol) (start-offset parse-symbol)) - (eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\:)) - (with-drawing-options (pane :ink +dark-violet+) - (call-next-method)) +(defmethod display-parse-tree ((parse-symbol token-mixin) (syntax lisp-syntax) pane) + (if (> (end-offset parse-symbol) (start-offset parse-symbol)) + (cond ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\:) + (with-drawing-options (pane :ink +dark-violet+) + (call-next-method))) + ((eql (buffer-object (buffer syntax) (start-offset parse-symbol)) #\&) + (with-drawing-options (pane :ink +dark-green+) + (call-next-method))) + (t (call-next-method))) (call-next-method))) (defmethod display-parse-tree ((parser-symbol lisp-lexeme) (syntax lisp-syntax) pane) @@ -957,9 +1157,6 @@ (loop for child in (cdr children) do (display-parse-tree child syntax pane)))) -(defmethod display-parse-tree ((parse-symbol symbol-form) (syntax lisp-syntax) pane) - (call-next-method)) - (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax lisp-syntax) current-p) (declare (ignore current-p)) (with-slots (top bot) pane @@ -971,7 +1168,10 @@ (display-parse-tree stack-top syntax pane)) (with-slots (top) pane (let* ((cursor-line (number-of-lines-in-region top (point pane))) - (height (text-style-height (medium-text-style pane) pane)) + (style (medium-text-style pane)) + (ascent (text-style-ascent style pane)) + (descent (text-style-descent style pane)) + (height (+ ascent descent)) (cursor-y (+ (* cursor-line (+ height (stream-vertical-spacing pane))))) (cursor-column (buffer-display-column @@ -980,8 +1180,8 @@ (cursor-x (* cursor-column (text-style-width (medium-text-style pane) pane)))) (updating-output (pane :unique-id -1) (draw-rectangle* pane - (1- cursor-x) (- cursor-y (* 0.2 height)) - (+ cursor-x 2) (+ cursor-y (* 0.8 height)) + (1- cursor-x) cursor-y + (+ cursor-x 2) (+ cursor-y ascent descent) :ink (if current-p +red+ +blue+)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -1079,46 +1279,141 @@ (defconstant keyword-package (find-package :keyword) "The KEYWORD package.") -;; FIXME: deal with #\| etc. hard to do portably. -(defun tokenize-symbol (string) - (let ((package (let ((pos (position #\: string))) - (if pos (subseq string 0 pos) nil))) - (symbol (let ((pos (position #\: string :from-end t))) - (if pos (subseq string (1+ pos)) string))) - (internp (search "::" string))) - (values symbol package internp))) - -(defun determine-case (string) - "Return two booleans LOWER and UPPER indicating whether STRING -contains lower or upper case characters." - (values (some #'lower-case-p string) - (some #'upper-case-p string))) - -;; FIXME: Escape chars are ignored -(defun casify (string) - "Convert string accoring to readtable-case." - (ecase (readtable-case *readtable*) - (:preserve string) - (:upcase (string-upcase string)) - (:downcase (string-downcase string)) - (:invert (multiple-value-bind (lower upper) (determine-case string) - (cond ((and lower upper) string) - (lower (string-upcase string)) - (upper (string-downcase string)) - (t string)))))) +;;; shamelessly replacing SWANK code +;; We first work through the string removing the characters and noting +;; which ones are escaped. We then replace each character with the +;; appropriate case version, according to the readtable. +;; Finally, we extract the package and symbol names. +;; Being in an editor, we are waaay more lenient than the reader. + +(defun parse-escapes (string) + "Return a string and a list of escaped character positions. +Uses part of the READ algorithm in CLTL2 22.1.1." + (let ((length (length string)) + (index 0) + irreplaceables chars) + (tagbody + step-8 + (unless (< index length) (go end)) + (cond + ((char/= (char string index) #\\ #\|) + (push (char string index) chars) + (incf index) + (go step-8)) + ((char= (char string index) #\\) + (push (length chars) irreplaceables) + (incf index) + (unless (< index length) (go end)) + (push (char string index) chars) + (incf index) + (go step-8)) + ((char= (char string index) #\|) + (incf index) + (go step-9))) + step-9 + (unless (< index length) (go end)) + (cond + ((char/= (char string index) #\\ #\|) + (push (length chars) irreplaceables) + (push (char string index) chars) + (incf index) + (go step-9)) + ((char= (char string index) #\\) + (push (length chars) irreplaceables) + (incf index) + (unless (< index length) (go end)) + (push (char string index) chars) + (incf index) + (go step-9)) + ((char= (char string index) #\|) + (incf index) + (go step-8))) + end + (return-from parse-escapes + (values (coerce (nreverse chars) 'string) + (nreverse irreplaceables)))))) + +(defun invert-cases (string &optional (irreplaceables nil)) + "Returns two flags: unescaped upper-case and lower-case chars in STRING." + (loop for index below (length string) + with upper = nil + with lower = nil + when (not (member index irreplaceables)) + if (upper-case-p (char string index)) + do (setf upper t) end + if (lower-case-p (char string index)) + do (setf lower t) end + finally (return (values upper lower)))) + +(defun replace-case (string &optional (case (readtable-case *readtable*)) + (irreplaceables nil)) + "Convert string according to readtable-case." + (multiple-value-bind (upper lower) (invert-cases string irreplaceables) + (loop for index below (length string) + as char = (char string index) then (char string index) + if (member index irreplaceables) + collect char into chars + else + collect (ecase case + (:preserve char) + (:upcase (char-upcase char)) + (:downcase (char-downcase char)) + (:invert (cond ((and lower upper) char) + (lower (char-upcase char)) + (upper (char-downcase char)) + (t char)))) into chars + finally (return (coerce chars 'string))))) + +(defun parse-token (string &optional (case (readtable-case *readtable*))) + "Extracts the symbol-name and package name from STRING +and whether the symbol-name was separated from the package by a double colon." + (multiple-value-bind (string irreplaceables) (parse-escapes string) + (let ((string (replace-case string case irreplaceables)) + package-name symbol-name internalp) + (loop for index below (length string) + with symbol-start = 0 + when (and (char= (char string index) #\:) + (not (member index irreplaceables))) + do (setf package-name (subseq string 0 index)) + (if (and (< (incf index) (length string)) + (char= (char string index) #\:) + (not (member index irreplaceables))) + (setf symbol-start (1+ index) + internalp t) + (setf symbol-start index)) + (loop-finish) + finally (setf symbol-name (subseq string symbol-start))) + (values symbol-name package-name internalp)))) + +#| +;;; Compare CLHS 23.1.2.1 + (defun test-parse-token () + (let ((*readtable* (copy-readtable nil))) + (format t "READTABLE-CASE Input Symbol-name Token-name~ + ~%------------------------------------------------------~ + ~%") + (dolist (readtable-case '(:upcase :downcase :preserve :invert)) + (dolist (input '("ZEBRA" "Zebra" "zebra" "\\zebra" "\\Zebra" "z|ebr|a" + "|ZE\\bRA|" "ze\\|bra")) + (format t "~&:~A~16T~A~30T~A~44T~A" + (string-upcase readtable-case) + input + (progn (setf (readtable-case *readtable*) readtable-case) + (symbol-name (read-from-string input))) + (parse-token input readtable-case)))))) +|# (defun parse-symbol (string &optional (package *package*)) "Find the symbol named STRING. -Return the symbol and a flag indicating whether the symbols was found." - (multiple-value-bind (sname pname) (tokenize-symbol string) - (let ((package (cond ((string= pname "") keyword-package) - (pname (find-package (casify pname))) - (t package)))) +Return the symbol and a flag indicating whether the symbol was found." + (multiple-value-bind (symbol-name package-name) (parse-token string) + (let ((package (cond ((string= package-name "") keyword-package) + (package-name (find-package package-name)) + (t package)))) (if package - (find-symbol (casify sname) package) + (find-symbol symbol-name package) (values nil nil))))) - (defun token-to-symbol (syntax token) (let ((package (or (slot-value syntax 'package) (find-package :common-lisp))) @@ -1145,7 +1440,7 @@ ;; before first element (values tree 1) (let ((first-child (elt (children tree) 1))) - (cond ((and (typep first-child 'token-lexeme) + (cond ((and (typep first-child 'token-mixin) (token-to-symbol syntax first-child)) (compute-list-indentation syntax (token-to-symbol syntax first-child) tree path)) ((null (cdr path))

1 0

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

24 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31844 Modified Files: esa.lisp gui.lisp packages.lisp Log Message: Climacs no longer uses the command table of the application frame, but now has a command table per pane. Eventually, this command table will inherit from a syntax-specific one, but that is not implemented yet. The global-climacs-table inherits from the global-esa-table. The commands com-quit and com-extended have been moved to the clobal-esa-table. Handling modified buffers before quitting has been moved to an :around method on frame-exit. Date: Sun Jul 24 07:10:49 2005 Author: rstrandh Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.9 climacs/esa.lisp:1.10 --- climacs/esa.lisp:1.9 Fri Jul 22 15:15:47 2005 +++ climacs/esa.lisp Sun Jul 24 07:10:47 2005 @@ -64,7 +64,8 @@ (defclass esa-pane-mixin () (;; allows a certain number of commands to have some minimal memory - (previous-command :initform nil :accessor previous-command))) + (previous-command :initform nil :accessor previous-command) + (command-table :initarg :command-table :accessor command-table))) (defmethod handle-repaint :before ((pane esa-pane-mixin) region) (declare (ignore region)) @@ -79,9 +80,7 @@ (recordingp :initform nil :accessor recordingp) (executingp :initform nil :accessor executingp) (recorded-keys :initform '() :accessor recorded-keys) - (remaining-keys :initform '() :accessor remaining-keys) - ;; temporary hack. The command table should be buffer or pane specific - (esa-command-table :initarg :esa-command-table :reader command-table))) + (remaining-keys :initform '() :accessor remaining-keys))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -239,9 +238,9 @@ (progn (handler-case (with-input-context - (`(command :command-table ,(command-table frame))) + (`(command :command-table ,(command-table (car (windows frame))))) (object) - (process-gestures frame (command-table frame)) + (process-gestures frame (command-table (car (windows frame)))) (t (execute-frame-command frame object) (setq maybe-error nil))) @@ -314,6 +313,22 @@ (set-key 'com-quit 'global-esa-table '((#\x :control) (#\c :control))) +(define-command (com-extended-command + :name t + :command-table global-esa-table) + () + (let ((item (handler-case + (accept + `(command :command-table + ,(command-table (car (windows *application-frame*)))) + :prompt "Extended Command") + (error () (progn (beep) + (display-message "No such command") + (return-from com-extended-command nil)))))) + (execute-frame-command *application-frame* item))) + +(set-key 'com-extended-command 'global-esa-table '((#\x :meta))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; example application @@ -344,7 +359,8 @@ (win (let* ((my-pane (make-pane 'example-pane :width 900 :height 400 - :display-function 'display-my-pane)) + :display-function 'display-my-pane + :command-table 'global-example-table)) (my-info-pane (make-pane 'example-info-pane :master-pane my-pane @@ -370,8 +386,7 @@ "Starts up the example application" (let ((frame (make-application-frame 'example - :width width :height height - :esa-command-table 'global-example-table))) + :width width :height height))) (run-frame-top-level frame))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.163 climacs/gui.lisp:1.164 --- climacs/gui.lisp:1.163 Fri Jul 22 15:15:47 2005 +++ climacs/gui.lisp Sun Jul 24 07:10:47 2005 @@ -58,7 +58,8 @@ :width 900 :height 400 :end-of-line-action :scroll :incremental-redisplay t - :display-function 'display-win)) + :display-function 'display-win + :command-table 'global-climacs-table)) (info-pane (make-pane 'climacs-info-pane :master-pane extended-pane @@ -91,8 +92,7 @@ (defun climacs (&key (width 900) (height 400)) "Starts up a climacs session" (let ((frame (make-application-frame - 'climacs :width width :height height - :esa-command-table 'global-climacs-table))) + 'climacs :width width :height height))) (run-frame-top-level frame))) (defun display-info (frame pane) @@ -159,10 +159,13 @@ do (when (modified-p buffer) (setf (needs-saving buffer) t)))) +(make-command-table 'global-climacs-table :errorp nil :inherit-from '(global-esa-table)) + (defmacro define-named-command (command-name args &body body) - `(define-climacs-command ,(if (listp command-name) - `(,@command-name :name t) - `(,command-name :name t)) ,args ,@body)) + `(define-command ,(if (listp command-name) + `(,@command-name :name t :command-table global-climacs-table) + `(,command-name :name t :command-table global-climacs-table)) + ,args ,@body)) (define-named-command com-toggle-overwrite-mode () (with-slots (overwrite-mode) (current-window) @@ -436,13 +439,6 @@ (possibly-fill-line) (setf (offset point) (offset point-backup))))) -(define-command com-extended-command () - (let ((item (handler-case (accept 'command :prompt "Extended Command") - (error () (progn (beep) - (display-message "No such command") - (return-from com-extended-command nil)))))) - (execute-frame-command *application-frame* item))) - (eval-when (:compile-toplevel :load-toplevel) (define-presentation-type completable-pathname () :inherit-from 'pathname)) @@ -597,23 +593,23 @@ (save-buffer buffer) (display-message "No changes need to be saved from ~a" (name buffer))))) -(define-named-command (com-quit) () - (loop for buffer in (buffers *application-frame*) +(defmethod frame-exit :around ((frame climacs)) + (loop for buffer in (buffers frame) when (and (needs-saving buffer) (filepath buffer) (handler-case (accept 'boolean :prompt (format nil "Save buffer: ~a ?" (name buffer))) (error () (progn (beep) (display-message "Invalid answer") - (return-from com-quit nil))))) + (return-from frame-exit nil))))) do (save-buffer buffer)) (when (or (notany #'(lambda (buffer) (and (needs-saving buffer) (filepath buffer))) - (buffers *application-frame*)) + (buffers frame)) (handler-case (accept 'boolean :prompt "Modified buffers exist. Quit anyway?") (error () (progn (beep) (display-message "Invalid answer") - (return-from com-quit nil))))) - (frame-exit *application-frame*))) + (return-from frame-exit nil))))) + (call-next-method))) (define-named-command com-write-buffer () (let ((filepath (accept 'completable-pathname @@ -803,7 +799,8 @@ :name 'win :end-of-line-action :scroll :incremental-redisplay t - :display-function 'display-win)) + :display-function 'display-win + :command-table 'global-climacs-table)) (vbox (vertically () (scrolling () extended-pane) @@ -1254,9 +1251,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Global and dead-escape command tables - -(make-command-table 'global-climacs-table :errorp nil) +;;; Dead-escape command tables (make-command-table 'dead-escape-climacs-table :errorp nil) @@ -1306,7 +1301,6 @@ (global-set-key '(#\u :meta) 'com-upcase-word) (global-set-key '(#\l :meta) 'com-downcase-word) (global-set-key '(#\c :meta) 'com-capitalize-word) -(global-set-key '(#\x :meta) 'com-extended-command) (global-set-key '(#\y :meta) 'com-rotate-yank) (global-set-key '(#\z :meta) 'com-zap-to-character) (global-set-key '(#\w :meta) 'com-copy-out) @@ -1371,7 +1365,6 @@ (c-x-set-key '(#\)) 'com-end-kbd-macro) (c-x-set-key '(#\b) 'com-switch-to-buffer) (c-x-set-key '(#\e) 'com-call-last-kbd-macro) -(c-x-set-key '(#\c :control) 'com-quit) (c-x-set-key '(#\f :control) 'com-find-file) (c-x-set-key '(#\i) 'com-insert-file) (c-x-set-key '(#\k) 'com-kill-buffer) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.67 climacs/packages.lisp:1.68 --- climacs/packages.lisp:1.67 Thu Jul 21 14:24:30 2005 +++ climacs/packages.lisp Sun Jul 24 07:10:48 2005 @@ -174,6 +174,7 @@ #:esa-frame-mixin #:windows #:recordingp #:executingp #:*numeric-argument-p* #:*current-gesture* #:esa-top-level #:simple-command-loop + #:global-esa-table ;; remove these when kbd macros move to esa #:recorded-keys #:remaining-keys))

1 0

[climacs-cvs] CVS update: climacs/esa.lisp climacs/gui.lisp
by rstrandh＠common-lisp.net 22 Jul '05

22 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv9411 Modified Files: esa.lisp gui.lisp Log Message: Fixed a bug that made extended commands unavailable. Date: Fri Jul 22 15:15:47 2005 Author: rstrandh Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.8 climacs/esa.lisp:1.9 --- climacs/esa.lisp:1.8 Fri Jul 22 09:05:44 2005 +++ climacs/esa.lisp Fri Jul 22 15:15:47 2005 @@ -81,7 +81,7 @@ (recorded-keys :initform '() :accessor recorded-keys) (remaining-keys :initform '() :accessor remaining-keys) ;; temporary hack. The command table should be buffer or pane specific - (command-table :initarg :command-table :reader command-table))) + (esa-command-table :initarg :esa-command-table :reader command-table))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -371,7 +371,7 @@ (let ((frame (make-application-frame 'example :width width :height height - :command-table 'global-example-table))) + :esa-command-table 'global-example-table))) (run-frame-top-level frame))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.162 climacs/gui.lisp:1.163 --- climacs/gui.lisp:1.162 Fri Jul 22 07:35:06 2005 +++ climacs/gui.lisp Fri Jul 22 15:15:47 2005 @@ -92,7 +92,7 @@ "Starts up a climacs session" (let ((frame (make-application-frame 'climacs :width width :height height - :command-table 'global-climacs-table))) + :esa-command-table 'global-climacs-table))) (run-frame-top-level frame))) (defun display-info (frame pane)

1 0

[climacs-cvs] CVS update: climacs/esa.lisp
by rstrandh＠common-lisp.net 22 Jul '05

22 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18396 Modified Files: esa.lisp Log Message: Implemented `shallow command tables'. Made the ESA command loop search for key bindings in the inherit-from list as well. Changed the ESA example so that com-quit is in the esa-global-table and the example-global-table inherits from the esa-global-table. Next, it would be good to create many small command tables that contain (say) all the commands that have to do with multi-windowing (C-x 2, C-x 3, etc), all the commands that have to do with kbd macros, all the commands that have to do with undo, etc. Also, next, rearrange Climacs itself to take advantage of all this. Date: Fri Jul 22 09:05:44 2005 Author: rstrandh Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.7 climacs/esa.lisp:1.8 --- climacs/esa.lisp:1.7 Fri Jul 22 07:36:58 2005 +++ climacs/esa.lisp Fri Jul 22 09:05:44 2005 @@ -97,6 +97,13 @@ (setf table (command-menu-item-value item))) finally (return item))) +(defun find-gestures-with-inheritance (gestures start-table) + (or (find-gestures gestures start-table) + (some (lambda (table) + (find-gestures-with-inheritance gestures table)) + (command-table-inherit-from + (find-command-table start-table))))) + (defparameter *current-gesture* nil) (defun meta-digit (gesture) @@ -185,7 +192,7 @@ (setf *current-gesture* (esa-read-gesture)) (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures command-table))) + (let ((item (find-gestures-with-inheritance gestures command-table))) (cond ((not item) (beep) (return)) @@ -252,7 +259,7 @@ (redisplay-frame-panes *application-frame*) (loop while ,loop-condition as ,gesture = (esa-read-gesture) - as ,item = (find-gestures (list ,gesture) ,command-table) + as ,item = (find-gestures-with-inheritance (list ,gesture) ,command-table) do (cond ((and ,item (eq (command-menu-item-type ,item) :command)) (setf *current-gesture* ,gesture) (let ((,command (command-menu-item-value ,item))) @@ -294,7 +301,18 @@ (ensure-subtable table (car gestures)) (cdr gestures)))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; standard key bindings +;;; global + +(define-command-table global-esa-table) + +(define-command (com-quit :name t :command-table global-esa-table) () + (frame-exit *application-frame*)) + +(set-key 'com-quit 'global-esa-table '((#\x :control) (#\c :control))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -360,9 +378,5 @@ ;;; ;;; Commands and key bindings -(define-command-table global-example-table) - -(define-command (com-quit :name t :command-table global-example-table) () - (frame-exit *application-frame*)) +(define-command-table global-example-table :inherit-from (global-esa-table)) -(set-key 'com-quit 'global-example-table '((#\x :control) (#\c :control)))

1 0

[climacs-cvs] CVS update: climacs/esa.lisp
by rstrandh＠common-lisp.net 22 Jul '05

22 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12597 Modified Files: esa.lisp Log Message: Fixed the FIXMEs by replacing `512' by (make-modifier-state :control) Date: Fri Jul 22 07:36:59 2005 Author: rstrandh Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.6 climacs/esa.lisp:1.7 --- climacs/esa.lisp:1.6 Fri Jul 22 07:35:06 2005 +++ climacs/esa.lisp Fri Jul 22 07:36:58 2005 @@ -137,10 +137,14 @@ (defun read-numeric-argument (&key (stream *standard-input*)) (let ((gesture (esa-read-gesture))) - (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME + (cond ((event-matches-gesture-name-p + gesture + '(:keyboard #\u (make-modifier-state :control))) (let ((numarg 4)) (loop for gesture = (esa-read-gesture) - while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME + while (event-matches-gesture-name-p + gesture + '(:keyboard #\u (make-modifier-state :control))) do (setf numarg (* 4 numarg)) finally (esa-unread-gesture gesture stream)) (let ((gesture (esa-read-gesture))) @@ -220,7 +224,7 @@ (let ((*standard-output* (car windows)) (*standard-input* (frame-standard-input frame)) (*print-pretty* nil) - (*abort-gestures* '((:keyboard #\g 512)))) + (*abort-gestures* `((:keyboard #\g ,(make-modifier-state :control))))) (redisplay-frame-panes frame :force-p t) (loop for maybe-error = t

1 0

[climacs-cvs] CVS update: climacs/esa.lisp climacs/gui.lisp
by rstrandh＠common-lisp.net 22 Jul '05

22 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv12545 Modified Files: esa.lisp gui.lisp Log Message: Removed functions find-climacs-pane and find-real-pane because they are no longer needed. Removed stupid names from panes, because they are not needed. Wrote a new version of set-key that can take a list of key strokes and that creates nested command tables as needed. Modified the esa example to take advantage of this new feature. Now, Climacs itself should probably be modified to take advantage of it. Date: Fri Jul 22 07:35:07 2005 Author: rstrandh Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.5 climacs/esa.lisp:1.6 --- climacs/esa.lisp:1.5 Thu Jul 21 14:24:30 2005 +++ climacs/esa.lisp Fri Jul 22 07:35:06 2005 @@ -208,13 +208,6 @@ (car command) command))) -(defun find-real-pane (vbox) - (first (sheet-children - (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane)) - (sheet-children - (find-if (lambda (pane) (typep pane 'scroller-pane)) - (sheet-children vbox))))))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Top level @@ -270,6 +263,37 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; comand table manipulation + +(defun ensure-subtable (table gesture) + (let* ((event (make-instance + 'key-press-event + :key-name nil + :key-character (car gesture) + :modifier-state (apply #'make-modifier-state (cdr gesture)))) + (item (find-keystroke-item event table :errorp nil))) + (when (or (null item) (not (eq (command-menu-item-type item) :menu))) + (let ((name (gensym))) + (make-command-table name :errorp nil) + (add-menu-item-to-command-table table (symbol-name name) + :menu name + :keystroke gesture))) + (command-menu-item-value + (find-keystroke-item event table :errorp nil)))) + + +(defun set-key (command table gestures) + (if (null (cdr gestures)) + (add-command-to-command-table + command table :keystroke (car gestures) :errorp nil) + (set-key command + (ensure-subtable table (car gestures)) + (cdr gestures)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; example application (defclass example-info-pane (info-pane) @@ -298,7 +322,6 @@ (win (let* ((my-pane (make-pane 'example-pane :width 900 :height 400 - :name 'my-pane :display-function 'display-my-pane)) (my-info-pane (make-pane 'example-info-pane @@ -329,29 +352,13 @@ :command-table 'global-example-table))) (run-frame-top-level frame))) -(define-command-table global-example-table) - -(define-command (com-quit :name t :command-table global-example-table) () - (frame-exit *application-frame*)) - -(defun set-key (command table gesture) - (add-command-to-command-table - command table :keystroke gesture :errorp nil)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; C-x command table - -(make-command-table 'global-c-x-example-table :errorp nil) - -(add-menu-item-to-command-table 'global-example-table "C-x" - :menu 'global-c-x-example-table - :keystroke '(#\x :control)) - -(set-key 'com-quit 'global-c-x-example-table - '(#\c :control)) - - +;;; Commands and key bindings +(define-command-table global-example-table) +(define-command (com-quit :name t :command-table global-example-table) () + (frame-exit *application-frame*)) +(set-key 'com-quit 'global-example-table '((#\x :control) (#\c :control))) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.161 climacs/gui.lisp:1.162 --- climacs/gui.lisp:1.161 Thu Jul 21 14:24:30 2005 +++ climacs/gui.lisp Fri Jul 22 07:35:06 2005 @@ -56,7 +56,6 @@ (win (let* ((extended-pane (make-pane 'extended-pane :width 900 :height 400 - :name 'bla :end-of-line-action :scroll :incremental-redisplay t :display-function 'display-win)) @@ -134,16 +133,6 @@ '((#\0 :meta) (#\1 :meta) (#\2 :meta) (#\3 :meta) (#\4 :meta) (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) :test #'event-matches-gesture-name-p)) - -;;; we know the vbox pane has a scroller pane and an info -;;; pane in it. The scroller pane has a viewport in it, -;;; and the viewport contains the climacs-pane as its only child. -(defun find-climacs-pane (vbox) - (first (sheet-children - (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane)) - (sheet-children - (find-if (lambda (pane) (typep pane 'scroller-pane)) - (sheet-children vbox))))))) (defun substitute-numeric-argument-p (command numargp) (substitute numargp *numeric-argument-p* command :test #'eq))

1 0

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

21 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10689 Modified Files: esa.lisp gui.lisp packages.lisp Log Message: Migration of initial common functionality from gui.lisp to esa.lisp completed. Next to migrate should be keyboard macros, pane splitting, and other functionality not specific to Climacs. Date: Thu Jul 21 14:24:31 2005 Author: rstrandh Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.4 climacs/esa.lisp:1.5 --- climacs/esa.lisp:1.4 Thu Jul 21 07:13:51 2005 +++ climacs/esa.lisp Thu Jul 21 14:24:30 2005 @@ -27,7 +27,7 @@ ;;; Info pane, a pane that displays some information about another pane (defclass info-pane (application-pane) - ((master-pane :initarg :master-pane)) + ((master-pane :initarg :master-pane :reader master-pane)) (:default-initargs :background +gray85+ :scroll-bars nil @@ -79,7 +79,9 @@ (recordingp :initform nil :accessor recordingp) (executingp :initform nil :accessor executingp) (recorded-keys :initform '() :accessor recorded-keys) - (remaining-keys :initform '() :accessor remaining-keys))) + (remaining-keys :initform '() :accessor remaining-keys) + ;; temporary hack. The command table should be buffer or pane specific + (command-table :initarg :command-table :reader command-table))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -222,7 +224,6 @@ partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (with-slots (windows) frame - (setf windows (list (find-real-pane (find-pane-named frame 'win)))) (let ((*standard-output* (car windows)) (*standard-input* (frame-standard-input frame)) (*print-pretty* nil) @@ -234,9 +235,9 @@ (progn (handler-case (with-input-context - ('(command :command-table global-example-table)) + (`(command :command-table ,(command-table frame))) (object) - (process-gestures frame 'global-example-table) + (process-gestures frame (command-table frame)) (t (execute-frame-command frame object) (setq maybe-error nil))) @@ -246,6 +247,27 @@ (redisplay-frame-panes frame)) (return-to-climacs () nil)))))) +(defmacro simple-command-loop (command-table loop-condition end-clauses) + (let ((gesture (gensym)) + (item (gensym)) + (command (gensym))) + `(progn + (redisplay-frame-panes *application-frame*) + (loop while ,loop-condition + as ,gesture = (esa-read-gesture) + as ,item = (find-gestures (list ,gesture) ,command-table) + do (cond ((and ,item (eq (command-menu-item-type ,item) :command)) + (setf *current-gesture* ,gesture) + (let ((,command (command-menu-item-value ,item))) + (unless (consp ,command) + (setf ,command (list ,command))) + (execute-frame-command *application-frame* + ,command))) + (t + (unread-gesture ,gesture) + ,@end-clauses)) + (redisplay-frame-panes *application-frame*))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; example application @@ -259,8 +281,7 @@ (defun display-info (frame pane) (declare (ignore frame)) - (with-slots (master-pane) pane - (format pane "Pane name: ~s" (pane-name master-pane)))) + (format pane "Pane name: ~s" (pane-name (master-pane pane)))) (defclass example-minibuffer-pane (minibuffer-pane) () @@ -283,6 +304,7 @@ (make-pane 'example-info-pane :master-pane my-pane :width 900))) + (setf (windows *application-frame*) (list my-pane)) (vertically () (scrolling () my-pane) @@ -301,7 +323,10 @@ (defun example (&key (width 900) (height 400)) "Starts up the example application" - (let ((frame (make-application-frame 'example :width width :height height))) + (let ((frame (make-application-frame + 'example + :width width :height height + :command-table 'global-example-table))) (run-frame-top-level frame))) (define-command-table global-example-table) Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.160 climacs/gui.lisp:1.161 --- climacs/gui.lisp:1.160 Thu Jul 21 07:13:51 2005 +++ climacs/gui.lisp Thu Jul 21 14:24:30 2005 @@ -37,14 +37,6 @@ (dabbrev-expansion-mark :initform nil) (overwrite-mode :initform nil))) -;;; a pane that displays some information about another pane -(defclass info-pane (application-pane) - ((master-pane :initarg :master-pane)) - (:default-initargs - :background +gray85+ - :scroll-bars nil - :borders nil)) - (defclass climacs-info-pane (info-pane) () (:default-initargs @@ -57,18 +49,9 @@ (:default-initargs :height 20 :max-height 20 :min-height 20)) -;;; eventually remove in favor of esa-frame-mixin -(defclass multi-frame-mixin () - ((windows :accessor windows) - (buffers :initform '() :accessor buffers) - (recordingp :initform nil :accessor recordingp) - (executingp :initform nil :accessor executingp) - (recorded-keys :initform '() :accessor recorded-keys) - (remaining-keys :initform '() :accessor remaining-keys))) - (define-application-frame climacs (standard-application-frame - multi-frame-mixin) - () + esa-frame-mixin) + ((buffers :initform '() :accessor buffers)) (:panes (win (let* ((extended-pane (make-pane 'extended-pane @@ -81,6 +64,7 @@ (make-pane 'climacs-info-pane :master-pane extended-pane :width 900))) + (setf (windows *application-frame*) (list extended-pane)) (vertically () (scrolling () extended-pane) @@ -91,7 +75,7 @@ (vertically (:scroll-bars nil) win int))) - (:top-level (climacs-top-level))) + (:top-level (esa-top-level))) (defun current-window () (car (windows *application-frame*))) @@ -107,30 +91,32 @@ (defun climacs (&key (width 900) (height 400)) "Starts up a climacs session" - (let ((frame (make-application-frame 'climacs :width width :height height))) + (let ((frame (make-application-frame + 'climacs :width width :height height + :command-table 'global-climacs-table))) (run-frame-top-level frame))) (defun display-info (frame pane) (declare (ignore frame)) - (with-slots (master-pane) pane - (let* ((buf (buffer master-pane)) - (name-info (format nil " ~a ~a Syntax: ~a~a~a~a ~a" - (if (needs-saving buf) "**" "--") - (name buf) - (name (syntax buf)) - (if (slot-value master-pane 'overwrite-mode) - " Ovwrt" - "") - (if (auto-fill-mode master-pane) - " Fill" - "") - (if (isearch-mode master-pane) - " Isearch" - "") - (if (recordingp *application-frame*) - "Def" - "")))) - (princ name-info pane)))) + (let* ((master-pane (master-pane pane)) + (buf (buffer master-pane)) + (name-info (format nil " ~a ~a Syntax: ~a~a~a~a ~a" + (if (needs-saving buf) "**" "--") + (name buf) + (name (syntax buf)) + (if (slot-value master-pane 'overwrite-mode) + " Ovwrt" + "") + (if (auto-fill-mode master-pane) + " Fill" + "") + (if (isearch-mode master-pane) + " Isearch" + "") + (if (recordingp *application-frame*) + "Def" + "")))) + (princ name-info pane))) (defun display-win (frame pane) "The display function used by the climacs application frame." @@ -141,18 +127,7 @@ (declare (ignore region)) (redisplay-frame-pane *application-frame* pane)) -(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))) - (defvar *kill-ring* (make-instance 'kill-ring :max-size 7)) -(defparameter *current-gesture* nil) (defun meta-digit (gesture) (position gesture @@ -160,68 +135,6 @@ (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) :test #'event-matches-gesture-name-p)) -(defun generic-read-gesture () - (unless (null (remaining-keys *application-frame*)) - (return-from generic-read-gesture - (pop (remaining-keys *application-frame*)))) - (loop for gesture = (read-gesture :stream *standard-input*) - until (or (characterp gesture) - (and (typep gesture 'keyboard-event) - (or (keyboard-event-character gesture) - (not (member (keyboard-event-key-name - gesture) - '(:control-left :control-right - :shift-left :shift-right - :meta-left :meta-right - :super-left :super-right - :hyper-left :hyper-right - :shift-lock :caps-lock - :alt-left :alt-right)))))) - finally (progn (when (recordingp *application-frame*) - (push gesture (recorded-keys *application-frame*))) - (return gesture)))) - -(defun generic-unread-gesture (gesture stream) - (cond ((recordingp *application-frame*) - (pop (recorded-keys *application-frame*)) - (unread-gesture gesture :stream stream)) - ((executingp *application-frame*) - (push gesture (remaining-keys *application-frame*))) - (t - (unread-gesture gesture :stream stream)))) - -(defun read-numeric-argument (&key (stream *standard-input*)) - (let ((gesture (generic-read-gesture))) - (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME - (let ((numarg 4)) - (loop for gesture = (generic-read-gesture) - while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME - do (setf numarg (* 4 numarg)) - finally (generic-unread-gesture gesture stream)) - (let ((gesture (generic-read-gesture))) - (cond ((and (characterp gesture) - (digit-char-p gesture 10)) - (setf numarg (- (char-code gesture) (char-code #\0))) - (loop for gesture = (generic-read-gesture) - while (and (characterp gesture) - (digit-char-p gesture 10)) - do (setf numarg (+ (* 10 numarg) - (- (char-code gesture) (char-code #\0)))) - finally (generic-unread-gesture gesture stream) - (return (values numarg t)))) - (t - (generic-unread-gesture gesture stream) - (values numarg t)))))) - ((meta-digit gesture) - (let ((numarg (meta-digit gesture))) - (loop for gesture = (generic-read-gesture) - while (meta-digit gesture) - do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) - finally (generic-unread-gesture gesture stream) - (return (values numarg t))))) - (t (generic-unread-gesture gesture stream) - (values 1 nil))))) - ;;; we know the vbox pane has a scroller pane and an info ;;; pane in it. The scroller pane has a viewport in it, ;;; and the viewport contains the climacs-pane as its only child. @@ -232,8 +145,6 @@ (find-if (lambda (pane) (typep pane 'scroller-pane)) (sheet-children vbox))))))) -(defvar *numeric-argument-p* (list nil)) - (defun substitute-numeric-argument-p (command numargp) (substitute numargp *numeric-argument-p* command :test #'eq)) @@ -258,102 +169,6 @@ (loop for buffer in (buffers frame) do (when (modified-p buffer) (setf (needs-saving buffer) t)))) - -(defmethod execute-frame-command :after ((frame multi-frame-mixin) command) - (setf (previous-command *standard-output*) - (if (consp command) - (car command) - command))) - -(defmethod redisplay-frame-panes :around ((frame multi-frame-mixin) &key force-p) - (declare (ignore force-p)) - (when (null (remaining-keys *application-frame*)) - (setf (executingp *application-frame*) nil) - (call-next-method))) - -(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* (generic-read-gesture)) - (setf gestures - (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures 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 climacs-top-level (frame &key - command-parser command-unparser - partial-command-parser prompt) - (declare (ignore command-parser command-unparser partial-command-parser prompt)) - (with-slots (windows) frame - (setf windows (list (find-climacs-pane (find-pane-named frame 'win)))) - (push (buffer (car windows)) (buffers frame)) - (let ((*standard-output* (car windows)) - (*standard-input* (frame-standard-input frame)) - (*print-pretty* nil) - (*abort-gestures* '((:keyboard #\g 512)))) - (redisplay-frame-panes frame :force-p t) - (loop - for maybe-error = t - do (restart-case - (progn - (handler-case - (with-input-context - ('(command :command-table global-climacs-table)) - (object) - (process-gestures frame 'global-climacs-table) - (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)))))) - -(defmacro simple-command-loop (command-table loop-condition end-clauses) - (let ((gesture (gensym)) - (item (gensym)) - (command (gensym))) - `(progn - (redisplay-frame-panes *application-frame*) - (loop while ,loop-condition - as ,gesture = (generic-read-gesture) - as ,item = (find-gestures (list ,gesture) ,command-table) - do (cond ((and ,item (eq (command-menu-item-type ,item) :command)) - (setf *current-gesture* ,gesture) - (let ((,command (command-menu-item-value ,item))) - (unless (consp ,command) - (setf ,command (list ,command))) - (handler-case - (execute-frame-command *application-frame* - ,command) - (offset-before-beginning () - (beep) (display-message "Beginning of buffer")) - (offset-after-end () - (beep) (display-message "End of buffer")) - (motion-before-beginning () - (beep) (display-message "Beginning of buffer")) - (motion-after-end () - (beep) (display-message "End of buffer"))))) - (t - (unread-gesture ,gesture) - ,@end-clauses)) - (redisplay-frame-panes *application-frame*))))) (defmacro define-named-command (command-name args &body body) `(define-climacs-command ,(if (listp command-name) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.66 climacs/packages.lisp:1.67 --- climacs/packages.lisp:1.66 Thu Jul 21 07:13:51 2005 +++ climacs/packages.lisp Thu Jul 21 14:24:30 2005 @@ -170,9 +170,12 @@ (:use :clim-lisp :clim) (:export #:minibuffer-pane #:display-message #:esa-pane-mixin #:previous-command -;; #:esa-frame-mixin #:windows #:recordingp #:execcutingp -;; #:*numeric-argument-p* - #:esa-top-level)) + #:info-pane #:master-pane + #:esa-frame-mixin #:windows #:recordingp #:executingp + #:*numeric-argument-p* #:*current-gesture* + #:esa-top-level #:simple-command-loop + ;; remove these when kbd macros move to esa + #:recorded-keys #:remaining-keys)) (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax

1 0

[climacs-cvs] CVS update: climacs/climacs.asd climacs/esa.lisp climacs/gui.lisp climacs/packages.lisp
by rstrandh＠common-lisp.net 21 Jul '05

21 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv15536 Modified Files: climacs.asd esa.lisp gui.lisp packages.lisp Log Message: Included the ESA module in climacs.asd and packages.asd Removed some functionality from gui.lisp in favor of equivalent functionality in esa.lisp Adapted some functionality in gui.lisp to resemble the corresponding functionality in esa.lisp to facilitate the eventual move. Date: Thu Jul 21 07:13:51 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.32 climacs/climacs.asd:1.33 --- climacs/climacs.asd:1.32 Tue Jul 19 12:02:02 2005 +++ climacs/climacs.asd Thu Jul 21 07:13:51 2005 @@ -67,6 +67,7 @@ "prolog-syntax" "ttcn3-syntax" "lisp-syntax" + "esa" "gui" "slidemacs" "slidemacs-gui" Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.3 climacs/esa.lisp:1.4 --- climacs/esa.lisp:1.3 Thu Jul 21 05:34:44 2005 +++ climacs/esa.lisp Thu Jul 21 07:13:51 2005 @@ -20,16 +20,6 @@ ;;; Emacs-Style Appication - -;;; move this to packages.lisp eventually -(defpackage :esa - (:use :clim-lisp :clim) - (:export #:minibuffer-pane #:display-message - #:esa-pane-mixin #:previous-command - #:esa-frame-mixin #:windows #:recordingp #:execcutingp - #:*numeric-argument-p* - #:esa-top-level)) - (in-package :esa) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -73,7 +63,12 @@ ;;; ESA pane mixin (defclass esa-pane-mixin () - ((previous-command :initform nil :accessor previous-command))) + (;; allows a certain number of commands to have some minimal memory + (previous-command :initform nil :accessor previous-command))) + +(defmethod handle-repaint :before ((pane esa-pane-mixin) region) + (declare (ignore region)) + (redisplay-frame-pane *application-frame* pane)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.159 climacs/gui.lisp:1.160 --- climacs/gui.lisp:1.159 Wed Jul 20 11:41:06 2005 +++ climacs/gui.lisp Thu Jul 21 07:13:51 2005 @@ -28,10 +28,8 @@ (in-package :climacs-gui) -(defclass extended-pane (climacs-pane) - (;; allows a certain number of commands to have some minimal memory - (previous-command :initform nil :accessor previous-command) - ;; for next-line and previous-line commands +(defclass extended-pane (climacs-pane esa-pane-mixin) + (;; for next-line and previous-line commands (goal-column :initform nil) ;; for dynamic abbrev expansion (original-prefix :initform nil) @@ -47,23 +45,6 @@ :scroll-bars nil :borders nil)) -(defclass minibuffer-pane (application-pane) - ((message :initform nil :accessor message)) - (:default-initargs - :scroll-bars nil - :display-function 'display-minibuffer)) - -(defun display-minibuffer (frame pane) - (declare (ignore frame)) - (with-slots (message) pane - (unless (null message) - (princ message pane) - (setf message nil)))) - -(defmethod stream-accept :before ((pane minibuffer-pane) type &rest args) - (declare (ignore type args)) - (window-clear pane)) - (defclass climacs-info-pane (info-pane) () (:default-initargs @@ -76,6 +57,7 @@ (:default-initargs :height 20 :max-height 20 :min-height 20)) +;;; eventually remove in favor of esa-frame-mixin (defclass multi-frame-mixin () ((windows :accessor windows) (buffers :initform '() :accessor buffers) @@ -111,10 +93,6 @@ int))) (:top-level (climacs-top-level))) -(defun display-message (format-string &rest format-args) - (setf (message *standard-input*) - (apply #'format nil format-string format-args))) - (defun current-window () (car (windows *application-frame*))) @@ -281,22 +259,19 @@ do (when (modified-p buffer) (setf (needs-saving buffer) t)))) -(defun do-command (frame command) - (execute-frame-command frame command) +(defmethod execute-frame-command :after ((frame multi-frame-mixin) command) (setf (previous-command *standard-output*) (if (consp command) (car command) command))) - -(defgeneric update-frame (frame) - (:method (frame) (declare (ignore frame)) nil)) -(defmethod update-frame ((frame climacs)) +(defmethod redisplay-frame-panes :around ((frame multi-frame-mixin) &key force-p) + (declare (ignore force-p)) (when (null (remaining-keys *application-frame*)) (setf (executingp *application-frame*) nil) - (redisplay-frame-panes frame))) + (call-next-method))) -(defun process-gestures (frame) +(defun process-gestures (frame command-table) (loop for gestures = '() do (multiple-value-bind (numarg numargp) @@ -305,7 +280,7 @@ (setf *current-gesture* (generic-read-gesture)) (setf gestures (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-table))) + (let ((item (find-gestures gestures command-table))) (cond ((not item) (beep) (return)) @@ -315,10 +290,10 @@ (setf command (list command))) (setf command (substitute-numeric-argument-marker command numarg)) (setf command (substitute-numeric-argument-p command numargp)) - (do-command frame command) + (execute-frame-command frame command) (return))) (t nil))))) - do (update-frame frame))) + do (redisplay-frame-panes frame))) (defun climacs-top-level (frame &key command-parser command-unparser @@ -340,14 +315,14 @@ (with-input-context ('(command :command-table global-climacs-table)) (object) - (process-gestures frame) + (process-gestures frame 'global-climacs-table) (t - (do-command frame object) + (execute-frame-command frame object) (setq maybe-error nil))) (abort-gesture () (display-message "Quit"))) (when maybe-error (beep)) - (update-frame frame)) + (redisplay-frame-panes frame)) (return-to-climacs () nil)))))) (defmacro simple-command-loop (command-table loop-condition end-clauses) Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.65 climacs/packages.lisp:1.66 --- climacs/packages.lisp:1.65 Tue Jul 19 12:02:02 2005 +++ climacs/packages.lisp Thu Jul 21 07:13:51 2005 @@ -166,7 +166,15 @@ :climacs-syntax :flexichain :climacs-pane) (:export)) +(defpackage :esa + (:use :clim-lisp :clim) + (:export #:minibuffer-pane #:display-message + #:esa-pane-mixin #:previous-command +;; #:esa-frame-mixin #:windows #:recordingp #:execcutingp +;; #:*numeric-argument-p* + #:esa-top-level)) + (defpackage :climacs-gui (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-abbrev :climacs-syntax - :climacs-kill-ring :climacs-pane :clim-extensions :undo)) + :climacs-kill-ring :climacs-pane :clim-extensions :undo :esa))

1 0

[climacs-cvs] CVS update: climacs/esa.lisp
by rstrandh＠common-lisp.net 21 Jul '05

21 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv9594 Modified Files: esa.lisp Log Message: Improvements to the Emacs-style application Date: Thu Jul 21 05:34:45 2005 Author: rstrandh Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.2 climacs/esa.lisp:1.3 --- climacs/esa.lisp:1.2 Wed Jul 20 17:36:25 2005 +++ climacs/esa.lisp Thu Jul 21 05:34:44 2005 @@ -24,11 +24,18 @@ ;;; move this to packages.lisp eventually (defpackage :esa (:use :clim-lisp :clim) - (:export)) + (:export #:minibuffer-pane #:display-message + #:esa-pane-mixin #:previous-command + #:esa-frame-mixin #:windows #:recordingp #:execcutingp + #:*numeric-argument-p* + #:esa-top-level)) (in-package :esa) -;;; a pane that displays some information about another pane +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Info pane, a pane that displays some information about another pane + (defclass info-pane (application-pane) ((master-pane :initarg :master-pane)) (:default-initargs @@ -36,6 +43,10 @@ :scroll-bars nil :borders nil)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Minibuffer pane + (defclass minibuffer-pane (application-pane) ((message :initform nil :accessor message)) (:default-initargs @@ -53,18 +64,31 @@ (declare (ignore type args)) (window-clear pane)) +(defun display-message (format-string &rest format-args) + (setf (message *standard-input*) + (apply #'format nil format-string format-args))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ESA pane mixin + +(defclass esa-pane-mixin () + ((previous-command :initform nil :accessor previous-command))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; ESA frame mixin + (defclass esa-frame-mixin () ((windows :accessor windows) - (buffers :initform '() :accessor buffers) (recordingp :initform nil :accessor recordingp) (executingp :initform nil :accessor executingp) (recorded-keys :initform '() :accessor recorded-keys) (remaining-keys :initform '() :accessor remaining-keys))) -(defclass esa-window-mixin () - ((previous-command :initform nil :accessor previous-command))) - -(defgeneric buffer (esa-window-mixin)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Command processing (defun find-gestures (gestures start-table) (loop with table = (find-command-table start-table) @@ -84,9 +108,9 @@ (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) :test #'event-matches-gesture-name-p)) -(defun generic-read-gesture () +(defun esa-read-gesture () (unless (null (remaining-keys *application-frame*)) - (return-from generic-read-gesture + (return-from esa-read-gesture (pop (remaining-keys *application-frame*)))) (loop for gesture = (read-gesture :stream *standard-input*) until (or (characterp gesture) @@ -105,7 +129,7 @@ (push gesture (recorded-keys *application-frame*))) (return gesture)))) -(defun generic-unread-gesture (gesture stream) +(defun esa-unread-gesture (gesture stream) (cond ((recordingp *application-frame*) (pop (recorded-keys *application-frame*)) (unread-gesture gesture :stream stream)) @@ -115,35 +139,35 @@ (unread-gesture gesture :stream stream)))) (defun read-numeric-argument (&key (stream *standard-input*)) - (let ((gesture (generic-read-gesture))) + (let ((gesture (esa-read-gesture))) (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME (let ((numarg 4)) - (loop for gesture = (generic-read-gesture) + (loop for gesture = (esa-read-gesture) while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME do (setf numarg (* 4 numarg)) - finally (generic-unread-gesture gesture stream)) - (let ((gesture (generic-read-gesture))) + finally (esa-unread-gesture gesture stream)) + (let ((gesture (esa-read-gesture))) (cond ((and (characterp gesture) (digit-char-p gesture 10)) (setf numarg (- (char-code gesture) (char-code #\0))) - (loop for gesture = (generic-read-gesture) + (loop for gesture = (esa-read-gesture) while (and (characterp gesture) (digit-char-p gesture 10)) do (setf numarg (+ (* 10 numarg) (- (char-code gesture) (char-code #\0)))) - finally (generic-unread-gesture gesture stream) + finally (esa-unread-gesture gesture stream) (return (values numarg t)))) (t - (generic-unread-gesture gesture stream) + (esa-unread-gesture gesture stream) (values numarg t)))))) ((meta-digit gesture) (let ((numarg (meta-digit gesture))) - (loop for gesture = (generic-read-gesture) + (loop for gesture = (esa-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) - finally (generic-unread-gesture gesture stream) + finally (esa-unread-gesture gesture stream) (return (values numarg t))))) - (t (generic-unread-gesture gesture stream) + (t (esa-unread-gesture gesture stream) (values 1 nil))))) (defvar *numeric-argument-p* (list nil)) @@ -157,7 +181,7 @@ do (multiple-value-bind (numarg numargp) (read-numeric-argument :stream *standard-input*) (loop - (setf *current-gesture* (generic-read-gesture)) + (setf *current-gesture* (esa-read-gesture)) (setf gestures (nconc gestures (list *current-gesture*))) (let ((item (find-gestures gestures command-table))) @@ -175,25 +199,18 @@ (t nil))))) do (redisplay-frame-panes frame))) -(defun display-message (format-string &rest format-args) - (setf (message *standard-input*) - (apply #'format nil format-string format-args))) - -(defgeneric update-frame (frame) - (:method (frame) (declare (ignore frame)) nil)) - -(defmethod update-frame ((frame esa-frame-mixin)) +(defmethod redisplay-frame-panes :around ((frame esa-frame-mixin) &key force-p) + (declare (ignore force-p)) (when (null (remaining-keys *application-frame*)) (setf (executingp *application-frame*) nil) - (redisplay-frame-panes frame))) + (call-next-method))) -(defun do-command (frame command) - (execute-frame-command frame command) +(defmethod execute-frame-command :after ((frame esa-frame-mixin) command) (setf (previous-command *standard-output*) (if (consp command) (car command) command))) - + (defun find-real-pane (vbox) (first (sheet-children (find-if-not (lambda (pane) (typep pane 'scroll-bar-pane)) @@ -201,13 +218,16 @@ (find-if (lambda (pane) (typep pane 'scroller-pane)) (sheet-children vbox))))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Top level + (defun esa-top-level (frame &key command-parser command-unparser partial-command-parser prompt) (declare (ignore command-parser command-unparser partial-command-parser prompt)) (with-slots (windows) frame (setf windows (list (find-real-pane (find-pane-named frame 'win)))) - (push (buffer (car windows)) (buffers frame)) (let ((*standard-output* (car windows)) (*standard-input* (frame-standard-input frame)) (*print-pretty* nil) @@ -223,12 +243,12 @@ (object) (process-gestures frame 'global-example-table) (t - (do-command frame object) + (execute-frame-command frame object) (setq maybe-error nil))) (abort-gesture () (display-message "Quit"))) (when maybe-error (beep)) - (update-frame frame)) + (redisplay-frame-panes frame)) (return-to-climacs () nil)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -252,8 +272,8 @@ (:default-initargs :height 20 :max-height 20 :min-height 20)) -(defclass example-pane (esa-window-mixin application-pane) - ((buffer :initform "hello" :accessor buffer))) +(defclass example-pane (esa-pane-mixin application-pane) + ((contents :initform "hello" :accessor contents))) (define-application-frame example (standard-application-frame esa-frame-mixin) @@ -282,7 +302,7 @@ (defun display-my-pane (frame pane) (declare (ignore frame)) - (princ (buffer pane) *standard-output*)) + (princ (contents pane) *standard-output*)) (defun example (&key (width 900) (height 400)) "Starts up the example application"

1 0

[climacs-cvs] CVS update: climacs/esa.lisp
by rstrandh＠common-lisp.net 20 Jul '05

20 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27711 Modified Files: esa.lisp Log Message: oops, fixed a mistake that slipped in with the first commit. Date: Wed Jul 20 17:36:25 2005 Author: rstrandh Index: climacs/esa.lisp diff -u climacs/esa.lisp:1.1 climacs/esa.lisp:1.2 --- climacs/esa.lisp:1.1 Wed Jul 20 17:08:15 2005 +++ climacs/esa.lisp Wed Jul 20 17:36:25 2005 @@ -282,7 +282,7 @@ (defun display-my-pane (frame pane) (declare (ignore frame)) - (princ *standard-output* (buffer pane))) + (princ (buffer pane) *standard-output*)) (defun example (&key (width 900) (height 400)) "Starts up the example application"

1 0

[climacs-cvs] CVS update: climacs/esa.lisp
by rstrandh＠common-lisp.net 20 Jul '05

20 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv25823 Added Files: esa.lisp Log Message: First version of an attempt to abstract out the emacs-style GUI framework. Date: Wed Jul 20 17:08:15 2005 Author: rstrandh

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/text-syntax.lisp
by dholman＠common-lisp.net 20 Jul '05

20 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv2851 Modified Files: gui.lisp text-syntax.lisp Log Message: Added zap-to commands. Added sentences to text-syntax. Currently treated as expressions, with M-a and M-e bound to the expression movement commands. Text-syntax might also be a bit faster. Date: Wed Jul 20 11:41:07 2005 Author: dholman Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.158 climacs/gui.lisp:1.159 --- climacs/gui.lisp:1.158 Tue Jul 19 20:35:22 2005 +++ climacs/gui.lisp Wed Jul 20 11:41:06 2005 @@ -431,6 +431,32 @@ (define-named-command com-delete-object ((count 'integer :prompt "Number of Objects")) (delete-range (point (current-window)) count)) +(define-named-command com-zap-to-object () + (let* ((item (handler-case (accept 't :prompt "Zap to Object") + (error () (progn (beep) + (display-message "Not a valid object") + (return-from com-zap-to-object nil))))) + (current-point (point (current-window))) + (item-mark (clone-mark current-point)) + (current-offset (offset current-point))) + (search-forward item-mark (vector item)) + (delete-range current-point (- (offset item-mark) current-offset)))) + +(define-named-command com-zap-to-character () + (let* ((item-string (handler-case (accept 'string :prompt "Zap to Character") ; Figure out how to get #\d and d. (or 'string 'character)? + (error () (progn (beep) + (display-message "Not a valid string. ") + (return-from com-zap-to-character nil))))) + (item (subseq item-string 0 1)) + (current-point (point (current-window))) + (item-mark (clone-mark current-point)) + + (current-offset (offset current-point))) + (if (> (length item-string) 1) + (display-message "Using just the first character")) + (search-forward item-mark item) + (delete-range current-point (- (offset item-mark) current-offset)))) + (define-named-command com-backward-delete-object ((count 'integer :prompt "Number of Objects")) (delete-range (point (current-window)) (- count))) @@ -1493,6 +1519,8 @@ (global-set-key '(#\Space :control) 'com-set-mark) (global-set-key '(#\y :control) 'com-yank) (global-set-key '(#\w :control) 'com-cut-out) +(global-set-key '(#\e :meta) `(com-forward-expression ,*numeric-argument-marker*)) +(global-set-key '(#\a :meta) `(com-backward-expression ,*numeric-argument-marker*)) (global-set-key '(#\f :meta) `(com-forward-word ,*numeric-argument-marker*)) (global-set-key '(#\b :meta) `(com-backward-word ,*numeric-argument-marker*)) (global-set-key '(#\t :meta) 'com-transpose-words) @@ -1501,6 +1529,7 @@ (global-set-key '(#\c :meta) 'com-capitalize-word) (global-set-key '(#\x :meta) 'com-extended-command) (global-set-key '(#\y :meta) 'com-rotate-yank) +(global-set-key '(#\z :meta) 'com-zap-to-character) (global-set-key '(#\w :meta) 'com-copy-out) (global-set-key '(#\v :control) 'com-page-down) (global-set-key '(#\v :meta) 'com-page-up) @@ -1516,6 +1545,8 @@ (global-set-key '(#\e :control :meta) 'com-end-of-paragraph) (global-set-key '(#\s :control) 'com-isearch-mode-forward) (global-set-key '(#\r :control) 'com-isearch-mode-backward) +(global-set-key '(#\_ :shift :meta) 'com-redo) +(global-set-key '(#\_ :shift :control) 'com-undo) (global-set-key '(#\% :shift :meta) 'com-query-replace) (global-set-key '(:up) `(com-previous-line ,*numeric-argument-marker*)) Index: climacs/text-syntax.lisp diff -u climacs/text-syntax.lisp:1.7 climacs/text-syntax.lisp:1.8 --- climacs/text-syntax.lisp:1.7 Thu May 26 10:31:53 2005 +++ climacs/text-syntax.lisp Wed Jul 20 11:41:06 2005 @@ -43,6 +43,14 @@ ;;; N.B.: These invariants only hold AFTER a complete syntax analysis. ;;; we do now know what might have happened during the editing ;;; phase between to invocations of the analysis. +;;; +;;; D.H.: Invariant text needs to change to reflect sentences. +;;; Should there be paragraph invariants and sentence invariants? +;;; Did I ducttape this in the wrong place? +;;; Sentence invariants: +;;; Left stickies after . ? and !, at the end of the buffer +;;; Right stickies at non whitespace characters preceeded by space and punctuation. +;;; (in-package :climacs-syntax) ;;; Put this in a separate package once it works @@ -58,45 +66,89 @@ finally (return low-position))) (define-syntax text-syntax (basic-syntax) - ((paragraphs :initform (make-instance 'standard-flexichain))) + ((paragraphs :initform (make-instance 'standard-flexichain)) + (sentence-beginnings :initform (make-instance 'standard-flexichain)) + (sentence-endings :initform (make-instance 'standard-flexichain))) (:name "Text") (:pathname-types "text" "txt" "README")) (defmethod update-syntax (buffer (syntax text-syntax)) (let* ((high-offset (min (+ (offset (high-mark buffer)) 3) (size buffer))) (low-offset (max (- (offset (low-mark buffer)) 3) 0))) - (with-slots (paragraphs) syntax - (let ((pos1 (index-of-mark-after-offset paragraphs low-offset))) + (with-slots (paragraphs sentence-beginnings sentence-endings) syntax + (let ((pos1 (index-of-mark-after-offset paragraphs low-offset)) + (pos-sentence-beginnings (index-of-mark-after-offset sentence-beginnings low-offset)) + (pos-sentence-endings (index-of-mark-after-offset sentence-endings low-offset))) ;; start by deleting all syntax marks that are between the low and ;; the high marks (loop repeat (- (nb-elements paragraphs) pos1) while (mark<= (element* paragraphs pos1) high-offset) do (delete* paragraphs pos1)) + (loop repeat (- (nb-elements sentence-beginnings) pos-sentence-beginnings) + while (mark<= (element* sentence-beginnings pos-sentence-beginnings) high-offset) + do (delete* sentence-beginnings pos-sentence-beginnings)) + (loop repeat (- (nb-elements sentence-endings) pos-sentence-endings) + while (mark<= (element* sentence-endings pos-sentence-endings) high-offset) + do (delete* sentence-endings pos-sentence-endings)) + ;; check the zone between low-offset and high-offset for - ;; paragraph delimiters + ;; paragraph delimiters and sentence delimiters (loop with buffer-size = (size buffer) - for offset from low-offset to high-offset - do (cond ((and (< offset buffer-size) - (not (eql (buffer-object buffer offset) #\Newline)) + for offset from low-offset to high-offset ;; Could be rewritten with even fewer buffer-object calls, + for current-object = nil then (if (>= offset high-offset) nil (buffer-object buffer offset)) ;; but it'd be premature optimization, and messy besides. + for next-object = nil then (if (>= offset (- high-offset 1)) nil (buffer-object buffer (1+ offset))) + for prev-object = nil then (if (= offset low-offset) nil (buffer-object buffer (1- offset))) + for before-prev-object = nil then (if (<= offset (1+ low-offset)) nil (buffer-object buffer (- offset 2))) + do (progn + (cond ((and (< offset buffer-size) + (member prev-object '(#\. #\? #\!)) + (or (= offset (1- buffer-size)) + (and (member current-object '(#\Newline #\Space #\Tab)) + (or (= offset 1) + (not (member before-prev-object '(#\Newline #\Space #\Tab))))))) + (let ((m (clone-mark (low-mark buffer) :left))) + (setf (offset m) offset) + (insert* sentence-endings pos-sentence-endings m)) + (incf pos-sentence-endings)) + + ((and (>= offset 0) + (not (member current-object '(#\. #\? #\! #\Newline #\Space #\Tab))) + (or (= offset 0) + (member prev-object '(#\Newline #\Space #\Tab))) + (or (<= offset 1) + (member before-prev-object '(#\. #\? #\! #\Newline #\Space #\Tab)))) + (let ((m (clone-mark (low-mark buffer) :right))) + (setf (offset m) offset) + (insert* sentence-beginnings pos-sentence-beginnings m)) + (incf pos-sentence-beginnings)) + (t nil)) + + ;; Paragraphs + + (cond ((and (< offset buffer-size) ;; Ends + (not (eql current-object #\Newline)) (or (zerop offset) - (and (eql (buffer-object buffer (1- offset)) #\Newline) + (and (eql prev-object #\Newline) (or (= offset 1) - (eql (buffer-object buffer (- offset 2)) #\Newline))))) + (eql before-prev-object #\Newline))))) (let ((m (clone-mark (low-mark buffer) :left))) (setf (offset m) offset) (insert* paragraphs pos1 m)) (incf pos1)) - ((and (plusp offset) - (not (eql (buffer-object buffer (1- offset)) #\Newline)) + + ((and (plusp offset) ;;Beginnings + (not (eql prev-object #\Newline)) (or (= offset buffer-size) - (and (eql (buffer-object buffer offset) #\Newline) + (and (eql current-object #\Newline) (or (= offset (1- buffer-size)) - (eql (buffer-object buffer (1+ offset)) #\Newline))))) + (eql next-object #\Newline))))) (let ((m (clone-mark (low-mark buffer) :right))) (setf (offset m) offset) (insert* paragraphs pos1 m)) (incf pos1)) - (t nil))))))) + (t nil)))))))) + + (defgeneric beginning-of-paragraph (mark text-syntax)) @@ -123,6 +175,28 @@ (if (typep (element* paragraphs pos1) 'left-sticky-mark) (offset (element* paragraphs (1+ pos1))) (offset (element* paragraphs pos1)))))))) + + + (defgeneric backward-expression (mark text-syntax)) + + (defmethod backward-expression (mark (syntax text-syntax)) + (with-slots (sentence-beginnings) syntax + (let ((pos1 (index-of-mark-after-offset sentence-beginnings (offset mark)))) + (when (> pos1 0) + (setf (offset mark) + (offset (element* sentence-beginnings (1- pos1)))))))) + (defgeneric forward-expression (mark text-syntax)) + + (defmethod forward-expression (mark (syntax text-syntax)) + (with-slots (sentence-endings) syntax + (let ((pos1 (index-of-mark-after-offset + sentence-endings + ;; if mark is at sentence-end, jump to end of next + ;; sentence + (1+ (offset mark))))) + (when (< pos1 (nb-elements sentence-endings)) + (setf (offset mark) + (offset (element* sentence-endings pos1))))))) (defmethod syntax-line-indentation (mark tab-width (syntax text-syntax)) (loop with indentation = 0

1 0

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

20 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv25524 Modified Files: lisp-syntax.lisp Log Message: Patch to allow the viewing of files containing #\Page and #\Return characters. (thanks to John Q Splittist) Date: Wed Jul 20 09:16:37 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.13 climacs/lisp-syntax.lisp:1.14 --- climacs/lisp-syntax.lisp:1.13 Wed Jul 13 07:25:44 2005 +++ climacs/lisp-syntax.lisp Wed Jul 20 09:16:37 2005 @@ -849,7 +849,7 @@ (multiple-value-bind (x y) (stream-cursor-position pane) (declare (ignore x)) y))) - (#\Space (stream-increment-cursor-position + ((#\Page #\Return #\Space) (stream-increment-cursor-position pane space-width 0)) (#\Tab (let ((x (stream-cursor-position pane))) (stream-increment-cursor-position

1 0

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

19 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv10112 Modified Files: gui.lisp Log Message: Replaced cloned marks with (setf offsets) to retain mark identity on switching buffers/panes Date: Tue Jul 19 20:35:22 2005 Author: dmurray Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.157 climacs/gui.lisp:1.158 --- climacs/gui.lisp:1.157 Mon Jul 18 08:09:50 2005 +++ climacs/gui.lisp Tue Jul 19 20:35:22 2005 @@ -741,7 +741,7 @@ :prompt "Find File")) (buffer (make-instance 'climacs-buffer)) (pane (current-window))) - (setf (point (buffer pane)) (clone-mark (point pane))) + (setf (offset (point (buffer pane))) (offset (point pane))) (push buffer (buffers *application-frame*)) (setf (buffer (current-window)) buffer) (setf (syntax buffer) @@ -841,7 +841,7 @@ (let ((buffer (accept 'buffer :prompt "Switch to buffer")) (pane (current-window))) - (setf (point (buffer pane)) (clone-mark (point pane))) + (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer pane) buffer) (full-redisplay pane))) @@ -1013,7 +1013,7 @@ (multiple-value-bind (vbox new-pane) (make-pane-constellation) (let* ((current-window (current-window)) (constellation-root (parent3 current-window))) - (setf (point (buffer current-window)) (clone-mark (point current-window)) + (setf (offset (point (buffer current-window))) (offset (point current-window)) (buffer new-pane) (buffer current-window) (auto-fill-mode new-pane) (auto-fill-mode current-window) (auto-fill-column new-pane) (auto-fill-column current-window)) @@ -1029,7 +1029,7 @@ (multiple-value-bind (vbox new-pane) (make-pane-constellation) (let* ((current-window (current-window)) (constellation-root (parent3 current-window))) - (setf (point (buffer current-window)) (clone-mark (point current-window)) + (setf (offset (point (buffer current-window))) (offset (point current-window)) (buffer new-pane) (buffer current-window) (auto-fill-mode new-pane) (auto-fill-mode current-window) (auto-fill-column new-pane) (auto-fill-column current-window))

1 0

[climacs-cvs] CVS update: climacs/fundamental-syntax.lisp climacs/climacs.asd climacs/packages.lisp
by rstrandh＠common-lisp.net 19 Jul '05

19 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv8941 Modified Files: climacs.asd packages.lisp Added Files: fundamental-syntax.lisp Log Message: New syntax: `fundamental' My idea is to eventually get rid of the `basic' syntax. Not only is the name not great, but the code it contains some cruft that I would like to get rid of. For instance, the cache is no longer necessary and is messy to manage anyway. In addition, the `basic' syntax is problematic with respect to factoring out the GUI part of Climacs into a separate application-independent module. That's another good reason to get rid of it. So, I would appreciate if you would please check out this new syntax and let me know how it turns out. If I hear no complaints, I'll start by making `fundamental' the default syntax, and then remove the `basic' syntax altogether. Date: Tue Jul 19 12:02:03 2005 Author: rstrandh Index: climacs/climacs.asd diff -u climacs/climacs.asd:1.31 climacs/climacs.asd:1.32 --- climacs/climacs.asd:1.31 Sun Jun 5 03:59:52 2005 +++ climacs/climacs.asd Tue Jul 19 12:02:02 2005 @@ -61,6 +61,7 @@ "delegating-buffer" "Persistent/persistent-undo" "pane" + "fundamental-syntax" "cl-syntax" "html-syntax" "prolog-syntax" Index: climacs/packages.lisp diff -u climacs/packages.lisp:1.64 climacs/packages.lisp:1.65 --- climacs/packages.lisp:1.64 Mon May 30 11:33:39 2005 +++ climacs/packages.lisp Tue Jul 19 12:02:02 2005 @@ -142,6 +142,11 @@ #:with-undo #:url)) +(defpackage :climacs-fundamental-syntax + (:use :clim-lisp :clim :climacs-buffer :climacs-base + :climacs-syntax :flexichain :climacs-pane) + (:export)) + (defpackage :climacs-html-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :climacs-syntax :flexichain :climacs-pane))

1 0

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

18 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv31484 Modified Files: gui.lisp Log Message: Renamed things that aren't Climacs specific. Moved the code for marking buffers as needing to be saved to an :after method of execute-frame-command. The previous code was not right, in that it is entirely possible for a command to modify a buffer which is not the current one. Date: Mon Jul 18 08:09:51 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.156 climacs/gui.lisp:1.157 --- climacs/gui.lisp:1.156 Mon Jul 18 00:40:37 2005 +++ climacs/gui.lisp Mon Jul 18 08:09:50 2005 @@ -182,9 +182,9 @@ (#\5 :meta) (#\6 :meta) (#\7 :meta) (#\8 :meta) (#\9 :meta)) :test #'event-matches-gesture-name-p)) -(defun climacs-read-gesture () +(defun generic-read-gesture () (unless (null (remaining-keys *application-frame*)) - (return-from climacs-read-gesture + (return-from generic-read-gesture (pop (remaining-keys *application-frame*)))) (loop for gesture = (read-gesture :stream *standard-input*) until (or (characterp gesture) @@ -203,7 +203,7 @@ (push gesture (recorded-keys *application-frame*))) (return gesture)))) -(defun climacs-unread-gesture (gesture stream) +(defun generic-unread-gesture (gesture stream) (cond ((recordingp *application-frame*) (pop (recorded-keys *application-frame*)) (unread-gesture gesture :stream stream)) @@ -213,35 +213,35 @@ (unread-gesture gesture :stream stream)))) (defun read-numeric-argument (&key (stream *standard-input*)) - (let ((gesture (climacs-read-gesture))) + (let ((gesture (generic-read-gesture))) (cond ((event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME (let ((numarg 4)) - (loop for gesture = (climacs-read-gesture) + (loop for gesture = (generic-read-gesture) while (event-matches-gesture-name-p gesture '(:keyboard #\u 512)) ; FIXME do (setf numarg (* 4 numarg)) - finally (climacs-unread-gesture gesture stream)) - (let ((gesture (climacs-read-gesture))) + finally (generic-unread-gesture gesture stream)) + (let ((gesture (generic-read-gesture))) (cond ((and (characterp gesture) (digit-char-p gesture 10)) (setf numarg (- (char-code gesture) (char-code #\0))) - (loop for gesture = (climacs-read-gesture) + (loop for gesture = (generic-read-gesture) while (and (characterp gesture) (digit-char-p gesture 10)) do (setf numarg (+ (* 10 numarg) (- (char-code gesture) (char-code #\0)))) - finally (climacs-unread-gesture gesture stream) + finally (generic-unread-gesture gesture stream) (return (values numarg t)))) (t - (climacs-unread-gesture gesture stream) + (generic-unread-gesture gesture stream) (values numarg t)))))) ((meta-digit gesture) (let ((numarg (meta-digit gesture))) - (loop for gesture = (climacs-read-gesture) + (loop for gesture = (generic-read-gesture) while (meta-digit gesture) do (setf numarg (+ (* 10 numarg) (meta-digit gesture))) - finally (climacs-unread-gesture gesture stream) + finally (generic-unread-gesture gesture stream) (return (values numarg t))))) - (t (climacs-unread-gesture gesture stream) + (t (generic-unread-gesture gesture stream) (values 1 nil))))) ;;; we know the vbox pane has a scroller pane and an info @@ -276,6 +276,11 @@ (no-such-operation () (beep) (display-message "Operation unavailable for syntax")))) +(defmethod execute-frame-command :after ((frame climacs) command) + (loop for buffer in (buffers frame) + do (when (modified-p buffer) + (setf (needs-saving buffer) t)))) + (defun do-command (frame command) (execute-frame-command frame command) (setf (previous-command *standard-output*) @@ -283,10 +288,10 @@ (car command) command))) -(defun update-climacs (frame) - (let ((buffer (buffer (current-window)))) - (when (modified-p buffer) - (setf (needs-saving buffer) t))) +(defgeneric update-frame (frame) + (:method (frame) (declare (ignore frame)) nil)) + +(defmethod update-frame ((frame climacs)) (when (null (remaining-keys *application-frame*)) (setf (executingp *application-frame*) nil) (redisplay-frame-panes frame))) @@ -297,7 +302,7 @@ do (multiple-value-bind (numarg numargp) (read-numeric-argument :stream *standard-input*) (loop - (setf *current-gesture* (climacs-read-gesture)) + (setf *current-gesture* (generic-read-gesture)) (setf gestures (nconc gestures (list *current-gesture*))) (let ((item (find-gestures gestures 'global-climacs-table))) @@ -313,7 +318,7 @@ (do-command frame command) (return))) (t nil))))) - do (update-climacs frame))) + do (update-frame frame))) (defun climacs-top-level (frame &key command-parser command-unparser @@ -342,7 +347,7 @@ (abort-gesture () (display-message "Quit"))) (when maybe-error (beep)) - (update-climacs frame)) + (update-frame frame)) (return-to-climacs () nil)))))) (defmacro simple-command-loop (command-table loop-condition end-clauses) @@ -352,7 +357,7 @@ `(progn (redisplay-frame-panes *application-frame*) (loop while ,loop-condition - as ,gesture = (climacs-read-gesture) + as ,gesture = (generic-read-gesture) as ,item = (find-gestures (list ,gesture) ,command-table) do (cond ((and ,item (eq (command-menu-item-type ,item) :command)) (setf *current-gesture* ,gesture)

1 0

[climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp
by abakic＠common-lisp.net 18 Jul '05

18 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv2940 Modified Files: gui.lisp pane.lisp Log Message: Bug fix: coalesced two "same" execute-frame-command methods. Date: Mon Jul 18 00:40:37 2005 Author: abakic Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.155 climacs/gui.lisp:1.156 --- climacs/gui.lisp:1.155 Sun Jul 17 17:31:38 2005 +++ climacs/gui.lisp Mon Jul 18 00:40:37 2005 @@ -118,11 +118,6 @@ (defun current-window () (car (windows *application-frame*))) -(defmethod execute-frame-command :around ((frame climacs) command) - (declare (ignore command)) - (with-undo ((buffer (current-window))) - (call-next-method))) - (defmethod redisplay-frame-panes :around ((frame climacs) &rest args) (declare (ignore args)) (let ((buffers (remove-duplicates (mapcar #'buffer (windows frame))))) @@ -266,7 +261,8 @@ (defmethod execute-frame-command :around ((frame climacs) command) (handler-case - (call-next-method) + (with-undo ((buffer (current-window))) + (call-next-method)) (offset-before-beginning () (beep) (display-message "Beginning of buffer")) (offset-after-end () Index: climacs/pane.lisp diff -u climacs/pane.lisp:1.27 climacs/pane.lisp:1.28 --- climacs/pane.lisp:1.27 Wed Jun 22 20:35:59 2005 +++ climacs/pane.lisp Mon Jul 18 00:40:37 2005 @@ -93,7 +93,6 @@ :buffer buffer :offset offset :length (length sequence)) (undo-accumulate buffer)))) - (defmethod delete-buffer-range :before ((buffer undo-mixin) offset n) (unless (performing-undo buffer) (push (make-instance 'insert-record

2 1

[climacs-cvs] CVS update: climacs/base-test.lisp
by abakic＠common-lisp.net 17 Jul '05

17 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14951 Modified Files: base-test.lisp Log Message: Test changes due to a change in whitespacep. Date: Sun Jul 17 19:20:27 2005 Author: abakic Index: climacs/base-test.lisp diff -u climacs/base-test.lisp:1.13 climacs/base-test.lisp:1.14 --- climacs/base-test.lisp:1.13 Sun Mar 13 21:51:48 2005 +++ climacs/base-test.lisp Sun Jul 17 19:20:27 2005 @@ -467,7 +467,7 @@ (not (null (whitespacep #\Tab))) (not (null (whitespacep " "))) (not (null (whitespacep #\Null)))) - nil nil t t nil nil) + nil t t t nil nil) (defmultitest forward-to-word-boundary.test-1 (let ((buffer (make-instance %%buffer))) @@ -953,8 +953,7 @@ (values (offset m) (buffer-sequence buffer 0 (size buffer))))) - 1 " -climacs ") + 0 "climacs ") (defmultitest fill-line.test-1 (let ((buffer (make-instance %%buffer)))

1 0

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

17 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv7636 Modified Files: gui.lisp Log Message: Reassign *standard-input* when the current pane changes, otherwise the concept of previous-command (which is per-pane) does not make sense. Date: Sun Jul 17 17:31:39 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.154 climacs/gui.lisp:1.155 --- climacs/gui.lisp:1.154 Sun Jul 17 14:40:19 2005 +++ climacs/gui.lisp Sun Jul 17 17:31:38 2005 @@ -327,7 +327,7 @@ (setf windows (list (find-climacs-pane (find-pane-named frame 'win)))) (push (buffer (car windows)) (buffers frame)) (let ((*standard-output* (car windows)) - (*standard-input* (find-pane-named frame 'int)) + (*standard-input* (frame-standard-input frame)) (*print-pretty* nil) (*abort-gestures* '((:keyboard #\g 512)))) (redisplay-frame-panes frame :force-p t) @@ -1017,6 +1017,7 @@ (auto-fill-mode new-pane) (auto-fill-mode current-window) (auto-fill-column new-pane) (auto-fill-column current-window)) (push new-pane (windows *application-frame*)) + (setf *standard-output* new-pane) (replace-constellation constellation-root vbox t) (full-redisplay current-window) (full-redisplay new-pane))))) @@ -1032,6 +1033,7 @@ (auto-fill-mode new-pane) (auto-fill-mode current-window) (auto-fill-column new-pane) (auto-fill-column current-window)) (push new-pane (windows *application-frame*)) + (setf *standard-output* new-pane) (replace-constellation constellation-root vbox nil) (full-redisplay current-window) (full-redisplay new-pane))))) @@ -1039,13 +1041,16 @@ (define-named-command com-other-window () (setf (windows *application-frame*) (append (cdr (windows *application-frame*)) - (list (car (windows *application-frame*)))))) + (list (car (windows *application-frame*))))) + (setf *standard-output* (car (windows *application-frame*)))) (define-named-command com-single-window () (loop until (null (cdr (windows *application-frame*))) do (rotatef (car (windows *application-frame*)) (cadr (windows *application-frame*))) - (com-delete-window))) + (com-delete-window)) + (setf *standard-output* (car (windows *application-frame*)))) + (define-named-command com-delete-window () (unless (null (cdr (windows *application-frame*))) @@ -1061,6 +1066,7 @@ (second (second children)) (third (third children))) (pop (windows *application-frame*)) + (setf *standard-output* (car (windows *application-frame*))) (sheet-disown-child box other) (sheet-disown-child parent box) (sheet-adopt-child parent other)

1 0