From crhodes at common-lisp.net Sat Jul 2 15:54:23 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Sat, 2 Jul 2005 17:54:23 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050702155423.B32EE88529@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28714 Modified Files: gui.lisp Log Message: Experimental fix for CSR minibuffer problems. Oddly, not everyone suffers from this. Nor from the problem the handle-repaint method was included to solve: the scrollbars not adjusting properly. handle-repaint is not necessarily the right place for this functionality to be hooked on, but note-sheet-region-changed isn't either: drawing to a viewport also seems to change the region, so drawing to the frame from within the note-sheed-region-changed is a bad idea. Date: Sat Jul 2 17:54:22 2005 Author: crhodes Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.148 climacs/gui.lisp:1.149 --- climacs/gui.lisp:1.148 Tue Jun 28 07:02:34 2005 +++ climacs/gui.lisp Sat Jul 2 17:54:22 2005 @@ -150,7 +150,7 @@ (defmethod handle-repaint :before ((pane extended-pane) region) (declare (ignore region)) - (redisplay-frame-panes *application-frame*)) + (redisplay-frame-pane *application-frame* pane)) (defun find-gestures (gestures start-table) (loop with table = (find-command-table start-table) From crhodes at common-lisp.net Mon Jul 4 13:55:56 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 4 Jul 2005 15:55:56 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/syntax.lisp Message-ID: <20050704135556.0DA6A88525@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv5285 Modified Files: syntax.lisp Log Message: Maybe get the initial state of the initial lexeme in the Earley parser right. (See climacs-devel "html syntax buglet" 2005-06-29) Date: Mon Jul 4 15:55:56 2005 Author: crhodes Index: climacs/syntax.lisp diff -u climacs/syntax.lisp:1.52 climacs/syntax.lisp:1.53 --- climacs/syntax.lisp:1.52 Mon May 30 11:33:39 2005 +++ climacs/syntax.lisp Mon Jul 4 15:55:56 2005 @@ -520,14 +520,20 @@ (or (subtypep (target parser) sym) (subtypep sym (target parser)))) (if (functionp (right-hand-side rule)) - (handle-incomplete-item - (make-instance 'incomplete-item - :orig-state initial-state - :predicted-from nil - :rule rule - :dot-position 0 - :suffix (right-hand-side rule)) - initial-state initial-state) + (let ((predicted-rules (slot-value initial-state 'predicted-rules)) + (rule-number (slot-value rule 'number)) + (predict-test (predict-test rule))) + (when (zerop (sbit predicted-rules rule-number)) + (setf (sbit predicted-rules rule-number) 1) + (when (null predict-test) + (handle-and-predict-incomplete-item + (make-instance 'incomplete-item + :orig-state initial-state + :predicted-from nil + :rule rule + :dot-position 0 + :suffix (right-hand-side rule)) + initial-state nil)))) (potentially-handle-parse-tree (right-hand-side rule) initial-state initial-state)))))) From rstrandh at common-lisp.net Fri Jul 8 07:02:09 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 8 Jul 2005 09:02:09 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050708070209.5ADB68815E@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv25174 Modified Files: lisp-syntax.lisp Log Message: Indentation framework and code for indenting some special forms. Date: Fri Jul 8 09:02:08 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.7 climacs/lisp-syntax.lisp:1.8 --- climacs/lisp-syntax.lisp:1.7 Wed Jun 15 08:00:12 2005 +++ climacs/lisp-syntax.lisp Fri Jul 8 09:02:07 2005 @@ -156,6 +156,7 @@ (defclass lisp-nonterminal (nonterminal) ()) (defclass form (lisp-nonterminal) ()) +(defclass incomplete-form-mixin () ()) (defclass lisp-lexeme (lexeme) ((ink) @@ -471,6 +472,8 @@ ;;; parse trees (defclass list-form (form) ()) +(defclass complete-list-form (list-form) ()) +(defclass incomplete-list-form (list-form incomplete-form-mixin) ()) (define-parser-state |( form* | (lexer-list-state form-may-follow) ()) (define-parser-state |( form* ) | (lexer-toplevel-state parser-state) ()) @@ -481,12 +484,18 @@ ;;; reduce according to the rule form -> ( form* ) (define-lisp-action (|( form* ) | t) - (reduce-until-type list-form left-parenthesis-lexeme)) + (reduce-until-type complete-list-form left-parenthesis-lexeme)) + +;;; reduce at the end of the buffer +(define-lisp-action (|( form* | (eql nil)) + (reduce-until-type incomplete-list-form left-parenthesis-lexeme)) ;;;;;;;;;;;;;;;; String ;;; parse trees (defclass string-form (form) ()) +(defclass complete-string-form (string-form) ()) +(defclass incomplete-string-form (string-form incomplete-form-mixin) ()) (define-parser-state |" word* | (lexer-string-state parser-state) ()) (define-parser-state |" word* " | (lexer-toplevel-state parser-state) ()) @@ -498,7 +507,11 @@ ;;; reduce according to the rule form -> " word* " (define-lisp-action (|" word* " | t) - (reduce-until-type string-form string-start-lexeme)) + (reduce-until-type complete-string-form string-start-lexeme)) + +;;; reduce at the end of the buffer +(define-lisp-action (|" word* | (eql nil)) + (reduce-until-type incomplete-string-form string-start-lexeme)) ;;;;;;;;;;;;;;;; Line comment @@ -523,6 +536,8 @@ ;;; parse trees (defclass long-comment-form (form) ()) +(defclass complete-long-comment-form (long-comment-form) ()) +(defclass incomplete-long-comment-form (long-comment-form incomplete-form-mixin) ()) (define-parser-state |#\| word* | (lexer-long-comment-state parser-state) ()) (define-parser-state |#\| word* \|# | (lexer-toplevel-state parser-state) ()) @@ -536,12 +551,18 @@ ;;; reduce according to the rule form -> #| word* |# (define-lisp-action (|#\| word* \|# | t) - (reduce-until-type long-comment-form long-comment-start-lexeme)) + (reduce-until-type complete-long-comment-form long-comment-start-lexeme)) + +;;; reduce at the end of the buffer +(define-lisp-action (|#\| word* | (eql nil)) + (reduce-until-type incomplete-long-comment-form long-comment-start-lexeme)) ;;;;;;;;;;;;;;;; Symbol name surrounded with vertical bars ;;; 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) ()) @@ -552,7 +573,11 @@ ;;; reduce according to the rule form -> | text* | (define-lisp-action (|\| text* \| | t) - (reduce-until-type symbol-form symbol-start-lexeme)) + (reduce-until-type complete-symbol-form symbol-start-lexeme)) + +;;; reduce at the end of the buffer +(define-lisp-action (|\| text* | (eql nil)) + (reduce-until-type incomplete-symbol-form symbol-start-lexeme)) ;;;;;;;;;;;;;;;; Quote @@ -899,7 +924,7 @@ (handle-whitespace pane (buffer pane) *white-space-start* (start-offset parse-symbol)) (setf *white-space-start* (end-offset parse-symbol))) -(defmethod display-parse-tree ((parse-symbol string-form) (syntax lisp-syntax) pane) +(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) @@ -907,6 +932,13 @@ do (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))))) + (defmethod display-parse-tree ((parse-symbol line-comment-form) (syntax lisp-syntax) pane) (with-drawing-options (pane :ink +maroon+) (call-next-method))) @@ -915,7 +947,7 @@ (with-drawing-options (pane :ink +maroon+) (call-next-method))) -(defmethod display-parse-tree ((parse-symbol list-form) (syntax lisp-syntax) pane) +(defmethod display-parse-tree ((parse-symbol complete-list-form) (syntax lisp-syntax) pane) (let ((children (children parse-symbol))) (if (= (end-offset parse-symbol) (offset (point pane))) (with-text-face (pane :bold) @@ -1055,6 +1087,12 @@ (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." @@ -1088,3 +1126,154 @@ (end-offset token)) 'string))) (parse-symbol token-string package))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; indentation + +(defmethod indent-form ((syntax lisp-syntax) (tree form*) path) + (cond ((or (null path) + (and (null (cdr path)) (zerop (car path)))) + (values tree 0)) + ((null (cdr path)) + (values (elt (children tree) (1- (car path))) 0)) + (t (indent-form syntax (elt (children tree) (car path)) (cdr path))))) + +(defmethod indent-form ((syntax lisp-syntax) (tree list-form) path) + (if (= (car path) 1) + ;; before first element + (values tree 1) + (let ((first-child (elt (children tree) 1))) + (cond ((and (typep first-child 'token-lexeme) + (token-to-symbol syntax first-child)) + (compute-list-indentation syntax (token-to-symbol syntax first-child) tree path)) + ((null (cdr path)) + ;; top level + (if (= (car path) 2) + ;; indent like first element + (values (elt (children tree) 1) 0) + ;; indent like second element + (values (elt (children tree) 2) 0))) + (t + ;; inside a subexpression + (indent-form syntax (elt (children tree) (car path)) (cdr path))))))) + +(defmethod indent-binding ((syntax lisp-syntax) tree path) + (if (null (cdr path)) + ;; top level + (cond ((= (car path) 1) + ;; before variable, indent 1 + (values tree 1)) + ((= (car path) 2) + ;; between variable and value + (values (elt (children tree) 1) 0)) + (t + ;; after value + (values (elt (children tree) 2) 0))) + (indent-form syntax (elt (children tree) (car path)) (cdr path)))) + +(defmethod indent-bindings ((syntax lisp-syntax) tree path) + (if (null (cdr path)) + ;; entire bind form + (if (= (car path) 1) + ;; before first binding, indent 1 + (values tree 1) + ;; after some bindings, align with first binding + (values (elt (children tree) 1) 0)) + ;; inside a bind form + (indent-binding syntax (elt (children tree) (car path)) (cdr path)))) + +(defmethod compute-list-indentation ((syntax lisp-syntax) symbol tree path) + (if (null (cdr path)) + ;; top level + (if (= (car path) 2) + ;; indent like first child + (values (elt (children tree) 1) 0) + ;; indent like second child + (values (elt (children tree) 2) 0)) + ;; inside a subexpression + (indent-form syntax (elt (children tree) (car path)) (cdr path)))) + +;;; line up the elements vertically +(defun indent-list (syntax tree path) + (if (null (cdr path)) + ;; top level + (if (= (car path) 1) + ;; indent one more than the list + (values tree 1) + ;; indent like the first element + (values (elt (children tree) 1) 0)) + ;; inside an element + (indent-list syntax (elt (children tree) (car path)) (cdr path)))) + +;;; for now the same as indent-list, but try to do better with +;;; optional parameters with default values +(defun indent-lambda-list (syntax tree path) + (if (null (cdr path)) + ;; top level + (if (= (car path) 1) + ;; indent one more than the list + (values tree 1) + ;; indent like the first parameter + (values (elt (children tree) 1) 0)) + ;; inside a parameter + (indent-list syntax (elt (children tree) (car path)) (cdr path)))) + +(defmacro define-simple-indentor (template) + `(defmethod compute-list-indentation + ((syntax lisp-syntax) (symbol (eql ',(car template))) tree path) + (cond ((null (cdr path)) + (values tree (if (<= (car path) ,(length template)) 4 2))) + ,@(loop for fun in (cdr template) + for i from 2 + collect `((= (car path) ,i) (,fun syntax (elt (children tree) ,i) (cdr path)))) + (t (indent-form syntax (elt (children tree) (car path)) (cdr path)))))) + +(define-simple-indentor (prog1 indent-form)) +(define-simple-indentor (let indent-bindings)) +(define-simple-indentor (let* indent-bindings)) +(define-simple-indentor (defun indent-list indent-lambda-list)) +(define-simple-indentor (with-slots indent-list)) +(define-simple-indentor (when indent-form)) +(define-simple-indentor (unless indent-form)) + +(defun compute-path-in-trees (trees n offset) + (cond ((or (null trees) + (>= (start-offset (car trees)) offset)) + (list n)) + ((or (< (start-offset (car trees)) offset (end-offset (car trees))) + (typep (car trees) 'incomplete-form-mixin)) + (cons n (compute-path-in-tree (car trees) offset))) + (t (compute-path-in-trees (cdr trees) (1+ n) offset)))) + +(defun compute-path-in-tree (tree offset) + (if (null (children tree)) + '() + (compute-path-in-trees (children tree) 0 offset))) + +(defun compute-path (syntax offset) + (with-slots (stack-top) syntax + (compute-path-in-tree stack-top offset))) + +(defun real-column-number (mark tab-width) + (let ((mark2 (clone-mark mark))) + (beginning-of-line mark2) + (loop with column = 0 + until (mark= mark mark2) + do (if (eql (object-after mark2) #\Tab) + (loop do (incf column) + until (zerop (mod column tab-width))) + (incf column)) + do (incf (offset mark2)) + finally (return column)))) + +(defmethod syntax-line-indentation (mark tab-width (syntax lisp-syntax)) + (setf mark (clone-mark mark)) + (with-slots (stack-top) syntax + (let ((path (compute-path syntax (offset mark)))) + (beginning-of-line mark) + (multiple-value-bind (tree offset) + (indent-form syntax stack-top path) + (setf (offset mark) (start-offset tree)) + (+ (real-column-number mark tab-width) + offset))))) From rstrandh at common-lisp.net Mon Jul 11 08:47:51 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 11 Jul 2005 10:47:51 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/lisp-syntax.lisp Message-ID: <20050711084751.E57B088151@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv11374 Modified Files: gui.lisp lisp-syntax.lisp Log Message: Indentation for defclass. Code factoring through a macro called define-list-indentor. Ignore errors when reading package name after `in-package'. Add C-i as another key for invoking com-indent-line. Date: Mon Jul 11 10:47:51 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.149 climacs/gui.lisp:1.150 --- climacs/gui.lisp:1.149 Sat Jul 2 17:54:22 2005 +++ climacs/gui.lisp Mon Jul 11 10:47:50 2005 @@ -1453,6 +1453,7 @@ (global-set-key #\Newline 'com-self-insert) (global-set-key #\Tab 'com-indent-line) +(global-set-key '(#\i :control) 'com-indent-line) (global-set-key '(#\: :shift :meta) `(com-eval-expression ,*numeric-argument-p*)) (global-set-key '(#\j :control) 'com-newline-and-indent) (global-set-key '(#\f :control) `(com-forward-object ,*numeric-argument-marker*)) Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.8 climacs/lisp-syntax.lisp:1.9 --- climacs/lisp-syntax.lisp:1.8 Fri Jul 8 09:02:07 2005 +++ climacs/lisp-syntax.lisp Mon Jul 11 10:47:50 2005 @@ -804,7 +804,8 @@ 'string)) (package-symbol (let ((*package* (find-package :common-lisp))) - (read-from-string package-name nil nil)))) + (ignore-errors + (read-from-string package-name nil nil))))) (find-package package-symbol)))))))) (defmethod update-syntax (buffer (syntax lisp-syntax)) @@ -1158,6 +1159,9 @@ ;; inside a subexpression (indent-form syntax (elt (children tree) (car path)) (cdr path))))))) +(defmethod indent-form ((syntax lisp-syntax) (tree string-form) path) + (values tree 1)) + (defmethod indent-binding ((syntax lisp-syntax) tree path) (if (null (cdr path)) ;; top level @@ -1194,30 +1198,24 @@ ;; inside a subexpression (indent-form syntax (elt (children tree) (car path)) (cdr path)))) +(defmacro define-list-indentor (name element-indentor) + `(defun ,name (syntax tree path) + (if (null (cdr path)) + ;; top level + (if (= (car path) 1) + ;; indent one more than the list + (values tree 1) + ;; indent like the first element + (values (elt (children tree) 1) 0)) + ;; inside an element + (,element-indentor syntax (elt (children tree) (car path)) (cdr path))))) + ;;; line up the elements vertically -(defun indent-list (syntax tree path) - (if (null (cdr path)) - ;; top level - (if (= (car path) 1) - ;; indent one more than the list - (values tree 1) - ;; indent like the first element - (values (elt (children tree) 1) 0)) - ;; inside an element - (indent-list syntax (elt (children tree) (car path)) (cdr path)))) +(define-list-indentor indent-list indent-list) ;;; for now the same as indent-list, but try to do better with ;;; optional parameters with default values -(defun indent-lambda-list (syntax tree path) - (if (null (cdr path)) - ;; top level - (if (= (car path) 1) - ;; indent one more than the list - (values tree 1) - ;; indent like the first parameter - (values (elt (children tree) 1) 0)) - ;; inside a parameter - (indent-list syntax (elt (children tree) (car path)) (cdr path)))) +(define-list-indentor indent-lambda-list indent-list) (defmacro define-simple-indentor (template) `(defmethod compute-list-indentation @@ -1237,6 +1235,25 @@ (define-simple-indentor (when indent-form)) (define-simple-indentor (unless indent-form)) +;;; do this better +(define-list-indentor indent-slot-specs indent-list) + +(defmethod compute-list-indentation + ((syntax lisp-syntax) (symbol (eql 'defclass)) tree path) + (if (null (cdr path)) + ;; top level + (values tree (if (<= (car path) 3) 4 2)) + (case (car path) + ((2 3) + ;; in the class name or superclasses respectively + (indent-list syntax (elt (children tree) 2) (cdr path))) + (3 + ;; in the slot specs + (indent-slot-specs syntax (elt (children tree) 3) (cdr path))) + (t + ;; this is an approximation, might want to do better + (indent-list syntax (elt (children tree) (car path)) (cdr path)))))) + (defun compute-path-in-trees (trees n offset) (cond ((or (null trees) (>= (start-offset (car trees)) offset)) @@ -1269,9 +1286,9 @@ (defmethod syntax-line-indentation (mark tab-width (syntax lisp-syntax)) (setf mark (clone-mark mark)) + (beginning-of-line mark) (with-slots (stack-top) syntax (let ((path (compute-path syntax (offset mark)))) - (beginning-of-line mark) (multiple-value-bind (tree offset) (indent-form syntax stack-top path) (setf (offset mark) (start-offset tree)) From rstrandh at common-lisp.net Mon Jul 11 09:19:15 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 11 Jul 2005 11:19:15 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050711091915.BD07188151@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv14099 Modified Files: lisp-syntax.lisp Log Message: indentation for defgeneric Date: Mon Jul 11 11:19:15 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.9 climacs/lisp-syntax.lisp:1.10 --- climacs/lisp-syntax.lisp:1.9 Mon Jul 11 10:47:50 2005 +++ climacs/lisp-syntax.lisp Mon Jul 11 11:19:15 2005 @@ -1246,12 +1246,28 @@ (case (car path) ((2 3) ;; in the class name or superclasses respectively - (indent-list syntax (elt (children tree) 2) (cdr path))) - (3 + (indent-list syntax (elt (children tree) (car path)) (cdr path))) + (4 ;; in the slot specs - (indent-slot-specs syntax (elt (children tree) 3) (cdr path))) + (indent-slot-specs syntax (elt (children tree) 4) (cdr path))) (t ;; this is an approximation, might want to do better + (indent-list syntax (elt (children tree) (car path)) (cdr path)))))) + +(defmethod compute-list-indentation + ((syntax lisp-syntax) (symbol (eql 'defgeneric)) tree path) + (if (null (cdr path)) + ;; top level + (values tree (if (<= (car path) 3) 4 2)) + (case (car path) + (2 + ;; in the function name + (indent-list syntax (elt (children tree) 2) (cdr path))) + (3 + ;; in the lambda-list + (indent-lambda-list syntax (elt (children tree) 3) (cdr path))) + (t + ;; in the options or method specifications (indent-list syntax (elt (children tree) (car path)) (cdr path)))))) (defun compute-path-in-trees (trees n offset) From rstrandh at common-lisp.net Tue Jul 12 05:47:40 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 12 Jul 2005 07:47:40 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050712054740.777C188528@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv26552 Modified Files: lisp-syntax.lisp Log Message: Indentation for `defmethod' which recognizes method qualifiers. Date: Tue Jul 12 07:47:39 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.10 climacs/lisp-syntax.lisp:1.11 --- climacs/lisp-syntax.lisp:1.10 Mon Jul 11 11:19:15 2005 +++ climacs/lisp-syntax.lisp Tue Jul 12 07:47:39 2005 @@ -1270,6 +1270,24 @@ ;; in the options or method specifications (indent-list syntax (elt (children tree) (car path)) (cdr path)))))) +(defmethod compute-list-indentation + ((syntax lisp-syntax) (symbol (eql 'defmethod)) tree path) + (let ((lambda-list-pos (position-if (lambda (x) (typep x 'list-form)) + (children tree)))) + (cond ((null (cdr path)) + ;; top level + (values tree (if (or (null lambda-list-pos) + (<= (car path) lambda-list-pos)) + 4 + 2))) + ((or (null lambda-list-pos) + (< (car path) lambda-list-pos)) + (indent-list syntax (elt (children tree) (car path)) (cdr path))) + ((= (car path) lambda-list-pos) + (indent-lambda-list syntax (elt (children tree) (car path)) (cdr path))) + (t + (indent-form syntax (elt (children tree) (car path)) (cdr path)))))) + (defun compute-path-in-trees (trees n offset) (cond ((or (null trees) (>= (start-offset (car trees)) offset)) From rstrandh at common-lisp.net Tue Jul 12 06:02:04 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 12 Jul 2005 08:02:04 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050712060204.1481C88544@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv27474 Modified Files: lisp-syntax.lisp Log Message: Indentation for `defmacro'. Date: Tue Jul 12 08:02:00 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.11 climacs/lisp-syntax.lisp:1.12 --- climacs/lisp-syntax.lisp:1.11 Tue Jul 12 07:47:39 2005 +++ climacs/lisp-syntax.lisp Tue Jul 12 08:01:59 2005 @@ -1231,6 +1231,7 @@ (define-simple-indentor (let indent-bindings)) (define-simple-indentor (let* indent-bindings)) (define-simple-indentor (defun indent-list indent-lambda-list)) +(define-simple-indentor (defmacro indent-list indent-lambda-list)) (define-simple-indentor (with-slots indent-list)) (define-simple-indentor (when indent-form)) (define-simple-indentor (unless indent-form)) From rstrandh at common-lisp.net Wed Jul 13 05:25:45 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 13 Jul 2005 07:25:45 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050713052545.2130088165@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv18092 Modified Files: lisp-syntax.lisp Log Message: Indentation for `cond'. Date: Wed Jul 13 07:25:44 2005 Author: rstrandh Index: climacs/lisp-syntax.lisp diff -u climacs/lisp-syntax.lisp:1.12 climacs/lisp-syntax.lisp:1.13 --- climacs/lisp-syntax.lisp:1.12 Tue Jul 12 08:01:59 2005 +++ climacs/lisp-syntax.lisp Wed Jul 13 07:25:44 2005 @@ -1289,6 +1289,20 @@ (t (indent-form syntax (elt (children tree) (car path)) (cdr path)))))) +(define-list-indentor indent-clause indent-form) + +(defmethod compute-list-indentation + ((syntax lisp-syntax) (symbol (eql 'cond)) tree path) + (if (null (cdr path)) + ;; top level + (if (= (car path) 2) + ;; after `cond' + (values tree 2) + ;; indent like the first clause + (values (elt (children tree) 2) 0)) + ;; inside a clause + (indent-clause syntax (elt (children tree) (car path)) (cdr path)))) + (defun compute-path-in-trees (trees n offset) (cond ((or (null trees) (>= (start-offset (car trees)) offset)) From rstrandh at common-lisp.net Sun Jul 17 05:07:44 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 17 Jul 2005 07:07:44 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050717050744.BD68A880DE@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv32166 Modified Files: gui.lisp Log Message: A small step in towards factoring out common GUI components into a Climacs-independent module so that they can be reused in similar applications such as Gsharp. Specifically, I am trying to factor out: * the info pane (done) * the minibuffer pane (done) * the pane constellation containing an application pane (possibly within a scroller pane) and an info pane inside a vbox pane * the command loop * command processing * if possible, common commands such as C-x 0, C-x 1, C-x 2, C-x 3 Date: Sun Jul 17 07:07:42 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.150 climacs/gui.lisp:1.151 --- climacs/gui.lisp:1.150 Mon Jul 11 10:47:50 2005 +++ climacs/gui.lisp Sun Jul 17 07:07:41 2005 @@ -39,15 +39,43 @@ (dabbrev-expansion-mark :initform nil) (overwrite-mode :initform nil))) +;;; a pane that displays some information about another pane (defclass info-pane (application-pane) - ((climacs-pane :initarg :climacs-pane))) + ((master-pane :initarg :master-pane)) + (:default-initargs + :background +gray85+ + :scroll-bars nil + :borders nil)) + +(defclass minibuffer-pane (application-pane) + ((message :initform nil :accessor message)) + (:default-initargs + :scroll-bars nil + :display-function 'display-minibuffer)) -(defclass minibuffer-pane (application-pane) ()) +(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 + :height 20 :max-height 20 :min-height 20 + :display-function 'display-info + :incremental-redisplay t)) + +(defclass climacs-minibuffer-pane (minibuffer-pane) + () + (:default-initargs + :height 20 :max-height 20 :min-height 20)) + (define-application-frame climacs () ((windows :accessor windows) (buffers :initform '() :accessor buffers) @@ -64,22 +92,14 @@ :incremental-redisplay t :display-function 'display-win)) (info-pane - (make-pane 'info-pane - :climacs-pane extended-pane - :width 900 :height 20 :max-height 20 :min-height 20 - ::background +gray85+ - :scroll-bars nil - :borders nil - :incremental-redisplay t - :display-function 'display-info))) + (make-pane 'climacs-info-pane + :master-pane extended-pane + :width 900))) (vertically () (scrolling () extended-pane) info-pane))) - (int (make-pane 'minibuffer-pane - :width 900 :height 20 :max-height 20 :min-height 20 - :display-function 'display-minibuffer - :scroll-bars nil))) + (int (make-pane 'climacs-minibuffer-pane :width 900))) (:layouts (default (vertically (:scroll-bars nil) @@ -87,18 +107,10 @@ int))) (:top-level (climacs-top-level))) -(defparameter *message* nil) - (defun display-message (format-string &rest format-args) - (setf *message* + (setf (message *standard-input*) (apply #'format nil format-string format-args))) -(defun display-minibuffer (frame pane) - (declare (ignore frame)) - (unless (null *message*) - (princ *message* pane) - (setf *message* nil))) - (defmacro current-window () ; shouldn't this be an inlined function? --amb `(car (windows *application-frame*))) @@ -116,26 +128,26 @@ (loop for buffer in buffers do (clear-modify buffer)))) -(defun climacs () +(defun climacs (&key (width 900) (height 400)) "Starts up a climacs session" - (let ((frame (make-application-frame 'climacs))) + (let ((frame (make-application-frame 'climacs :width width :height height))) (run-frame-top-level frame))) (defun display-info (frame pane) (declare (ignore frame)) - (with-slots (climacs-pane) pane - (let* ((buf (buffer climacs-pane)) + (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 climacs-pane 'overwrite-mode) + (if (slot-value master-pane 'overwrite-mode) " Ovwrt" "") - (if (auto-fill-mode climacs-pane) + (if (auto-fill-mode master-pane) " Fill" "") - (if (isearch-mode climacs-pane) + (if (isearch-mode master-pane) " Isearch" "") (if (recordingp *application-frame*) @@ -979,15 +991,9 @@ (vbox (vertically () (scrolling () extended-pane) - (make-pane 'info-pane - :climacs-pane extended-pane - :width 900 :height 20 - :max-height 20 :min-height 20 - ::background +gray85+ - :scroll-bars nil - :borders nil - :incremental-redisplay t - :display-function 'display-info)))) + (make-pane 'climacs-info-pane + :master-pane extended-pane + :width 900)))) (values vbox extended-pane))) (define-named-command com-split-window-vertically () From rstrandh at common-lisp.net Sun Jul 17 10:24:16 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 17 Jul 2005 12:24:16 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050717102416.AACB08852B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv19923 Modified Files: gui.lisp Log Message: more code factoring of GUI components Date: Sun Jul 17 12:24:15 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.151 climacs/gui.lisp:1.152 --- climacs/gui.lisp:1.151 Sun Jul 17 07:07:41 2005 +++ climacs/gui.lisp Sun Jul 17 12:24:15 2005 @@ -76,13 +76,17 @@ (:default-initargs :height 20 :max-height 20 :min-height 20)) -(define-application-frame climacs () +(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)) + (remaining-keys :initform '() :accessor remaining-keys))) + +(define-application-frame climacs (standard-application-frame + multi-frame-mixin) + () (:panes (win (let* ((extended-pane (make-pane 'extended-pane @@ -260,6 +264,22 @@ (defun substitute-numeric-argument-p (command numargp) (substitute numargp *numeric-argument-p* command :test #'eq)) +(defmethod execute-frame-command :around ((frame climacs) command) + (handler-case + (call-next-method) + (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")) + (no-expression () + (beep) (display-message "No expression around point")) + (no-such-operation () + (beep) (display-message "Operation unavailable for syntax")))) + (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -273,20 +293,7 @@ (*abort-gestures* '((:keyboard #\g 512)))) (redisplay-frame-panes frame :force-p t) (flet ((do-command (command) - (handler-case - (execute-frame-command 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")) - (no-expression () - (beep) (display-message "No expression around point")) - (no-such-operation () - (beep) (display-message "Operation unavailable for syntax"))) + (execute-frame-command frame command) (setf (previous-command *standard-output*) (if (consp command) (car command) From rstrandh at common-lisp.net Sun Jul 17 12:31:56 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 17 Jul 2005 14:31:56 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050717123156.F129D8852B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28103 Modified Files: gui.lisp Log Message: moved do-command and update-climacs out of climacs-top-level Date: Sun Jul 17 14:31:55 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.152 climacs/gui.lisp:1.153 --- climacs/gui.lisp:1.152 Sun Jul 17 12:24:15 2005 +++ climacs/gui.lisp Sun Jul 17 14:31:55 2005 @@ -115,8 +115,8 @@ (setf (message *standard-input*) (apply #'format nil format-string format-args))) -(defmacro current-window () ; shouldn't this be an inlined function? --amb - `(car (windows *application-frame*))) +(defun current-window () + (car (windows *application-frame*))) (defmethod execute-frame-command :around ((frame climacs) command) (declare (ignore command)) @@ -280,6 +280,21 @@ (no-such-operation () (beep) (display-message "Operation unavailable for syntax")))) +(defun do-command (frame command) + (execute-frame-command frame command) + (setf (previous-command *standard-output*) + (if (consp command) + (car command) + command))) + +(defun update-climacs (frame) + (let ((buffer (buffer (current-window)))) + (when (modified-p buffer) + (setf (needs-saving buffer) t))) + (when (null (remaining-keys *application-frame*)) + (setf (executingp *application-frame*) nil) + (redisplay-frame-panes frame))) + (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -292,19 +307,7 @@ (*print-pretty* nil) (*abort-gestures* '((:keyboard #\g 512)))) (redisplay-frame-panes frame :force-p t) - (flet ((do-command (command) - (execute-frame-command frame command) - (setf (previous-command *standard-output*) - (if (consp command) - (car command) - command))) - (update-climacs () - (let ((buffer (buffer (current-window)))) - (when (modified-p buffer) - (setf (needs-saving buffer) t))) - (when (null (remaining-keys *application-frame*)) - (setf (executingp *application-frame*) nil) - (redisplay-frame-panes frame)))) + (flet () (flet ((process-gestures () (loop for gestures = '() @@ -324,10 +327,10 @@ (setf command (list command))) (setf command (substitute-numeric-argument-marker command numarg)) (setf command (substitute-numeric-argument-p command numargp)) - (do-command command) + (do-command frame command) (return))) (t nil))))) - do (update-climacs)))) + do (update-climacs frame)))) (loop for maybe-error = t do (restart-case @@ -338,12 +341,12 @@ (object) (process-gestures) (t - (do-command object) + (do-command frame object) (setq maybe-error nil))) (abort-gesture () (display-message "Quit"))) (when maybe-error (beep)) - (update-climacs)) + (update-climacs frame)) (return-to-climacs () nil)))))))) (defmacro simple-command-loop (command-table loop-condition end-clauses) From rstrandh at common-lisp.net Sun Jul 17 12:40:19 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 17 Jul 2005 14:40:19 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050717124019.11AF68852B@common-lisp.net> Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-serv28181 Modified Files: gui.lisp Log Message: factored out process-gestures from climacs-top-level Date: Sun Jul 17 14:40:19 2005 Author: rstrandh Index: climacs/gui.lisp diff -u climacs/gui.lisp:1.153 climacs/gui.lisp:1.154 --- climacs/gui.lisp:1.153 Sun Jul 17 14:31:55 2005 +++ climacs/gui.lisp Sun Jul 17 14:40:19 2005 @@ -295,6 +295,30 @@ (setf (executingp *application-frame*) nil) (redisplay-frame-panes frame))) +(defun process-gestures (frame) + (loop + for gestures = '() + do (multiple-value-bind (numarg numargp) + (read-numeric-argument :stream *standard-input*) + (loop + (setf *current-gesture* (climacs-read-gesture)) + (setf gestures + (nconc gestures (list *current-gesture*))) + (let ((item (find-gestures gestures 'global-climacs-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)) + (do-command frame command) + (return))) + (t nil))))) + do (update-climacs frame))) + (defun climacs-top-level (frame &key command-parser command-unparser partial-command-parser prompt) @@ -307,47 +331,23 @@ (*print-pretty* nil) (*abort-gestures* '((:keyboard #\g 512)))) (redisplay-frame-panes frame :force-p t) - (flet () - (flet ((process-gestures () - (loop - for gestures = '() - do (multiple-value-bind (numarg numargp) - (read-numeric-argument :stream *standard-input*) - (loop - (setf *current-gesture* (climacs-read-gesture)) - (setf gestures - (nconc gestures (list *current-gesture*))) - (let ((item (find-gestures gestures 'global-climacs-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)) - (do-command frame command) - (return))) - (t nil))))) - do (update-climacs frame)))) - (loop - for maybe-error = t - do (restart-case - (progn - (handler-case - (with-input-context - ('(command :command-table global-climacs-table)) - (object) - (process-gestures) - (t - (do-command frame object) - (setq maybe-error nil))) - (abort-gesture () (display-message "Quit"))) - (when maybe-error - (beep)) - (update-climacs frame)) - (return-to-climacs () nil)))))))) + (loop + for maybe-error = t + do (restart-case + (progn + (handler-case + (with-input-context + ('(command :command-table global-climacs-table)) + (object) + (process-gestures frame) + (t + (do-command frame object) + (setq maybe-error nil))) + (abort-gesture () (display-message "Quit"))) + (when maybe-error + (beep)) + (update-climacs frame)) + (return-to-climacs () nil)))))) (defmacro simple-command-loop (command-table loop-condition end-clauses) (let ((gesture (gensym)) From rstrandh at common-lisp.net Sun Jul 17 15:31:39 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 17 Jul 2005 17:31:39 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050717153139.955CF8852B@common-lisp.net> 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) From abakic at common-lisp.net Sun Jul 17 17:20:28 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Sun, 17 Jul 2005 19:20:28 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/base-test.lisp Message-ID: <20050717172028.8B0C6880DF@common-lisp.net> 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))) From abakic at common-lisp.net Sun Jul 17 22:40:39 2005 From: abakic at common-lisp.net (Aleksandar Bakic) Date: Mon, 18 Jul 2005 00:40:39 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp Message-ID: <20050717224039.18413880DF@common-lisp.net> 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 From strandh at labri.fr Mon Jul 18 03:46:04 2005 From: strandh at labri.fr (Robert Strandh) Date: Mon, 18 Jul 2005 05:46:04 +0200 Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/pane.lisp In-Reply-To: <20050717224039.18413880DF@common-lisp.net> References: <20050717224039.18413880DF@common-lisp.net> Message-ID: <17115.9724.827859.689684@serveur5.labri.fr> Aleksandar Bakic writes: > Bug fix: coalesced two "same" execute-frame-command methods. Thanks. I broke it, didn't I? -- Robert Strandh --------------------------------------------------------------------- Greenspun's Tenth Rule of Programming: any sufficiently complicated C or Fortran program contains an ad hoc informally-specified bug-ridden slow implementation of half of Common Lisp. --------------------------------------------------------------------- From rstrandh at common-lisp.net Mon Jul 18 06:09:53 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 18 Jul 2005 08:09:53 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050718060953.A2D86880DF@common-lisp.net> 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) From rstrandh at common-lisp.net Tue Jul 19 10:02:06 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 19 Jul 2005 12:02:06 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/fundamental-syntax.lisp climacs/climacs.asd climacs/packages.lisp Message-ID: <20050719100206.5E8EB880DF@common-lisp.net> 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)) From dmurray at common-lisp.net Tue Jul 19 18:35:22 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Tue, 19 Jul 2005 20:35:22 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp Message-ID: <20050719183522.98E32880DF@common-lisp.net> 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)) From rstrandh at common-lisp.net Wed Jul 20 07:16:37 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 20 Jul 2005 09:16:37 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050720071637.D884E88526@common-lisp.net> 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 From dholman at common-lisp.net Wed Jul 20 09:41:07 2005 From: dholman at common-lisp.net (Dwight Holman) Date: Wed, 20 Jul 2005 11:41:07 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/text-syntax.lisp Message-ID: <20050720094107.E3A7488526@common-lisp.net> 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 From rstrandh at common-lisp.net Wed Jul 20 15:08:16 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 20 Jul 2005 17:08:16 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp Message-ID: <20050720150816.1C2B188526@common-lisp.net> 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 From rstrandh at common-lisp.net Wed Jul 20 15:36:25 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Wed, 20 Jul 2005 17:36:25 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp Message-ID: <20050720153625.D935C88526@common-lisp.net> 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" From rstrandh at common-lisp.net Thu Jul 21 03:34:45 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 21 Jul 2005 05:34:45 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp Message-ID: <20050721033445.CBBAC8815C@common-lisp.net> 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" From rstrandh at common-lisp.net Thu Jul 21 05:13:53 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 21 Jul 2005 07:13:53 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/climacs.asd climacs/esa.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050721051353.509B18815C@common-lisp.net> 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)) From rstrandh at common-lisp.net Thu Jul 21 12:24:32 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Thu, 21 Jul 2005 14:24:32 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050721122432.6751388525@common-lisp.net> 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) + , at 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) - , at 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 From rstrandh at common-lisp.net Fri Jul 22 05:35:08 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 22 Jul 2005 07:35:08 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp climacs/gui.lisp Message-ID: <20050722053508.3AE3588525@common-lisp.net> 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)) From rstrandh at common-lisp.net Fri Jul 22 05:36:59 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 22 Jul 2005 07:36:59 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp Message-ID: <20050722053659.23B7488525@common-lisp.net> 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 From rstrandh at common-lisp.net Fri Jul 22 07:05:44 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 22 Jul 2005 09:05:44 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp Message-ID: <20050722070544.1A2688852B@common-lisp.net> 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))) From rstrandh at common-lisp.net Fri Jul 22 13:15:48 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Fri, 22 Jul 2005 15:15:48 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp climacs/gui.lisp Message-ID: <20050722131548.E23F8880DF@common-lisp.net> 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) From rstrandh at common-lisp.net Sun Jul 24 05:10:51 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 24 Jul 2005 07:10:51 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050724051051.DD7FF8853D@common-lisp.net> 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) - `(, at command-name :name t) - `(,command-name :name t)) ,args , at body)) + `(define-command ,(if (listp command-name) + `(, at command-name :name t :command-table global-climacs-table) + `(,command-name :name t :command-table global-climacs-table)) + ,args , at 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)) From rstrandh at common-lisp.net Sun Jul 24 08:06:51 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 24 Jul 2005 10:06:51 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050724080651.79185880DF@common-lisp.net> 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 |# | (form-may-follow) ()) +(define-parser-state |# form | (lexer-toplevel-state parser-state) ()) + +(define-new-lisp-state (form-may-follow undefined-reader-macro-lexeme) |' |) +(define-new-lisp-state (|# | form) |# 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)) From rstrandh at common-lisp.net Sun Jul 24 10:42:38 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Sun, 24 Jul 2005 12:42:38 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/climacs.asd Message-ID: <20050724104238.2F00488526@common-lisp.net> 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 , at 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) From afuchs at common-lisp.net Sun Jul 24 16:44:49 2005 From: afuchs at common-lisp.net (Andreas Fuchs) Date: Sun, 24 Jul 2005 18:44:49 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/climacs.asd Message-ID: <20050724164449.41A6688526@common-lisp.net> 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" From rstrandh at common-lisp.net Mon Jul 25 03:41:16 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Mon, 25 Jul 2005 05:41:16 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/esa.lisp climacs/gui.lisp climacs/packages.lisp Message-ID: <20050725034116.B5DBC88526@common-lisp.net> 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 From dmurray at common-lisp.net Mon Jul 25 11:04:31 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Mon, 25 Jul 2005 13:04:31 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/lisp-syntax.lisp Message-ID: <20050725110431.1FA75880DF@common-lisp.net> 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)) From rstrandh at common-lisp.net Tue Jul 26 05:28:41 2005 From: rstrandh at common-lisp.net (Robert Strandh) Date: Tue, 26 Jul 2005 07:28:41 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/lisp-syntax.lisp climacs/packages.lisp Message-ID: <20050726052841.61885880DD@common-lisp.net> 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 From dmurray at common-lisp.net Thu Jul 28 20:36:39 2005 From: dmurray at common-lisp.net (Dave Murray) Date: Thu, 28 Jul 2005 22:36:39 +0200 (CEST) Subject: [climacs-cvs] CVS update: climacs/gui.lisp climacs/lisp-syntax.lisp climacs/packages.lisp Message-ID: <20050728203639.13B468854A@common-lisp.net> 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) `(, at 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))