[climacs-cvs] CVS update: climacs/lisp-syntax.lisp

[Dave Murray]

Update of /project/climacs/cvsroot/climacs
In directory common-lisp.net:/tmp/cvs-serv21006

Modified Files:
	lisp-syntax.lisp 
Log Message:
Small changes to movement by expression and display of reader
conditionals to exploit new handling of comments.

Date: Sat Aug 13 20:33:11 2005
Author: dmurray

Index: climacs/lisp-syntax.lisp
diff -u climacs/lisp-syntax.lisp:1.25 climacs/lisp-syntax.lisp:1.26
--- climacs/lisp-syntax.lisp:1.25	Wed Aug 10 18:38:45 2005
+++ climacs/lisp-syntax.lisp	Sat Aug 13 20:33:10 2005
@@ -1076,6 +1076,30 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
+;;; accessing parser forms
+
+(defun first-form (list)
+  "Returns the first non-comment in list."
+  (find-if-not #'(lambda (item) (typep item 'comment)) list))
+
+(defun nth-form (n list)
+  "Returns the nth non-comment in list."
+  (loop for item in list
+	count (not (typep item 'comment))
+	  into forms
+	until (= forms n)
+	finally (return item)))
+
+(defun second-form (list)
+  "Returns the second non-comment in list."
+  (nth-form 2 list))
+
+(defun third-form (list)
+  "Returns the third non-comment in list."
+  (nth-form 3 list))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;
 ;;; display
 
 (defvar *white-space-start* nil)
@@ -1258,7 +1282,7 @@
 
 (defmethod display-parse-tree ((parse-symbol reader-conditional-positive-form)
 			       (syntax lisp-syntax) pane)
-  (let ((conditional (second (children parse-symbol))))
+  (let ((conditional (second-form (children parse-symbol))))
     (if (eval-feature-conditional conditional syntax)
 	(call-next-method)
 	(let ((*current-faces* *reader-conditional-faces*))
@@ -1267,7 +1291,7 @@
 
 (defmethod display-parse-tree ((parse-symbol reader-conditional-negative-form)
 				(syntax lisp-syntax) pane)
-  (let ((conditional (second (children parse-symbol))))
+  (let ((conditional (second-form (children parse-symbol))))
     (if (eval-feature-conditional conditional syntax)
 	(let ((*current-faces* *reader-conditional-faces*))
 	  (with-face (:reader-conditional)
@@ -1296,11 +1320,16 @@
 
 (defmethod eval-feature-conditional ((conditional list-form) (syntax lisp-syntax))
   (let ((children (children conditional)))
-    (when (third children)
+    (when (third-form children)
       (flet ((eval-fc (conditional)
 	       (funcall #'eval-feature-conditional conditional syntax)))
-	(let* ((type (second children))
-	       (conditionals (butlast (nthcdr 2 children)))
+	(let* ((type (second-form children))
+	       (conditionals  (butlast
+			       (nthcdr
+				2
+				(remove-if
+				 #'(lambda (child) (typep child 'comment))
+				 children))))
 	       (type-string (coerce (buffer-sequence (buffer syntax)
 						     (start-offset type)
 						     (end-offset type))
@@ -1355,14 +1384,15 @@
 ;;; exploit the parse 
 
 (defun form-before-in-children (children offset)
-  (loop for (first second) on children
+  (loop for (first . rest) on children
+	unless (typep first 'comment)
 	do (cond ((< (start-offset first) offset (end-offset first))
 		  (return (if (null (children first))
 			      nil
 			      (form-before-in-children (children first) offset))))
 		 ((and (>= offset (end-offset first))
-		       (or (null second)
-			   (<= offset (start-offset second))))
+		       (or (null rest)
+			   (<= offset (start-offset (first-form rest)))))
 		  (return (let ((potential-form (form-before-in-children (children first) offset)))
 			    (or potential-form
 				(when (typep first 'form)
@@ -1378,16 +1408,17 @@
 
 (defun form-after-in-children (children offset)
   (loop for child in children
-	do (cond ((< (start-offset child) offset (end-offset child))
-		  (return (if (null (children child))
-			      nil
-			      (form-after-in-children (children child) offset))))
-		 ((<= offset (start-offset child))
-		  (return (let ((potential-form (form-after-in-children (children child) offset)))
-			    (or potential-form
-				(when (typep child 'form)
-				  child)))))
-		 (t nil))))
+	unless (typep child 'comment)
+	  do (cond ((< (start-offset child) offset (end-offset child))
+		    (return (if (null (children child))
+				nil
+				(form-after-in-children (children child) offset))))
+		   ((<= offset (start-offset child))
+		    (return (let ((potential-form (form-after-in-children (children child) offset)))
+			      (or potential-form
+				  (when (typep child 'form)
+				    child)))))
+		   (t nil))))
 		 
 (defun form-after (syntax offset)
   (with-slots (stack-top) syntax
@@ -1398,6 +1429,7 @@
 	     
 (defun form-around-in-children (children offset)
   (loop for child in children
+	unless (typep child 'comment)
 	do (cond ((< (start-offset child) offset (end-offset child))
 		  (return (if (null (children child))
 			      (when (typep child 'form)
@@ -1444,14 +1476,14 @@
   (with-slots (stack-top) syntax
     (loop for form in (children stack-top)
 	  with last-toplevel-list = nil
-	  when (and (typep form 'list-form)
+	  when (and (typep form 'form)
 		    (mark< mark (end-offset form)))
           do (if (mark< (start-offset form) mark)
 		 (setf (offset mark) (start-offset form))
 		 (when last-toplevel-list form
 		       (setf (offset mark) (start-offset last-toplevel-list))))
 	     (return t)
-	  when (typep form 'list-form)
+	  when (typep form 'form)
 	  do (setf last-toplevel-list form)
 	  finally (when last-toplevel-list form
 		       (setf (offset mark) (start-offset last-toplevel-list))))))
@@ -1459,7 +1491,7 @@
 (defmethod end-of-definition (mark (syntax lisp-syntax))
   (with-slots (stack-top) syntax
     (loop for form in (children stack-top)
-	  when (and (typep form 'list-form)
+	  when (and (typep form 'form)
 		    (mark< mark (end-offset form)))
 	  do (setf (offset mark) (end-offset form))
 	     (loop-finish))))