climacs-cvs April 2006

climacs-cvs@common-lisp.net

2 participants
21 discussions

[climacs-cvs] CVS climacs
by thenriksen 23 Apr '06

23 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv15857 Modified Files: lisp-syntax.lisp Log Message: Made `lex-token' able to discern between numbers and symbols. Also made `package-of' read the package defined in the local options line if no (in-package) forms can be found. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 12:11:26 1.52 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 14:38:57 1.53 @@ -380,7 +380,7 @@ (#\| (fo) (make-instance 'multiple-escape-start-lexeme)) (t (cond ((or (constituentp object) (eql object #\\)) - (lex-token scan)) + (lex-token syntax scan)) (t (fo) (make-instance 'error-lexeme)))))))) (defmethod lex ((syntax lisp-syntax) (state lexer-list-state) scan) @@ -446,25 +446,54 @@ (make-instance 'word-lexeme)) (t (fo) (make-instance 'delimiter-lexeme))))) -(defun lex-token (scan) - (macrolet ((fo () `(forward-object 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 'incomplete-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))))) +(defun lex-token (syntax scan) + ;; May need more work. Can recognize symbols and numbers. + (flet ((fo () (forward-object scan))) + (let ((could-be-number t) + sign-seen dot-seen slash-seen) + (flet ((return-token-or-number-lexeme () + (return-from lex-token + (if could-be-number + (make-instance 'number-lexeme) + (make-instance 'complete-token-lexeme)))) + (this-object () + (object-after scan))) + (tagbody + START + (when (end-of-buffer-p scan) + (return-token-or-number-lexeme)) + (when (constituentp (object-after scan)) + (cond ((or (eql (this-object) #\+) + (eql (this-object) #\-)) + (when sign-seen + (setf could-be-number nil)) + (setf sign-seen t)) + ((eql (this-object) #\.) + (when dot-seen + (setf could-be-number nil)) + (setf dot-seen t)) + ((eql (this-object) #\/) + (when slash-seen + (setf could-be-number nil)) + (setf slash-seen t)) + ;; We obey the base specified in the file when + ;; determining whether or not this character is an + ;; integer. + ((not (digit-char-p (this-object) + (base syntax))) + (setf could-be-number nil))) + (fo) + (go START)) + (when (eql (object-after scan) #\\) + (fo) + (when (end-of-buffer-p scan) + (return-from lex-token (make-instance 'incomplete-lexeme))) + (fo) + (go START)) + (when (eql (object-after scan) #\|) + (fo) + (return-from lex-token (make-instance 'multiple-escape-start-lexeme))) + (return-token-or-number-lexeme)))))) (defmethod lex ((syntax lisp-syntax) (state lexer-escaped-token-state) scan) (let ((bars-seen 0)) @@ -1106,40 +1135,41 @@ 'cl:in-package)))))) (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) - (when form - (let ((package-form (second-form (children form)))) - (when package-form - (let ((package-name - (typecase package-form - (token-mixin - (coerce (buffer-sequence - buffer - (start-offset package-form) - (end-offset package-form)) - 'string)) - (complete-string-form - (coerce (buffer-sequence - buffer - (1+ (start-offset package-form)) - (1- (end-offset package-form))) - 'string)) - (quote-form - (coerce (buffer-sequence - buffer - (start-offset (second-noncomment (children package-form))) - (end-offset (second-noncomment (children package-form)))) - 'string)) - (uninterned-symbol-form - (coerce (buffer-sequence - buffer - (start-offset (second-noncomment (children package-form))) - (end-offset (second-noncomment (children package-form)))) - 'string)) - (t 'nil)))) - (when package-name - (let ((package-symbol (parse-token package-name))) - (or (find-package package-symbol) - package-symbol)))))))))))) + (or (when form + (let ((package-form (second-form (children form)))) + (when package-form + (let ((package-name + (typecase package-form + (token-mixin + (coerce (buffer-sequence + buffer + (start-offset package-form) + (end-offset package-form)) + 'string)) + (complete-string-form + (coerce (buffer-sequence + buffer + (1+ (start-offset package-form)) + (1- (end-offset package-form))) + 'string)) + (quote-form + (coerce (buffer-sequence + buffer + (start-offset (second-noncomment (children package-form))) + (end-offset (second-noncomment (children package-form)))) + 'string)) + (uninterned-symbol-form + (coerce (buffer-sequence + buffer + (start-offset (second-noncomment (children package-form))) + (end-offset (second-noncomment (children package-form)))) + 'string)) + (t 'nil)))) + (when package-name + (let ((package-symbol (parse-token package-name))) + (or (find-package package-symbol) + package-symbol))))))) + (option-specified-package syntax))))))) (defmethod update-syntax (buffer (syntax lisp-syntax)) (let* ((low-mark (low-mark buffer))

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Apr '06

23 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1476 Modified Files: buffer.lisp Log Message: Converted the mark movement functions return the mark instead of the modified offset. This is both more logical and far more useful. --- /project/climacs/cvsroot/climacs/buffer.lisp 2005/05/10 16:28:53 1.31 +++ /project/climacs/cvsroot/climacs/buffer.lisp 2006/04/23 12:40:31 1.32 @@ -132,12 +132,26 @@ (make-condition 'motion-after-end :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) -(defgeneric backward-object (mark &optional count)) +(defgeneric backward-object (mark &optional count) + (:documentation "Move `mark' `count' objects backwards. Returns + `mark'.")) + +(defmethod backward-object :around (mark &optional count) + (declare (ignore count)) + (call-next-method) + mark) (defmethod backward-object ((mark mark-mixin) &optional (count 1)) (decf (offset mark) count)) -(defgeneric forward-object (mark &optional count)) +(defgeneric forward-object (mark &optional count) + (:documentation "Move `mark' `count' objects forwards. Returns + `mark'")) + +(defmethod forward-object :around (mark &optional count) + (declare (ignore count)) + (call-next-method) + mark) (defmethod forward-object ((mark mark-mixin) &optional (count 1)) (incf (offset mark) count)) @@ -297,21 +311,32 @@ (>= mark1 (offset mark2))) (defgeneric beginning-of-buffer (mark) - (:documentation "Move the mark to the beginning of the buffer. This is equivalent to - (setf (offset mark) 0)")) + (:documentation "Move the mark to the beginning of the buffer. + This is equivalent to (setf (offset mark) 0), but returns + mark.")) + +;; Easy way to make sure mark is always returned. +(defmethod beginning-of-buffer :around (mark) + (call-next-method) + mark) (defmethod beginning-of-buffer ((mark mark-mixin)) (setf (offset mark) 0)) (defgeneric end-of-buffer (mark) - (:documentation "Move the mark to the end of the buffer.")) + (:documentation "Move the mark to the end of the buffer and + return mark.")) + +(defmethod end-of-buffer :around (mark) + (call-next-method) + mark) (defmethod end-of-buffer ((mark mark-mixin)) (setf (offset mark) (size (buffer mark)))) (defgeneric beginning-of-buffer-p (mark) - (:documentation "Return t if the mark is at the beginning of the buffer, nil - otherwise.")) + (:documentation "Return t if the mark is at the beginning of + the buffer, nil otherwise.")) (defmethod beginning-of-buffer-p ((mark mark-mixin)) (zerop (offset mark))) @@ -344,7 +369,11 @@ (:documentation "Move the mark to the beginning of the line. The mark will be positioned either immediately after the closest preceding newline character, or at the beginning of the buffer if no preceding newline - character exists.")) + character exists. Returns mark.")) + +(defmethod beginning-of-line :around (mark) + (call-next-method) + mark) (defmethod beginning-of-line ((mark mark-mixin)) (loop until (beginning-of-line-p mark) @@ -353,7 +382,11 @@ (defgeneric end-of-line (mark) (:documentation "Move the mark to the end of the line. The mark will be positioned either immediately before the closest following newline character, or -at the end of the buffer if no following newline character exists.")) +at the end of the buffer if no following newline character exists. Returns mark.")) + +(defmethod end-of-line :around (mark) + (call-next-method) + mark) (defmethod end-of-line ((mark mark-mixin)) (let* ((offset (offset mark))

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Apr '06

23 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv1333 Modified Files: file-commands.lisp Log Message: Set (syntax buffer) to NIL so we can check whether or not the local options line has set a syntax. --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 12:11:26 1.6 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 12:36:19 1.7 @@ -212,6 +212,7 @@ (switch-to-buffer existing-buffer) (let ((buffer (make-buffer)) (pane (current-window))) + (setf (syntax buffer) nil) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer (current-window)) buffer) ;; Don't want to create the file if it doesn't exist.

1 0

[climacs-cvs] CVS climacs
by thenriksen 23 Apr '06

23 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv28674 Modified Files: syntax.lisp packages.lisp misc-commands.lisp lisp-syntax.lisp file-commands.lisp climacs.asd Log Message: Added support for local options lines (the -*- ... -*- stuff), the generic option Syntax/Mode and Base and Package options for Lisp syntax. --- /project/climacs/cvsroot/climacs/syntax.lisp 2005/11/14 16:30:13 1.61 +++ /project/climacs/cvsroot/climacs/syntax.lisp 2006/04/23 12:11:26 1.62 @@ -208,6 +208,38 @@ (:default-initargs :command-table ',command-table ,@default-initargs) ,@defclass-options)))) +(defgeneric eval-option (syntax name value) + (:documentation "Evaluate the option `name' with the specified + `value' for `syntax'.") + (:method (syntax name value) + ;; We do not want to error out if an invalid option is + ;; specified. Signal a condition? For now, silently ignore. + (declare (ignore syntax name value)))) + +(defmethod eval-option :around (syntax (name string) value) + ;; Convert the name to a keyword symbol... + (eval-option syntax (intern name (find-package :keyword)) + value)) + +(defmacro define-option-for-syntax + (syntax option-name (syntax-symbol value-symbol) &body body) + "Define an option for the syntax specified by the symbol + `syntax'. `Option-name' should be a string that will be the + name of the option. The name will automatically be converted to + uppercase. When the option is being evaluated, `body' will be + run, with `syntax-symbol' bound to the syntax object the option + is being evaluated for, and `value-symbol' bound to the value + of the option." + ;; The name is converted to a keyword symbol which is used for all + ;; further identification. + (let ((name-symbol (gensym)) + (symbol (intern (string-upcase option-name) + (find-package :keyword)))) + `(defmethod eval-option ((,syntax-symbol ,syntax) + (,name-symbol (eql ,symbol)) + ,value-symbol) + ,@body))) + #+nil (defmacro define-syntax (class-name (name superclasses) &body body) `(progn (push '(,name . ,class-name) *syntaxes*) --- /project/climacs/cvsroot/climacs/packages.lisp 2006/03/26 14:14:48 1.87 +++ /project/climacs/cvsroot/climacs/packages.lisp 2006/04/23 12:11:26 1.88 @@ -94,6 +94,8 @@ (defpackage :climacs-syntax (:use :clim-lisp :clim :climacs-buffer :climacs-base :flexichain) (:export #:syntax #:define-syntax + #:eval-option + #:define-option-for-syntax #:syntax-from-name #:basic-syntax #:update-syntax #:update-syntax-for-display --- /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/03/26 14:14:48 1.5 +++ /project/climacs/cvsroot/climacs/misc-commands.lisp 2006/04/23 12:11:26 1.6 @@ -28,6 +28,13 @@ (in-package :climacs-gui) +(define-command (com-reload-local-options-line + :name t + :command-table buffer-table) + () + "Reload the local options line." + (evaluate-local-options-line (current-buffer))) + (define-command (com-overwrite-mode :name t :command-table editing-table) () (with-slots (overwrite-mode) (current-window) (setf overwrite-mode (not overwrite-mode)))) --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/13 10:47:48 1.51 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/23 12:11:26 1.52 @@ -42,11 +42,31 @@ (current-start-mark) (current-size) (scan) - (package)) + (package) + (base :accessor base + :initform 10 + :documentation "The base which numbers in the buffer are + expected to be in.") + (option-specified-package :accessor option-specified-package + :initform nil + :documentation "The package + specified in the local options + line (may be overridden + by (in-package) forms).")) (:name "Lisp") (:pathname-types "lisp" "lsp" "cl") (:command-table lisp-table)) +(define-option-for-syntax lisp-syntax "Package" (syntax package-name) + (let ((specified-package (find-package package-name))) + (when specified-package + (setf (option-specified-package syntax) specified-package)))) + +(define-option-for-syntax lisp-syntax "Base" (syntax base) + (let ((integer-base (parse-integer base :junk-allowed t))) + (when integer-base + (setf (base syntax) integer-base)))) + (defmethod initialize-instance :after ((syntax lisp-syntax) &rest args) (declare (ignore args)) (with-slots (buffer scan) syntax --- /project/climacs/cvsroot/climacs/file-commands.lisp 2006/03/27 15:43:17 1.5 +++ /project/climacs/cvsroot/climacs/file-commands.lisp 2006/04/23 12:11:26 1.6 @@ -129,6 +129,67 @@ :key #'climacs-syntax::syntax-description-pathname-types)) 'basic-syntax)) +(defun parse-local-options-line (line) + "Parse the local options line `line' and return an alist + mapping options to values. All option names will be coerced to + uppercase. `Line' must be stripped of the leading and + terminating -*- tokens." + (loop for pair in (split-sequence:split-sequence #\; line) + when (find #\: pair) + collect (destructuring-bind (key value) + (loop for elem in (split-sequence:split-sequence #\: pair) + collecting (string-trim " " elem)) + (list (string-upcase key) value)))) + +(defun evaluate-local-options (buffer options) + "Evaluate the local options `options' and modify `buffer' as + appropriate. `Options' should be an alist mapping option names + to their values." + ;; First, check whether we need to change the syntax (via the SYNTAX + ;; option). MODE is an alias for SYNTAX for compatibility with + ;; Emacs. If there is more than one option with one of these names, + ;; only the first will be acted upon. + (let ((specified-syntax + (syntax-from-name + (second (find-if #'(lambda (name) + (or (string= name "SYNTAX") + (string= name "MODE"))) + options + :key #'first))))) + (when specified-syntax + (setf (syntax buffer) + (make-instance specified-syntax + :buffer buffer)))) + ;; Now we iterate through the options (discarding SYNTAX and MODE + ;; options). + (loop for (name value) in options + unless (or (string= name "SYNTAX") + (string= name "MODE")) + do (eval-option (syntax buffer) name value))) + +(defun evaluate-local-options-line (buffer) + "Evaluate the local options line of `buffer'. If `buffer' does + not have a local options line, this function is a no-op." + ;; This could be simplified a bit by using regexps. + (let* ((beginning-mark (beginning-of-buffer + (clone-mark (point buffer)))) + (end-mark (end-of-line (clone-mark beginning-mark))) + (line (buffer-sequence buffer (offset beginning-mark) (offset end-mark))) + (first-occurence (search "-*-" line)) + (second-occurence + (when first-occurence + (search "-*-" line :start2 (1+ first-occurence))))) + (when (and first-occurence + second-occurence) + ;; Strip away the -*-s. + (let ((cleaned-options-line (coerce (subseq line + (+ first-occurence 3) + second-occurence) + 'string))) + (evaluate-local-options + buffer + (parse-local-options-line cleaned-options-line)))))) + ;; Adapted from cl-fad/PCL (defun directory-pathname-p (pathspec) "Returns NIL if PATHSPEC does not designate a directory." @@ -153,13 +214,19 @@ (pane (current-window))) (setf (offset (point (buffer pane))) (offset (point pane))) (setf (buffer (current-window)) buffer) - (setf (syntax buffer) - (make-instance (syntax-class-name-for-filepath filepath) - :buffer buffer)) ;; Don't want to create the file if it doesn't exist. (when (probe-file filepath) (with-open-file (stream filepath :direction :input) - (input-from-stream stream buffer 0))) + (input-from-stream stream buffer 0)) + ;; A file! That means we may have a local options + ;; line to parse. + (evaluate-local-options-line buffer)) + ;; If the local options line didn't set a syntax, do + ;; it now. + (when (null (syntax buffer)) + (setf (syntax buffer) + (make-instance (syntax-class-name-for-filepath filepath) + :buffer buffer))) (setf (filepath buffer) filepath (name buffer) (filepath-filename filepath) (needs-saving buffer) nil) --- /project/climacs/cvsroot/climacs/climacs.asd 2006/03/25 21:15:21 1.43 +++ /project/climacs/cvsroot/climacs/climacs.asd 2006/04/23 12:11:26 1.44 @@ -28,7 +28,7 @@ (defparameter *climacs-directory* (directory-namestring *load-truename*)) (defsystem :climacs - :depends-on (:mcclim :flexichain :esa) + :depends-on (:mcclim :flexichain :esa :split-sequence) :components ((:module "cl-automaton" :components ((:file "automaton-package")

1 0

[climacs-cvs] CVS climacs
by thenriksen 13 Apr '06

13 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv22566 Modified Files: lisp-syntax.lisp Log Message: Fixed inheritance hierarchy for vector forms and made `nth-form' not return invalid values. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/13 09:25:41 1.50 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/13 10:47:48 1.51 @@ -636,8 +636,8 @@ ;;; parse trees (defclass simple-vector-form (list-form) ()) -(defclass complete-simple-vector-form (complete-list-form) ()) -(defclass incomplete-simple-vector-form (incomplete-list-form) ()) +(defclass complete-simple-vector-form (complete-list-form simple-vector-form) ()) +(defclass incomplete-simple-vector-form (incomplete-list-form simple-vector-form) ()) (define-parser-state |#( form* | (lexer-list-state form-may-follow) ()) (define-parser-state |#( form* ) | (lexer-toplevel-state parser-state) ()) @@ -1190,12 +1190,13 @@ finally (return rest))) (defun nth-form (n list) - "Returns the nth form in list." + "Returns the nth form in list or `nil'." (loop for item in list count (typep item 'form) into forms until (> forms n) - finally (return item))) + finally (when (> forms n) + (return item)))) (defun elt-form (list n) "Returns the nth form in list."

1 0

[climacs-cvs] CVS climacs
by thenriksen 13 Apr '06

13 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv11930 Modified Files: lisp-syntax.lisp Log Message: Check whether the `package' slot of the syntax object is bound in `token-to-symbol'. --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/12 19:37:23 1.49 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/13 09:25:41 1.50 @@ -1851,7 +1851,8 @@ (values nil nil))))) (defun token-to-symbol (syntax token) - (let ((package (if (and (slot-value syntax 'package) + (let ((package (if (and (slot-boundp syntax 'package) + (slot-value syntax 'package) (typep (slot-value syntax 'package) 'package)) (slot-value syntax 'package) (find-package :common-lisp)))

1 0

[climacs-cvs] CVS climacs
by thenriksen 12 Apr '06

12 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv3490 Modified Files: lisp-syntax.lisp Log Message: Added `first-form', `rest-forms' functions that work as expected, changed `package-of' to use them. Also removed call to Clouseau (oops). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/12 18:52:00 1.48 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/12 19:37:23 1.49 @@ -1080,17 +1080,14 @@ (let ((buffer (buffer syntax))) (flet ((test (x) (when (typep x 'complete-list-form) - (let ((candidate (second-noncomment (children x)))) + (let ((candidate (first-form (children x)))) (and (typep candidate 'token-mixin) - (eq (parse-symbol (coerce (buffer-sequence (buffer syntax) - (start-offset candidate) - (end-offset candidate)) - 'string)) + (eq (token-to-symbol syntax candidate) 'cl:in-package)))))) (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) (when form - (let ((package-form (third-noncomment (children form)))) + (let ((package-form (second-form (children form)))) (when package-form (let ((package-name (typecase package-form @@ -1183,6 +1180,39 @@ "Returns the third non-comment in list." (nth-noncomment 2 list)) +(defun rest-forms (list) + "Returns the remainder of the list after the first form, +stripping leading non-forms." + (loop for rest on list + count (typep (car rest) 'form) + into forms + until (= forms 2) + finally (return rest))) + +(defun nth-form (n list) + "Returns the nth form in list." + (loop for item in list + count (typep item 'form) + into forms + until (> forms n) + finally (return item))) + +(defun elt-form (list n) + "Returns the nth form in list." + (nth-form n list)) + +(defun first-form (list) + "Returns the first form in list." + (nth-form 0 list)) + +(defun second-form (list) + "Returns the second form in list." + (nth-form 1 list)) + +(defun third-form (list) + "Returns the third formw in list." + (nth-form 2 list)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; display @@ -2165,7 +2195,6 @@ (beginning-of-line mark) (with-slots (stack-top) syntax (let ((path (compute-path syntax (offset mark)))) - (clouseau:inspector path) (multiple-value-bind (tree offset) (indent-form syntax stack-top path) (setf (offset mark) (start-offset tree))

1 0

[climacs-cvs] CVS climacs
by thenriksen 12 Apr '06

12 Apr '06

Update of /project/climacs/cvsroot/climacs In directory clnet:/tmp/cvs-serv29577 Modified Files: lisp-syntax.lisp Log Message: Changed `first-form', `rest-forms' etc. to `first-noncomment', `rest-noncomments' (since that's what the functions do). --- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/03 20:51:51 1.47 +++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/04/12 18:52:00 1.48 @@ -1080,7 +1080,7 @@ (let ((buffer (buffer syntax))) (flet ((test (x) (when (typep x 'complete-list-form) - (let ((candidate (second-form (children x)))) + (let ((candidate (second-noncomment (children x)))) (and (typep candidate 'token-mixin) (eq (parse-symbol (coerce (buffer-sequence (buffer syntax) (start-offset candidate) @@ -1090,7 +1090,7 @@ (with-slots (stack-top) syntax (let ((form (find-if #'test (children stack-top)))) (when form - (let ((package-form (third-form (children form)))) + (let ((package-form (third-noncomment (children form)))) (when package-form (let ((package-name (typecase package-form @@ -1109,14 +1109,14 @@ (quote-form (coerce (buffer-sequence buffer - (start-offset (second-form (children package-form))) - (end-offset (second-form (children package-form)))) + (start-offset (second-noncomment (children package-form))) + (end-offset (second-noncomment (children package-form)))) 'string)) (uninterned-symbol-form (coerce (buffer-sequence buffer - (start-offset (second-form (children package-form))) - (end-offset (second-form (children package-form)))) + (start-offset (second-noncomment (children package-form))) + (end-offset (second-noncomment (children package-form)))) 'string)) (t 'nil)))) (when package-name @@ -1150,11 +1150,11 @@ ;;; ;;; accessing parser forms -(defun first-form (list) +(defun first-noncomment (list) "Returns the first non-comment in list." (find-if-not #'(lambda (item) (typep item 'comment)) list)) -(defun rest-forms (list) +(defun rest-noncomments (list) "Returns the remainder of the list after the first non-comment, stripping leading comments." (loop for rest on list @@ -1163,7 +1163,7 @@ until (= forms 2) finally (return rest))) -(defun nth-form (n list) +(defun nth-noncomment (n list) "Returns the nth non-comment in list." (loop for item in list count (not (typep item 'comment)) @@ -1171,17 +1171,17 @@ until (> forms n) finally (return item))) -(defun elt-form (list n) +(defun elt-noncomment (list n) "Returns the nth non-comment in list." - (nth-form n list)) + (nth-noncomment n list)) -(defun second-form (list) +(defun second-noncomment (list) "Returns the second non-comment in list." - (nth-form 1 list)) + (nth-noncomment 1 list)) -(defun third-form (list) +(defun third-noncomment (list) "Returns the third non-comment in list." - (nth-form 2 list)) + (nth-noncomment 2 list)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -1372,7 +1372,7 @@ (defmethod display-parse-tree ((parse-symbol reader-conditional-positive-form) (syntax lisp-syntax) pane) - (let ((conditional (second-form (children parse-symbol)))) + (let ((conditional (second-noncomment (children parse-symbol)))) (if (eval-feature-conditional conditional syntax) (call-next-method) (let ((*current-faces* *reader-conditional-faces*)) @@ -1381,7 +1381,7 @@ (defmethod display-parse-tree ((parse-symbol reader-conditional-negative-form) (syntax lisp-syntax) pane) - (let ((conditional (second-form (children parse-symbol)))) + (let ((conditional (second-noncomment (children parse-symbol)))) (if (eval-feature-conditional conditional syntax) (let ((*current-faces* *reader-conditional-faces*)) (with-face (:reader-conditional) @@ -1408,10 +1408,10 @@ (defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax)) (let ((children (children conditional))) - (when (third-form children) + (when (third-noncomment children) (flet ((eval-fc (conditional) (funcall #'eval-feature-conditional conditional syntax))) - (let* ((type (second-form children)) + (let* ((type (second-noncomment children)) (conditionals (butlast (nthcdr 2 @@ -1473,10 +1473,10 @@ (form-before-in-children (children first) offset)))) ((and (>= offset (end-offset first)) (or (null rest) - ;; `first-form' may return NIL if there are nothing but + ;; `first-noncomment' may return NIL if there are nothing but ;; comments left; in that case, just take a comment ;; with `first'. - (<= offset (start-offset (or (first-form rest) + (<= offset (start-offset (or (first-noncomment rest) (first rest)))))) (return (let ((potential-form (when (typep first 'list-form) @@ -1680,7 +1680,7 @@ (:method (form syntax) nil)) (defmethod form-operator ((form list-form) syntax) - (let* ((operator-token (first-form (rest (children form)))) + (let* ((operator-token (first-noncomment (rest (children form)))) (operator-symbol (when operator-token (token-to-symbol syntax operator-token)))) operator-symbol)) @@ -1840,8 +1840,8 @@ (and (null (cdr path)) (zerop (car path)))) (values tree 0)) ((null (cdr path)) - (values (elt-form (children tree) (1- (car path))) 0)) - (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))) + (values (elt-noncomment (children tree) (1- (car path))) 0)) + (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) ;; FIXME: The next two methods are basically identical to the above definition, ;; something should be done about this duplication. @@ -1851,22 +1851,22 @@ (and (null (cdr path)) (zerop (car path)))) (values tree 0)) ((null (cdr path)) - (values (elt-form (children tree) (1- (car path))) 0)) - (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))) + (values (elt-noncomment (children tree) (1- (car path))) 0)) + (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) (defmethod indent-form ((syntax lisp-syntax) (tree reader-conditional-negative-form) path) (cond ((or (null path) (and (null (cdr path)) (zerop (car path)))) (values tree 0)) ((null (cdr path)) - (values (elt-form (children tree) (1- (car path))) 0)) - (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))) + (values (elt-noncomment (children tree) (1- (car path))) 0)) + (t (indent-form syntax (elt-noncomment (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-form (children tree) 1))) + (let ((first-child (elt-noncomment (children tree) 1))) (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)) @@ -1874,12 +1874,12 @@ ;; top level (if (= (car path) 2) ;; indent like first element - (values (elt-form (children tree) 1) 0) + (values (elt-noncomment (children tree) 1) 0) ;; indent like second element - (values (elt-form (children tree) 2) 0))) + (values (elt-noncomment (children tree) 2) 0))) (t ;; inside a subexpression - (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))))) (defmethod indent-form ((syntax lisp-syntax) (tree string-form) path) (values tree 1)) @@ -1894,10 +1894,10 @@ (values tree 0)) (defmethod indent-form ((syntax lisp-syntax) (tree quote-form) path) - (indent-form syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))) (defmethod indent-form ((syntax lisp-syntax) (tree backquote-form) path) - (indent-form syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))) (defmethod indent-binding ((syntax lisp-syntax) tree path) (if (null (cdr path)) @@ -1907,11 +1907,11 @@ (values tree 1)) ((= (car path) 2) ;; between variable and value - (values (elt-form (children tree) 1) 0)) + (values (elt-noncomment (children tree) 1) 0)) (t ;; after value - (values (elt-form (children tree) 2) 0))) - (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) + (values (elt-noncomment (children tree) 2) 0))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod indent-bindings ((syntax lisp-syntax) tree path) (if (null (cdr path)) @@ -1920,20 +1920,20 @@ ;; before first binding, indent 1 (values tree 1) ;; after some bindings, align with first binding - (values (elt-form (children tree) 1) 0)) + (values (elt-noncomment (children tree) 1) 0)) ;; inside a bind form - (indent-binding syntax (elt-form (children tree) (car path)) (cdr path)))) + (indent-binding syntax (elt-noncomment (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-form (children tree) 1) 0) + (values (elt-noncomment (children tree) 1) 0) ;; indent like second child - (values (elt-form (children tree) 2) 0)) + (values (elt-noncomment (children tree) 2) 0)) ;; inside a subexpression - (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmacro define-list-indentor (name element-indentor) `(defun ,name (syntax tree path) @@ -1943,9 +1943,9 @@ ;; indent one more than the list (values tree 1) ;; indent like the first element - (values (elt-form (children tree) 1) 0)) + (values (elt-noncomment (children tree) 1) 0)) ;; inside an element - (,element-indentor syntax (elt-form (children tree) (car path)) (cdr path))))) + (,element-indentor syntax (elt-noncomment (children tree) (car path)) (cdr path))))) ;;; line up the elements vertically (define-list-indentor indent-list indent-list) @@ -1967,8 +1967,8 @@ ,@(loop for fun in (cdr template) for i from 2 collect `((= (car path) ,i) - (,fun syntax (elt-form (children tree) ,i) (cdr path)))) - (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))))) + (,fun syntax (elt-noncomment (children tree) ,i) (cdr path)))) + (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (define-simple-indentor (progn)) (define-simple-indentor (prog1 indent-form)) @@ -2003,13 +2003,13 @@ (case (car path) ((2 3) ;; in the class name or superclasses respectively - (indent-list syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) (4 ;; in the slot specs - (indent-slot-specs syntax (elt-form (children tree) 4) (cdr path))) + (indent-slot-specs syntax (elt-noncomment (children tree) 4) (cdr path))) (t ;; this is an approximation, might want to do better - (indent-list syntax (elt-form (children tree) (car path)) (cdr path)))))) + (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defgeneric)) tree path) @@ -2019,13 +2019,13 @@ (case (car path) (2 ;; in the function name - (indent-list syntax (elt-form (children tree) 2) (cdr path))) + (indent-list syntax (elt-noncomment (children tree) 2) (cdr path))) (3 ;; in the lambda-list - (indent-ordinary-lambda-list syntax (elt-form (children tree) 3) (cdr path))) + (indent-ordinary-lambda-list syntax (elt-noncomment (children tree) 3) (cdr path))) (t ;; in the options or method specifications - (indent-list syntax (elt-form (children tree) (car path)) (cdr path)))))) + (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'defmethod)) tree path) @@ -2040,11 +2040,11 @@ 2))) ((or (null lambda-list-pos) (< (car path) lambda-list-pos)) - (indent-list syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) ((= (car path) lambda-list-pos) - (indent-ordinary-lambda-list syntax (elt-form (children tree) (car path)) (cdr path))) + (indent-ordinary-lambda-list syntax (elt-noncomment (children tree) (car path)) (cdr path))) (t - (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (defun indent-clause (syntax tree path) (if (null (cdr path)) @@ -2052,8 +2052,8 @@ (case (car path) (1 (values tree 1)) (2 (values tree 1)) - (t (values (elt-form (children tree) 2) 0))) - (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) + (t (values (elt-noncomment (children tree) 2) 0))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod compute-list-indentation ((syntax lisp-syntax) (symbol (eql 'cond)) tree path) @@ -2063,9 +2063,9 @@ ;; after `cond' (values tree 2) ;; indent like the first clause - (values (elt-form (children tree) 2) 0)) + (values (elt-noncomment (children tree) 2) 0)) ;; inside a clause - (indent-clause syntax (elt-form (children tree) (car path)) (cdr path)))) + (indent-clause syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (macrolet ((def (symbol) `(defmethod compute-list-indentation @@ -2074,8 +2074,8 @@ (case (car path) (2 (values tree 4)) (3 (values tree 2)) - (t (values (elt-form (children tree) 3) 0))) - (indent-clause syntax (elt-form (children tree) (car path)) (cdr path)))))) + (t (values (elt-noncomment (children tree) 3) 0))) + (indent-clause syntax (elt-noncomment (children tree) (car path)) (cdr path)))))) (def case) (def ccase) (def ecase) @@ -2091,10 +2091,10 @@ ;; the symbol existing in the current image. (Arguably, too, ;; this is a broken indentation form because it doesn't carry ;; over to the implicit tagbodies in macros such as DO. - (if (typep (elt-form (children tree) (car path)) 'token-mixin) + (if (typep (elt-noncomment (children tree) (car path)) 'token-mixin) (values tree 2) (values tree 4)) - (indent-form syntax (elt-form (children tree) (car path)) (cdr path)))) + (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path)))) (defmethod indent-local-function-definition ((syntax lisp-syntax) tree path) (cond ((null (cdr path)) @@ -2104,14 +2104,14 @@ (values tree 1)) ((= (car path) 2) ;; between name and lambda list, indent 4 - (values (elt-form (children tree) 1) 4)) + (values (elt-noncomment (children tree) 1) 4)) (t ;; after lambda list, indent 2 - (values (elt-form (children tree) 1) 2)))) + (values (elt-noncomment (children tree) 1) 2)))) ((= (car path) 1) ;; inside lambda list - (indent-ordinary-lambda-list syntax (elt-form (children tree) 1) (cdr path))) - (t (indent-form syntax (elt-form (children tree) (car path)) (cdr path))))) + (indent-ordinary-lambda-list syntax (elt-noncomment (children tree) 1) (cdr path))) + (t (indent-form syntax (elt-noncomment (children tree) (car path)) (cdr path))))) (define-list-indentor indent-local-function-definitions indent-local-function-definition) @@ -2132,12 +2132,12 @@ (defun compute-path-in-trees (trees n offset) (cond ((or (null trees) - (>= (start-offset (first-form trees)) offset)) + (>= (start-offset (first-noncomment trees)) offset)) (list n)) - ((or (< (start-offset (first-form trees)) offset (end-offset (first-form trees))) - (typep (first-form trees) 'incomplete-form-mixin)) - (cons n (compute-path-in-tree (first-form trees) offset))) - (t (compute-path-in-trees (rest-forms trees) (1+ n) offset)))) + ((or (< (start-offset (first-noncomment trees)) offset (end-offset (first-noncomment trees))) + (typep (first-noncomment trees) 'incomplete-form-mixin)) + (cons n (compute-path-in-tree (first-noncomment trees) offset))) [12 lines skipped]

1 0

[climacs-cvs] CVS esa
by thenriksen 08 Apr '06

08 Apr '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv22755 Modified Files: packages.lisp esa.lisp Log Message: Added `with-minibuffer-stream' and switched implementation of minibuffer to use an output record instead of a string. --- /project/climacs/cvsroot/esa/packages.lisp 2006/03/25 00:08:07 1.1.1.1 +++ /project/climacs/cvsroot/esa/packages.lisp 2006/04/08 23:36:44 1.2 @@ -1,6 +1,7 @@ (defpackage :esa (:use :clim-lisp :clim) (:export #:minibuffer-pane #:display-message + #:with-minibuffer-stream #:esa-pane-mixin #:previous-command #:info-pane #:master-pane #:esa-frame-mixin #:windows #:recordingp #:executingp --- /project/climacs/cvsroot/esa/esa.lisp 2006/03/27 15:38:19 1.5 +++ /project/climacs/cvsroot/esa/esa.lisp 2006/04/08 23:36:44 1.6 @@ -42,30 +42,49 @@ displayed." ) (defclass minibuffer-pane (application-pane) - ((message :initform nil :accessor message) - (message-time :initform 0 :accessor message-time)) + ((message :initform nil + :accessor message + :documentation "An output record containing whatever + message is supposed to be displayed in the + minibuffer.") + (message-time :initform 0 + :accessor message-time + :documentation "The universal time at which the + current message was set.")) (: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) - (when (> (get-universal-time) - (+ *minimum-message-time* (message-time pane))) - (setf message nil))))) + :scroll-bars nil + :display-function 'display-minibuffer)) (defmethod stream-accept :before ((pane minibuffer-pane) type &rest args) (declare (ignore type args)) (window-clear pane)) +(defun display-minibuffer (frame pane) + (declare (ignore frame)) + (when (message pane) + (if (> (get-universal-time) + (+ *minimum-message-time* (message-time pane))) + (setf (message pane) nil) + (replay-output-record (message pane) pane)))) + +(defmacro with-minibuffer-stream ((stream-symbol) + &body body) + "Bind `stream-symbol' to the minibuffer stream and evaluate + `body'. This macro makes sure to setup the initial blanking of + the minibuffer as well as taking care of for how long the + message should be displayed." + `(let ((,stream-symbol *standard-input*)) + (setf (message ,stream-symbol) + (with-output-to-output-record (,stream-symbol) + (window-clear ,stream-symbol) + (setf (message-time ,stream-symbol) (get-universal-time)) + ,@body)))) + (defun display-message (format-string &rest format-args) - (setf (message *standard-input*) - (apply #'format nil format-string format-args)) - (setf (message-time *standard-input*) - (get-universal-time))) + "Display a message in the minibuffer. Composes the string based +on the `format-string' and the `format-args'." + (with-minibuffer-stream (minibuffer) + (apply #'format minibuffer format-string format-args))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -323,6 +342,7 @@ ;; for presentation-to-command-translators, ;; which are searched for in ;; (frame-command-table *application-frame*) + (redisplay-frame-pane frame (frame-standard-input frame) :force-p t) (setf (frame-command-table frame) command-table) (process-gestures-or-command frame command-table)) (abort-gesture ()

1 0

[climacs-cvs] CVS esa
by thenriksen 08 Apr '06

08 Apr '06

Update of /project/climacs/cvsroot/esa In directory clnet:/tmp/cvs-serv15002 Modified Files: esa.asd Log Message: Added somewhat proper file dependencies. --- /project/climacs/cvsroot/esa/esa.asd 2006/03/25 00:08:07 1.1.1.1 +++ /project/climacs/cvsroot/esa/esa.asd 2006/04/08 22:34:09 1.2 @@ -8,5 +8,5 @@ :components ((:file "packages") (:file "colors" :depends-on ("packages")) (:file "esa" :depends-on ("colors" "packages")) - (:file "esa-buffer" :depends-on ("packages")) - (:file "esa-io" :depends-on ("packages")))) + (:file "esa-buffer" :depends-on ("packages" "esa")) + (:file "esa-io" :depends-on ("packages" "esa"))))

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 April 2006