[slime-cvs] CVS slime/contrib

[heller]

Update of /project/slime/cvsroot/slime/contrib
In directory clnet:/tmp/cvs-serv17056/contrib

Modified Files:
	swank-arglists.lisp 
Log Message:
Move some functions to swank-arglist.lisp.

* swank.lisp (length=, ensure-list, recursively-empty-p)
(maybecall, exactly-one-p, read-softly-from-string)
(unintern-in-home-package, valid-function-name-p): Moved to
contrib/swank-arglist.lisp.


--- /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2008/01/10 20:00:17	1.18
+++ /project/slime/cvsroot/slime/contrib/swank-arglists.lisp	2008/02/04 16:35:39	1.19
@@ -12,6 +12,40 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (swank-require :swank-c-p-c))
 
+(defun length= (seq n)
+  "Test for whether SEQ contains N number of elements. I.e. it's equivalent
+ to (= (LENGTH SEQ) N), but besides being more concise, it may also be more
+ efficiently implemented."
+  (etypecase seq 
+    (list (do ((i n (1- i))
+               (list seq (cdr list)))
+              ((or (<= i 0) (null list))
+               (and (zerop i) (null list)))))
+    (sequence (= (length seq) n))))
+
+(defun ensure-list (thing)
+  (if (listp thing) thing (list thing)))
+
+(defun recursively-empty-p (list)
+  "Returns whether LIST consists only of arbitrarily nested empty lists."
+  (cond ((not (listp list)) nil)
+	((null list) t)
+	(t (every #'recursively-empty-p list))))
+
+(defun maybecall (bool fn &rest args)
+  "Call FN with ARGS if BOOL is T. Otherwise return ARGS as multiple values."
+  (if bool (apply fn args) (values-list args)))
+
+(defun exactly-one-p (&rest values)
+  "If exactly one value in VALUES is non-NIL, this value is returned.
+Otherwise NIL is returned."
+  (let ((found nil))
+    (dolist (v values)
+      (when v (if found
+                  (return-from exactly-one-p nil)
+                  (setq found v))))
+    found))
+
 (defun valid-operator-symbol-p (symbol)
   "Is SYMBOL the name of a function, a macro, or a special-operator?"
   (or (fboundp symbol)
@@ -24,6 +58,14 @@
   (let ((symbol (parse-symbol string)))
     (valid-operator-symbol-p symbol)))
 
+(defun valid-function-name-p (form)
+  (or (symbolp form)
+      (and (consp form)
+           (second form)
+           (not (third form))
+           (eq (first form) 'setf)
+           (symbolp (second form)))))
+
 (defslimefun arglist-for-echo-area (raw-specs &key arg-indices
                                                    print-right-margin print-lines)
   "Return the arglist for the first valid ``form spec'' in
@@ -243,6 +285,29 @@
     (assert (= pos (length string)))
     (values sexp interned?)))
 
+(defun read-softly-from-string (string)
+  "Returns three values:
+
+     1. the object resulting from READing STRING.
+
+     2. The index of the first character in STRING that was not read.
+
+     3. T if the object is a symbol that had to be newly interned
+        in some package. (This does not work for symbols in
+        compound forms like lists or vectors.)"
+  (multiple-value-bind (symbol found? symbol-name package) (parse-symbol string)
+    (if found?
+        (values symbol (length string) nil)
+        (multiple-value-bind (sexp pos) (read-from-string string)
+          (values sexp pos
+                  (when (symbolp sexp)
+                    (prog1 t
+                      ;; assert that PARSE-SYMBOL didn't parse incorrectly.
+                      (assert (and (equal symbol-name (symbol-name sexp))
+                                   (eq package (symbol-package sexp)))))))))))
+
+(defun unintern-in-home-package (symbol)
+  (unintern symbol (symbol-package symbol)))
 
 (defstruct (arglist (:conc-name arglist.) (:predicate arglist-p))
   provided-args         ; list of the provided actual arguments