[mcclim-cvs] CVS mcclim/Drei

[thenriksen]

Update of /project/mcclim/cvsroot/mcclim/Drei
In directory clnet:/tmp/cvs-serv5211/Drei

Modified Files:
	lisp-syntax.lisp packages.lisp 
Log Message:
Added some more nifty utility functions to Lisp syntax.


--- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp	2007/12/20 10:33:36	1.38
+++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp	2007/12/21 23:10:49	1.39
@@ -1386,6 +1386,16 @@
 `mark-or-offset' is returned."
   (form-toplevel syntax (expression-at-mark syntax mark-or-offset)))
 
+(defun list-at-mark (syntax mark-or-offset)
+  "Return the list form that `mark-or-offset' is inside, or NIL
+if no such form exists."
+  (as-offsets ((offset mark-or-offset))
+    (let ((form-around (form-around syntax offset)))
+      (if (and (form-list-p form-around)
+               (> offset (start-offset form-around)))
+          form-around
+          (find-list-parent form-around)))))
+
 (defun symbol-at-mark (syntax mark-or-offset
                        &optional (form-fetcher 'expression-at-mark))
   "Return a symbol token at `mark-or-offset'. This function will
@@ -2002,16 +2012,23 @@
                   nil
                   (form-around-in-children syntax (children stack-top) offset))))))
 
+(defun find-list-parent (form)
+  "Find a list parent of `form' and return it. If a list parent
+cannot be found, return nil"
+  (let ((parent (parent form)))
+    (typecase parent
+      (list-form parent)
+      ((or form* null) nil)
+      (t (find-list-parent-offset parent)))))
+
 (defun find-list-parent-offset (form fn)
   "Find a list parent of `form' and return `fn' applied to this
 parent token. `Fn' should be a function that returns an offset
 when applied to a token (eg. `start-offset' or `end-offset'). If
 a list parent cannot be found, return nil"
-  (let ((parent (parent form)))
-    (typecase parent
-      (list-form (funcall fn parent))
-      ((or form* null) nil)
-      (t (find-list-parent-offset parent fn)))))
+  (let ((list-parent (find-list-parent form)))
+    (when list-parent
+      (funcall fn list-parent))))
 
 (defun find-list-child-offset (form fn &optional (min-offset 0))
   "Find a list child of `token' with a minimum start
@@ -2032,6 +2049,7 @@
         (funcall fn list-child)))))
 
 (defmethod backward-one-expression (mark (syntax lisp-syntax))
+  (update-syntax syntax 0 0)
   (let ((potential-form (or (form-before syntax (offset mark))
 			    (form-around syntax (offset mark)))))
     (when (and (not (null potential-form))
@@ -2039,6 +2057,7 @@
 	(setf (offset mark) (start-offset potential-form)))))
 
 (defmethod forward-one-expression (mark (syntax lisp-syntax))
+  (update-parse syntax 0 (offset mark))
   (let ((potential-form (or (form-after syntax (offset mark))
 			    (form-around syntax (offset mark)))))
     (when (and (not (null potential-form))
@@ -2050,6 +2069,7 @@
 Return T if successful, or NIL if the buffer limit was reached."))
 
 (defmethod forward-one-list (mark (syntax lisp-syntax))
+  (update-parse syntax 0 (offset mark))
   (loop for start = (offset mark)
      then (end-offset potential-form)
      for potential-form = (or (form-after syntax start)
@@ -2067,6 +2087,7 @@
 successful, or NIL if the buffer limit was reached."))
 
 (defmethod backward-one-list (mark (syntax lisp-syntax))
+  (update-parse syntax 0 (offset mark))
   (loop for start = (offset mark)
      then (start-offset potential-form)
      for potential-form = (or (form-before syntax start)
@@ -2082,6 +2103,7 @@
 (drei-motion:define-motion-fns list)
 
 (defun down-list (mark syntax selector next-offset-fn target-offset-fn)
+  (update-parse syntax 0 (offset mark))
   (labels ((find-offset (potential-form)
              (typecase potential-form
                (list-form (funcall target-offset-fn potential-form))
@@ -2094,14 +2116,17 @@
         t))))
 
 (defmethod forward-one-down ((mark mark) (syntax lisp-syntax))
+  (update-parse syntax 0 (offset mark))
   (when (down-list mark syntax #'form-after #'end-offset #'start-offset)
     (forward-object mark)))
 
 (defmethod backward-one-down ((mark mark) (syntax lisp-syntax))
+  (update-parse syntax 0 (offset mark))
   (when (down-list mark syntax #'form-before #'start-offset #'end-offset)
     (backward-object mark)))
 
 (defun up-list (mark syntax fn)
+  (update-parse syntax 0 (offset mark))
   (let ((form (form-around syntax (offset mark))))
     (when (if (and (form-list-p form)
                    (/= (start-offset form) (offset mark))
@@ -2113,12 +2138,15 @@
       t)))
 
 (defmethod backward-one-up (mark (syntax lisp-syntax))
+  (update-parse syntax 0 (offset mark))
   (up-list mark syntax #'start-offset))
 
 (defmethod forward-one-up (mark (syntax lisp-syntax))
+  (update-parse syntax 0 (offset mark))
   (up-list mark syntax #'end-offset))
 
 (defmethod backward-one-definition ((mark mark) (syntax lisp-syntax))
+  (update-parse syntax 0 (offset mark))
   (with-slots (stack-top) syntax
     ;; FIXME? This conses! I'm over it already. I don't think it
     ;; matters much, but if someone is bored, please profile it.
@@ -2129,6 +2157,7 @@
        and do (return t))))
 
 (defmethod forward-one-definition ((mark mark) (syntax lisp-syntax))
+  (update-parse syntax 0 (offset mark))
   (with-slots (stack-top) syntax
     (loop for form in (children stack-top)
        when (and (formp form)
@@ -2137,6 +2166,7 @@
        and do (return t))))
 
 (defmethod eval-defun ((mark mark) (syntax lisp-syntax))
+  (update-parse syntax 0 (offset mark))
   (with-slots (stack-top) syntax
      (loop for form in (children stack-top)
 	   when (and (mark<= (start-offset form) mark)
--- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp	2007/12/19 17:17:37	1.23
+++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp	2007/12/21 23:10:49	1.24
@@ -500,8 +500,10 @@
 
            ;; Selecting forms based on mark
            #:form-around #:form-before #:form-after
+           #:find-list-parent
            #:expression-at-mark
            #:definition-at-mark
+           #:list-at-mark
            #:symbol-at-mark
            #:fully-quoted-form
            #:fully-unquoted-form