src/package.lisp, etc.: Muffle warnings about exported symbols etc.

[sod] / src / utilities.lisp

diff --git a/src/utilities.lisp b/src/utilities.lisp
index bdcdf80..a496283 100644 (file)
--- a/src/utilities.lisp
+++ b/src/utilities.lisp
@@ -23,17 +23,29 @@
 ;;; along with SOD; if not, write to the Free Software Foundation,
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
-(cl:defpackage #:sod-utilities
-  (:use #:common-lisp
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (handler-bind ((warning #'muffle-warning))
+    (cl:defpackage #:sod-utilities
+      (:use #:common-lisp
 
-       ;; MOP from somewhere.
-       #+sbcl #:sb-mop
-       #+(or cmu clisp) #:mop
-       #+ecl #:clos))
+           ;; MOP from somewhere.
+           #+sbcl #:sb-mop
+           #+(or cmu clisp) #:mop
+           #+ecl #:clos))))
 
 (cl:in-package #:sod-utilities)
 
 ;;;--------------------------------------------------------------------------
+;;; Common symbols.
+;;;
+;;; Sometimes, logically independent packages will want to use the same
+;;; symbol, and these uses (by careful design) don't conflict with each
+;;; other.  If we export the symbols here, then the necessary sharing will
+;;; happen automatically.
+
+(export 'int)                          ; used by c-types and optparse
+
+;;;--------------------------------------------------------------------------
 ;;; Macro hacks.
 
 (export 'with-gensyms)
@@ -843,7 +855,7 @@
 ;;; Functions.
 
 (export 'compose)
-(defun compose (function &rest more-functions)
+(defun compose (&rest functions)
   "Composition of functions.  Functions are applied left-to-right.
 
    This is the reverse order of the usual mathematical notation, but I find
@@ -854,7 +866,9 @@
   (labels ((compose1 (func-a func-b)
             (lambda (&rest args)
               (multiple-value-call func-b (apply func-a args)))))
-    (reduce #'compose1 more-functions :initial-value function)))
+    (if (null functions) #'values
+       (reduce #'compose1 (cdr functions)
+               :initial-value (car functions)))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Variables.
@@ -934,8 +948,9 @@
    The loop is surrounded by an anonymous BLOCK and the loop body forms an
    implicit TAGBODY, as is usual.  There is no result-form, however."
 
-  (once-only (:environment env seq start end)
-    (with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
+  (once-only (:environment env start end)
+    (with-gensyms ((seqvar "SEQ-") (ivar "INDEX-")
+                  (endvar "END-") (bodyfunc "BODY-"))
       (multiple-value-bind (docs decls body) (parse-body body :docp nil)
        (declare (ignore docs))
 
@@ -944,13 +959,13 @@
                 (let* ((do-vars nil)
                        (end-condition (if endvar
                                           `(>= ,ivar ,endvar)
-                                          `(endp ,seq)))
+                                          `(endp ,seqvar)))
                        (item (if listp
-                                 `(car ,seq)
-                                 `(aref ,seq ,ivar)))
+                                 `(car ,seqvar)
+                                 `(aref ,seqvar ,ivar)))
                        (body-call `(,bodyfunc ,item)))
                   (when listp
-                    (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
+                    (push `(,seqvar (nthcdr ,start ,seqvar) (cdr ,seqvar))
                           do-vars))
                   (when indexp
                     (push `(,ivar ,start (1+ ,ivar)) do-vars))
@@ -959,17 +974,18 @@
                   `(do ,do-vars (,end-condition) ,body-call))))
 
          `(block nil
-            (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
-                     ,@decls
-                     (tagbody ,@body)))
-              (etypecase ,seq
-                (vector
-                 (let ((,endvar (or ,end (length ,seq))))
-                   ,(loopguts t nil endvar)))
-                (list
-                 (if ,end
-                     ,(loopguts t t end)
-                     ,(loopguts indexvar t nil)))))))))))
+            (let ((,seqvar ,seq))
+              (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
+                       ,@decls
+                       (tagbody ,@body)))
+                (etypecase ,seqvar
+                  (vector
+                   (let ((,endvar (or ,end (length ,seqvar))))
+                     ,(loopguts t nil endvar)))
+                  (list
+                   (if ,end
+                       ,(loopguts t t end)
+                       ,(loopguts indexvar t nil))))))))))))
 
 ;;;--------------------------------------------------------------------------
 ;;; Structure accessor hacks.