[climacs-cvs] CVS climacs
thenriksen
thenriksen at common-lisp.net
Sun Jun 4 22:19:56 UTC 2006
Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv20507
Modified Files:
lisp-syntax.lisp
Log Message:
Completely revamped the package interpretation style to be more
SLIME-like (ie. the current package is determined by the points
position in the buffer). Also added `with-syntax-package' macro for
easy determination of the package at point. Made `token-to-object' use
this macro for determining which package to look up symbols in.
--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/04 16:21:06 1.83
+++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp 2006/06/04 22:19:56 1.84
@@ -42,7 +42,12 @@
(current-start-mark)
(current-size)
(scan)
- (package)
+ (package-list :accessor package-list
+ :documentation "An alist mapping the end offset
+ of (in-package) forms to a string of the package
+ designator in the form. The list is sorted with
+ the earliest (in-package) forms last (descending
+ offset).")
(base :accessor base
:initform 10
:documentation "The base which numbers in the buffer are
@@ -71,12 +76,9 @@
(with-slots (buffer scan) syntax
(setf scan (clone-mark (low-mark buffer) :left))))
-(defmethod name-for-info-pane ((syntax lisp-syntax) &key)
+(defmethod name-for-info-pane ((syntax lisp-syntax) &key pane)
(format nil "Lisp~@[:~(~A~)~]"
- (let ((package (slot-value syntax 'package)))
- (typecase package
- (package (package-name package))
- (t package)))))
+ (package-name (package-at-mark syntax (point pane)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -1167,45 +1169,86 @@
(defmethod update-syntax-for-display (buffer (syntax lisp-syntax) top bot)
nil)
-(defun package-of (syntax)
- (let ((buffer (buffer syntax)))
+(defun package-at-mark (syntax mark-or-offset)
+ "Get the specified Lisp package for the syntax. First, an
+attempt will be made to find the package specified in
+the (in-package) preceding `mark-or-offset'. If none can be
+found, return the package specified in the attribute list. If no
+package can be found at all, or the otherwise found packages are
+invalid, return the CLIM-USER package."
+ (let* ((mark-offset (if (numberp mark-or-offset)
+ mark-or-offset
+ (offset mark-or-offset)))
+ (designator (rest (find mark-offset (package-list syntax)
+ :key #'first
+ :test #'>=))))
+ (or (handler-case (find-package designator)
+ (type-error ()
+ nil))
+ (find-package (option-specified-package syntax))
+ (find-package :clim-user))))
+
+(defmacro with-syntax-package (syntax offset (package-sym) &body
+ body)
+ "Evaluate `body' with `package-sym' bound to a valid package,
+ preferably taken from `syntax' based on `offset'.."
+ `(let ((,package-sym (package-at-mark ,syntax ,offset)))
+ , at body))
+
+(defun need-to-update-package-list-p (buffer syntax)
+ (let ((low-mark-offset (offset (low-mark buffer)))
+ (high-mark-offset (offset (high-mark buffer))))
(flet ((test (x)
- (when (typep x 'complete-list-form)
- (let ((candidate (first-form (children x))))
- (and (typep candidate 'token-mixin)
- (eq (token-to-object syntax candidate
- :no-error t)
- 'cl:in-package))))))
+ (let ((start-offset (start-offset x))
+ (end-offset (end-offset x)))
+ (when (and (or (<= start-offset
+ low-mark-offset
+ end-offset
+ high-mark-offset)
+ (<= low-mark-offset
+ start-offset
+ high-mark-offset
+ end-offset)
+ (<= low-mark-offset
+ start-offset
+ end-offset
+ high-mark-offset)
+ (<= start-offset
+ low-mark-offset
+ high-mark-offset
+ end-offset))
+ (typep x 'complete-list-form))
+ (let ((candidate (first-form (children x))))
+ (and (typep candidate 'token-mixin)
+ (eq (token-to-object syntax candidate
+ :no-error t)
+ 'cl:in-package)))))))
(with-slots (stack-top) syntax
- (let ((form (find-if #'test (children stack-top))))
- (or (when form
- (let ((package-form (second-form (children form))))
- (when package-form
- (let ((package-name
- (typecase package-form
- (token-mixin
- (token-string syntax package-form))
- (complete-string-form
- (buffer-substring
- buffer
- (1+ (start-offset package-form))
- (1- (end-offset package-form))))
- (quote-form
- (buffer-substring
- buffer
- (start-offset (second-noncomment (children package-form)))
- (end-offset (second-noncomment (children package-form)))))
- (uninterned-symbol-form
- (buffer-substring
- buffer
- (start-offset (second-noncomment (children package-form)))
- (end-offset (second-noncomment (children package-form)))))
- (t 'nil))))
- (when package-name
- (let ((package-symbol (parse-token package-name)))
- (or (find-package package-symbol)
- package-symbol)))))))
- (option-specified-package syntax)))))))
+ (or (not (slot-boundp syntax 'package-list))
+ (loop for child in (children stack-top)
+ when (test child)
+ do (return t)))))))
+
+(defun update-package-list (buffer syntax)
+ (declare (ignore buffer))
+ (setf (package-list syntax) nil)
+ (flet ((test (x)
+ (when (typep x 'complete-list-form)
+ (let ((candidate (first-form (children x))))
+ (and (typep candidate 'token-mixin)
+ (eq (token-to-object syntax candidate
+ :no-error t)
+ 'cl:in-package)))))
+ (extract (x)
+ (let ((designator (second-form (children x))))
+ (token-to-object syntax designator
+ :no-error t))))
+ (with-slots (stack-top) syntax
+ (loop for child in (children stack-top)
+ when (test child)
+ do (push (cons (end-offset child)
+ (extract child))
+ (package-list syntax))))))
(defmethod update-syntax (buffer (syntax lisp-syntax))
(let* ((low-mark (low-mark buffer))
@@ -1213,21 +1256,21 @@
(when (mark<= low-mark high-mark)
(catch 'done
(with-slots (current-state stack-top scan potentially-valid-trees) syntax
- (setf potentially-valid-trees
- (if (null stack-top)
- nil
- (find-first-potentially-valid-lexeme (children stack-top)
- (offset high-mark))))
- (setf stack-top (find-last-valid-lexeme stack-top (offset low-mark)))
- (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top))
- current-state (if (null stack-top)
- |initial-state |
- (new-state syntax
- (parser-state stack-top)
- stack-top)))
- (loop do (parse-patch syntax))))))
- (with-slots (package) syntax
- (setf package (package-of syntax))))
+ (setf potentially-valid-trees
+ (if (null stack-top)
+ nil
+ (find-first-potentially-valid-lexeme (children stack-top)
+ (offset high-mark))))
+ (setf stack-top (find-last-valid-lexeme stack-top (offset low-mark)))
+ (setf (offset scan) (if (null stack-top) 0 (end-offset stack-top))
+ current-state (if (null stack-top)
+ |initial-state |
+ (new-state syntax
+ (parser-state stack-top)
+ stack-top)))
+ (loop do (parse-patch syntax))))))
+ (when (need-to-update-package-list-p buffer syntax)
+ (update-package-list buffer syntax)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
@@ -2050,22 +2093,16 @@
;; Ensure that every symbol that is READ will be looked up
;; in the correct package. Also handle quoting.
(flet ((act ()
- (let ((*package* (if (and (slot-boundp syntax 'package)
- (slot-value syntax 'package)
- (typep (slot-value syntax 'package) 'package))
- (slot-value syntax 'package)
- (or (when package
- (if (packagep package)
- package
- (find-package package)))
- (find-package :common-lisp)))))
+ (with-syntax-package syntax (start-offset token)
+ (syntax-package)
+ (let ((*package* syntax-package))
(cond (read
(read-from-string (token-string syntax token)))
(quote
(setf (getf args :quote) nil)
`',(call-next-method))
(t
- (call-next-method))))))
+ (call-next-method)))))))
(if no-error
(ignore-errors (act))
(act))))
More information about the Climacs-cvs
mailing list