[climacs-cvs] CVS climacs

[thenriksen]

Update of /project/climacs/cvsroot/climacs
In directory clnet:/tmp/cvs-serv24499

Modified Files:
	lisp-syntax.lisp 
Log Message:
Added new `form-operator' utility function, added some minor
performance improvements and made the paren-matcher highlight both
matching parens.


--- /project/climacs/cvsroot/climacs/lisp-syntax.lisp	2006/03/01 19:32:07	1.46
+++ /project/climacs/cvsroot/climacs/lisp-syntax.lisp	2006/04/03 20:51:51	1.47
@@ -1252,7 +1252,7 @@
 
 (defmethod display-parse-tree (parse-symbol syntax pane)
   (loop for child in (children parse-symbol)
-	do (display-parse-tree child syntax pane)))
+     do (display-parse-tree child syntax pane)))
 
 (defmethod display-parse-tree ((parse-symbol error-symbol) (syntax lisp-syntax) pane)
   (let ((children (children parse-symbol)))
@@ -1282,7 +1282,7 @@
   (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))
+  (if (> (the fixnum (end-offset parse-symbol)) (the fixnum (start-offset parse-symbol)))
       (let ((string (coerce (buffer-sequence (buffer syntax)
                                              (start-offset parse-symbol)
                                              (end-offset parse-symbol))
@@ -1431,13 +1431,22 @@
 			     #'eval-fc conditionals)))))))))
 	  
 (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)))
+  (let* ((children (children parse-symbol))
+         (point-offset (the fixnum (offset (point pane))))
+         ;; The following is set to true if the location if the point
+         ;; warrants highlighting of a set of matching parantheses.
+         (should-highlight (or (= (the fixnum (end-offset parse-symbol)) point-offset)
+                               (= (the fixnum (start-offset parse-symbol)) point-offset))))
+    (if should-highlight
 	(with-text-face (pane :bold)
 	  (display-parse-tree (car children) syntax pane))
 	(display-parse-tree (car children) syntax pane))
-    (loop for child in (cdr children)
-	  do (display-parse-tree child syntax pane))))
+    (loop for child-list on (cdr children)
+       if (and should-highlight (null (cdr child-list))) do
+         (with-text-face (pane :bold)
+           (display-parse-tree (car child-list) syntax pane))
+         else do
+         (display-parse-tree (car child-list) syntax pane))))
     
 (defmethod redisplay-pane-with-syntax ((pane climacs-pane) (syntax lisp-syntax) current-p)
   (with-slots (top bot) pane
@@ -1447,7 +1456,7 @@
      (setf *white-space-start* (offset top)))
   (let ((*current-faces* *standard-faces*))
     (with-slots (stack-top) syntax
-       (display-parse-tree stack-top syntax pane)))
+      (display-parse-tree stack-top syntax pane)))
   (when (mark-visible-p pane) (display-mark pane syntax))
   (display-cursor pane syntax current-p))
 
@@ -1665,6 +1674,17 @@
 (defun in-comment-p (mark syntax)
   (in-type-p mark syntax 'comment))
 
+(defgeneric form-operator (form syntax)
+  (:documentation "Return the operator of `form' as a
+symbol. Returns nil if none can be found.")
+  (:method (form syntax) nil))
+
+(defmethod form-operator ((form list-form) syntax)
+  (let* ((operator-token (first-form (rest (children form))))
+         (operator-symbol (when operator-token
+                            (token-to-symbol syntax operator-token))))
+    operator-symbol))
+
 ;;; 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