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