climacs-cvs July 2005

climacs-cvs@common-lisp.net

7 participants
37 discussions

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

17 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-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))

1 0

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

17 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-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)

1 0

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

17 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-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)

1 0

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

17 Jul '05

Update of /project/climacs/cvsroot/climacs In directory common-lisp.net:/tmp/cvs-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 ()

1 0

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

13 Jul '05

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))

1 0

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

12 Jul '05

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))

1 0

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

12 Jul '05

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))

1 0

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

11 Jul '05

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)

1 0

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

11 Jul '05

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))

1 0

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

08 Jul '05

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)))))

1 0

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

04 Jul '05

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))))))

1 0

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

02 Jul '05

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)

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

climacs-cvs July 2005