Merge branch 'master' of ssh://git.informatimago.com/srv/git/public/lisp

Pascal J. Bourguignon [2014-09-10 08:28]
Merge branch 'master' of ssh://git.informatimago.com/srv/git/public/lisp
Filename
common-lisp/cesarum/utility.lisp
common-lisp/interactive/browser.lisp
common-lisp/interactive/interactive.lisp
tools/asdf-file.lisp
tools/com.informatimago.tools.asd
tools/com.informatimago.tools.check-asdf.asd
tools/script.lisp
tools/symbol.lisp
diff --git a/common-lisp/cesarum/utility.lisp b/common-lisp/cesarum/utility.lisp
index f4d5e49..31e95da 100644
--- a/common-lisp/cesarum/utility.lisp
+++ b/common-lisp/cesarum/utility.lisp
@@ -271,14 +271,14 @@ WHO'S THE AUTHOR?"

 #||
 (define-if-undefined
-
-    (defmacro with-simple-restart (restart &rest body)
-      "Like PROGN, except provides control over restarts if there is an error."
-      (declare (ignore restart))
-      `(progn ,@body))

-    (defmacro done-mac () nil)
-  )
+(defmacro with-simple-restart (restart &rest body)
+"Like PROGN, except provides control over restarts if there is an error."
+(declare (ignore restart))
+`(progn ,@body))
+
+(defmacro done-mac () nil)
+)

 (defmacro uncond-mac () nil)

@@ -309,13 +309,13 @@ Return the results of the last form.
 "
   (let ((bindings (mapcar (lambda (form) (list (gensym) form)) forms)))
     `(let* ,(loop
-               for (*** ** * current) on (list* '(nil) '(nil) '(nil) bindings)
-               unless (null current)
-               collect (list (first current)
-                             (subst (first ***) '***
-                                    (subst (first **) '**
-                                           (subst (first *) '*
-                                                  (second current))))))
+              for (*** ** * current) on (list* '(nil) '(nil) '(nil) bindings)
+              unless (null current)
+                collect (list (first current)
+                              (subst (first ***) '***
+                                     (subst (first **) '**
+                                            (subst (first *) '*
+                                                   (second current))))))
        ,(first (first (last bindings))))))

 ;; (let ((*** nil) (** nil) (* nil))
@@ -420,8 +420,8 @@ NOTE:  No prefix argument are allowed for REDUCE!
 "
   (let ((arg-list (car (last args))))
     (if (< (+ (length args) (length arg-list)) call-arguments-limit)
-      (apply  fun (nconc (butlast args) arg-list))
-      (reduce fun (nconc (butlast args) arg-list)))))
+        (apply  fun (nconc (butlast args) arg-list))
+        (reduce fun (nconc (butlast args) arg-list)))))


 (defmacro while (condition &body body)
@@ -468,7 +468,7 @@ DO:    Repeat BODY with VAR bound to successive integer values from
 ;; 7 - OBJECTS
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

-
+
 (defmacro pjb-defclass (name super &rest args)
   "
 This macro encapsulate DEFCLASS and allow the declaration of the attributes
@@ -500,10 +500,10 @@ The initarg an accessor are the same keyword built from the name.
                            doc  (cadr args)) )
                     ((= 1 (length args))
                      (if (stringp (car args))
-                       (setq init nil
-                             doc  (car args))
-                       (setq init (car args)
-                             doc  nil)) )
+                         (setq init nil
+                               doc  (car args))
+                         (setq init (car args)
+                               doc  nil)) )
                     (t (error "Invalid attribute ~S"
                               `(:att ,name ,type ,@args))))
              (when (and (symbolp type) (null init))
@@ -568,9 +568,9 @@ DO:     Define a class implementing the structure API.
         The DEFSTRUCT options: :TYPE and :INITIAL-OFFSET are not supported.
 "
   (let (name options documentation slots slot-names accessors
-             conc-name constructors copier
-             include initial-offset predicate
-             print-function print-object)
+        conc-name constructors copier
+        include initial-offset predicate
+        print-function print-object)
     (declare (ignorable initial-offset))
     (if (symbolp name-and-options)
         (setf name    name-and-options
@@ -662,21 +662,21 @@ DO:     Define a class implementing the structure API.
                      (error "pjb-defclass does not implement this yet.")))))
           constructors)
        ,@(when copier
-               (list `(defmethod ,copier ((self ,name))
-                        (make-instance ',name
-                          ,@(mapcan
-                             (lambda (slot accessor)
-                               (list (make-keyword slot) (list accessor 'self)))
-                             slot-names accessors)))))
+           (list `(defmethod ,copier ((self ,name))
+                    (make-instance ',name
+                                   ,@(mapcan
+                                      (lambda (slot accessor)
+                                        (list (make-keyword slot) (list accessor 'self)))
+                                      slot-names accessors)))))
        ,@(when predicate
-               (list `(defmethod ,predicate (object)
-                        (eq (type-of object) ',name))))
+           (list `(defmethod ,predicate (object)
+                    (eq (type-of object) ',name))))
        ,@(when print-function
-               (list `(defmethod print-object ((self ,name) stream)
-                        (,print-function self stream 0))))
+           (list `(defmethod print-object ((self ,name) stream)
+                    (,print-function self stream 0))))
        ,@(when print-object
-               (list `(defmethod print-object ((self ,name) stream)
-                        (,print-object self stream)))))))
+           (list `(defmethod print-object ((self ,name) stream)
+                    (,print-object self stream)))))))



@@ -712,8 +712,8 @@ RETURN:         A string containing the object identity as printed by
         (*print-readably* nil))
     (declare (special *step-mode*))
     (let ((ident
-           (with-output-to-string (stream)
-             (print-unreadable-object (object stream :type nil :identity t)))))
+            (with-output-to-string (stream)
+              (print-unreadable-object (object stream :type nil :identity t)))))
       (subseq ident 3 (1- (length ident))))))


@@ -791,16 +791,16 @@ EXAMPLE:        (print-parseable-object (object stream :type t :identity t)
 "
   `(locally (declare (stepper disable))
      ,(if (symbolp object)
-         `(call-print-parseable-object ,object ,stream ,type ,identity
-                                       (lambda (,object)
-                                         (declare (ignorable ,object) (stepper disable))
-                                         ,(extract-slots object slots)))
-         (destructuring-bind (ovar oval) object
-           `(let ((,ovar ,oval))
-              (call-print-parseable-object ,ovar ,stream ,type ,identity
-                                           (lambda (,ovar)
-                                             (declare (ignorable ,ovar) (stepper disable))
-                                             ,(extract-slots object slots))))))))
+          `(call-print-parseable-object ,object ,stream ,type ,identity
+                                        (lambda (,object)
+                                          (declare (ignorable ,object) (stepper disable))
+                                          ,(extract-slots object slots)))
+          (destructuring-bind (ovar oval) object
+            `(let ((,ovar ,oval))
+               (call-print-parseable-object ,ovar ,stream ,type ,identity
+                                            (lambda (,ovar)
+                                              (declare (ignorable ,ovar) (stepper disable))
+                                              ,(extract-slots object slots))))))))


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -864,41 +864,41 @@ DO:       Define a macro: (WITH-{NAME} object &body body)
           symbol macros are defined to access the slots.
 "
   (let* ((name      (if (symbolp name-and-options)
-                      name-and-options (car name-and-options)))
+                        name-and-options (car name-and-options)))
          (conc-name (if (symbolp name-and-options)
-                      (concatenate 'string (string name) "-")
-                      (let ((conc-opt (car (member :conc-name
-                                                   (cdr name-and-options)
-                                                   :key (function car)))))
-                        (if conc-opt
-                          (second conc-opt)
-                          (concatenate 'string (string name) "-")))))
+                        (concatenate 'string (string name) "-")
+                        (let ((conc-opt (car (member :conc-name
+                                                     (cdr name-and-options)
+                                                     :key (function car)))))
+                          (if conc-opt
+                              (second conc-opt)
+                              (concatenate 'string (string name) "-")))))
          (slot-names (mapcar (lambda (slot) (if (listp slot) (car slot) slot))
                              slots)))
     `(progn
        (defstruct ,name-and-options ,@slots)
        (defmacro
-         ,(intern (with-standard-io-syntax (format nil "WITH-~A" name)))
-         (object &body body)
+           ,(intern (with-standard-io-syntax (format nil "WITH-~A" name)))
+           (object &body body)
          (if (symbolp object)
-           `(symbol-macrolet
-             ,(mapcar
-               (lambda (slot)
-                 (list slot
-                       (list
-                        (intern (concatenate 'string (string ',conc-name) (string slot)))
-                        object))) ',slot-names)
-             ,@body)
-           (let ((objv (gensym)))
-             `(let ((,objv ,object))
-                (symbol-macrolet
-                 ,(mapcar
-                   (lambda (slot)
-                     (list slot
-                           (list
-                            (intern (concatenate 'string (string ',conc-name) (string slot)))
-                            objv))) ',slot-names)
-                 ,@body))))))))
+             `(symbol-macrolet
+                  ,(mapcar
+                    (lambda (slot)
+                      (list slot
+                            (list
+                             (intern (concatenate 'string (string ',conc-name) (string slot)))
+                             object))) ',slot-names)
+                ,@body)
+             (let ((objv (gensym)))
+               `(let ((,objv ,object))
+                  (symbol-macrolet
+                      ,(mapcar
+                        (lambda (slot)
+                          (list slot
+                                (list
+                                 (intern (concatenate 'string (string ',conc-name) (string slot)))
+                                 objv))) ',slot-names)
+                    ,@body))))))))

 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; 9 - CONDITIONS
@@ -1104,7 +1104,7 @@ there are fewer distinct representations, the following rules apply:
                   ,@(loop
                       :for (type . body) :in clauses
                       :when (member type types)
-                      :collect `(,type ,@body))))))
+                        :collect `(,type ,@body))))))


 (defmacro float-typecase (expression &rest clauses)
@@ -1152,7 +1152,7 @@ DO:        Expands to a ETYPECASE where only the clauses with unique


 (defmacro float-ctypecase (expression &rest clauses)
-    "
+  "
 EXPRESSION: an expression evaluate to some value.

 CLAUSES:    ctypecase clauses where the type is one of the standard
@@ -1180,33 +1180,33 @@ DO:        Expands to a CTYPECASE where only the clauses with unique
     (* sign (scale-float
              (if (minusp sign)
                  (- significand (float-etypecase float
-                                  (long-float   long-float-negative-epsilon)
-                                  (double-float double-float-negative-epsilon)
-                                  (single-float single-float-negative-epsilon)
-                                  (short-float  short-float-negative-epsilon)))
+                                                 (long-float   long-float-negative-epsilon)
+                                                 (double-float double-float-negative-epsilon)
+                                                 (single-float single-float-negative-epsilon)
+                                                 (short-float  short-float-negative-epsilon)))
                  (+ significand (float-etypecase float
-                                  (long-float   long-float-epsilon)
-                                  (double-float double-float-epsilon)
-                                  (single-float single-float-epsilon)
-                                  (short-float  short-float-epsilon))))
+                                                 (long-float   long-float-epsilon)
+                                                 (double-float double-float-epsilon)
+                                                 (single-float single-float-epsilon)
+                                                 (short-float  short-float-epsilon))))
              exponent))))

 (defun -epsilon (float)
-   "Returns the float incremented by the smallest increment possible."
-   (multiple-value-bind (significand exponent sign) (decode-float float)
-     (* sign (scale-float
-              (if (minusp sign)
-                  (+ significand (float-etypecase float
-                                   (long-float   long-float-negative-epsilon)
-                                   (double-float double-float-negative-epsilon)
-                                   (single-float single-float-negative-epsilon)
-                                   (short-float  short-float-negative-epsilon)))
-                  (- significand (float-etypecase float
-                                   (long-float   long-float-epsilon)
-                                   (double-float double-float-epsilon)
-                                   (single-float single-float-epsilon)
-                                   (short-float  short-float-epsilon))))
-              exponent))))
+  "Returns the float incremented by the smallest increment possible."
+  (multiple-value-bind (significand exponent sign) (decode-float float)
+    (* sign (scale-float
+             (if (minusp sign)
+                 (+ significand (float-etypecase float
+                                                 (long-float   long-float-negative-epsilon)
+                                                 (double-float double-float-negative-epsilon)
+                                                 (single-float single-float-negative-epsilon)
+                                                 (short-float  short-float-negative-epsilon)))
+                 (- significand (float-etypecase float
+                                                 (long-float   long-float-epsilon)
+                                                 (double-float double-float-epsilon)
+                                                 (single-float single-float-epsilon)
+                                                 (short-float  short-float-epsilon))))
+             exponent))))


 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -1267,10 +1267,10 @@ NOTE:    This version avoids calling FUN twice with the same argument.
              :finally (return result))))
     (loop
       :for follows = (delete-duplicates (join (mapcar fun set)))
-      :then (delete-duplicates (join (cons follows (mapcar fun newbies))))
+        :then (delete-duplicates (join (cons follows (mapcar fun newbies))))
       :for newbies = (set-difference follows set)
       :while newbies
-       ;; :do (print (list 'newbies newbies))
+      ;; :do (print (list 'newbies newbies))
       :do (setf set (append newbies set))
       :finally (return set))))

@@ -1279,37 +1279,37 @@ NOTE:    This version avoids calling FUN twice with the same argument.
 ;; (DEFUN ARRAY->LIST (A) (MAP 'LIST (FUNCTION IDENTITY) A));;ARRAY->LIST

 (defun topological-sort (nodes lessp)
-   "
+  "
 RETURN: A list of NODES sorted topologically according to
         the partial order function LESSP.
         If there are cycles (discounting reflexivity),
         then the list returned won't contain all the NODES.
 "
-   (loop
-     :with sorted = '()
-     :with incoming = (map 'vector (lambda (to)
-                                     (loop
-                                       :for from :in nodes
-                                       :when (and (not (eq from to))
-                                                  (funcall lessp from to))
-                                       :sum 1))
-                           nodes)
-     :with q = (loop
-                 :for node :in nodes
-                 :for inco :across incoming
-                 :when (zerop inco)
-                 :collect node)
-     :while q
-     :do (let ((n (pop q)))
-           (push n sorted)
-           (loop
-             :for m :in nodes
-             :for i :from 0
-             :do (when (and (and (not (eq n m))
-                                 (funcall lessp n m))
-                            (zerop (decf (aref incoming i))))
-                   (push m q))))
-     :finally (return (nreverse sorted))))
+  (loop
+    :with sorted = '()
+    :with incoming = (map 'vector (lambda (to)
+                                    (loop
+                                      :for from :in nodes
+                                      :when (and (not (eq from to))
+                                                 (funcall lessp from to))
+                                        :sum 1))
+                       nodes)
+    :with q = (loop
+                :for node :in nodes
+                :for inco :across incoming
+                :when (zerop inco)
+                  :collect node)
+    :while q
+    :do (let ((n (pop q)))
+          (push n sorted)
+          (loop
+            :for m :in nodes
+            :for i :from 0
+            :do (when (and (and (not (eq n m))
+                                (funcall lessp n m))
+                           (zerop (decf (aref incoming i))))
+                  (push m q))))
+    :finally (return (nreverse sorted))))



@@ -1331,7 +1331,7 @@ RETURN:  VECTOR
   (do ((index 0 (1+ index)))
       ((>= index (array-dimension vector 0)))
     (setf (aref vector index) (funcall constructor index)))
-  vector) ;;VECTOR-INIT
+  vector)


 (defun undisplace-array (array)
@@ -1343,71 +1343,71 @@ AUTHOR:  Erik Naggum <erik@naggum.no>
   (let ((length (length array))
         (start 0))
     (loop
-       (multiple-value-bind (to offset) (array-displacement array)
-         (if to
-             (setq array to
-                   start (+ start offset))
-             (return (values array start (+ start length)))))))
-  ) ;;UNDISPLACE-ARRAY
+      (multiple-value-bind (to offset) (array-displacement array)
+        (if to
+            (setq array to
+                  start (+ start offset))
+            (return (values array start (+ start length))))))))


-(defun dichotomy (matchp min max)
-    "
+(defun dichotomy (matchp start end)
+  "

-MATCHP: A function taking an integer between START and END, and
+MATCHP: A function taking an integer between [START,END[, and
         returning an order (signed integer).
-MIN:    The minimum integer.
-MAX:    The maximum integer.
+START:  The minimum integer.
+END:    The maximum integer+1.
 RETURN: (values found index order)
-POST:	(<= min index max)
-        +-------------------+----------+-------+----------+----------------+
-        | Case              |  found   | index |  order   |     Error      |
-        +-------------------+----------+-------+----------+----------------+
-        | x < a[i]          |   FALSE  |  min  |  less    |      0         |
-        | a[i] < x < a[i+1] |   FALSE  |   i   |  greater |      0         |
-        | x = a[i]          |   TRUE   |   i   |  equal   |      0         |
-        | a[max] < x        |   FALSE  |  max  |  greater |      0         |
-        +-------------------+----------+-------+----------+----------------+
+POST:	(<= start index (1- end))
+        +-------------------+----------+-------+----------+
+        | Case              |  found   | index |  order   |
+        +-------------------+----------+-------+----------+
+        | x < a[i]          |   FALSE  | start |  less    |
+        | a[i] < x < a[i+1] |   FALSE  |   i   |  greater |
+        | x = a[i]          |   TRUE   |   i   |  equal   |
+        | a[max] < x        |   FALSE  | end-1 |  greater |
+        +-------------------+----------+-------+----------+
 "
-    (let* ((curmin min)
-           (curmax max)
-           (index  (truncate (+ curmin curmax) 2))
-           (order  (funcall matchp index)))
-      (loop :while (and (/= 0 order) (/= curmin index)) :do
-         ;; (FORMAT T "~&min=~S  cur=~S  max=~S   key=~S <~S> [cur]=~S ~%" CURMIN INDEX CURMAX VALUE (FUNCALL COMPARE VALUE (FUNCALL KEY (AREF VECTOR INDEX))) (AREF VECTOR INDEX))
-         (if (< order 0)
-             (setf curmax index)
-             (setf curmin index))
-         (setf index (truncate (+ curmin curmax) 2))
-         (setf order (funcall matchp index)))
-      (when (and (< min index) (< order 0))
-        (setf order 1)
-        (decf index))
-      (assert
-       (or (< (funcall matchp index) 0)
-           (and (> (funcall matchp index) 0)
-                (or (>= (1+ index) max)
-                    (< (funcall matchp (1+ index)) 0)))
-           (= (funcall matchp index) 0)))
-      (values (= order 0) index order)))
+  (let* ((curmin start)
+         (curmax end)
+         (index  (truncate (+ curmin curmax) 2))
+         (order  (funcall matchp index)))
+    (loop :while (and (/= 0 order) (/= curmin index)) :do
+      ;; (format t "~&min=~S  cur=~S  max=~S  <~S>~%" curmin index curmax (funcall matchp index))
+      (if (minusp order)
+          (setf curmax index)
+          (setf curmin index))
+      (setf index (truncate (+ curmin curmax) 2))
+      (setf order (funcall matchp index)))
+    ;; (format t "~&min=~S  cur=~S  max=~S  <~S> []~%" curmin index curmax (funcall matchp index))
+    (when (and (< start index) (minusp order))
+      (setf order 1)
+      (decf index))
+    (assert
+     (or (minusp (funcall matchp index))
+         (and (plusp (funcall matchp index))
+              (or (>= (1+ index) end)
+                  (minusp (funcall matchp (1+ index)))))
+         (= (funcall matchp index) 0)))
+    (values (zerop order) index order)))


 (defun dichotomy-search (vector value compare &key
-                         (start 0) (end (length vector))
-                         (key (function identity)))
+                                                (start 0) (end (length vector))
+                                                (key (function identity)))
   "
 PRE:	entry is the element to be searched in the table.
         (<= start end)
 RETURN: (values found index order)
 POST:	(<= start index end)
-        +-------------------+----------+-------+----------+----------------+
-        | Case              |  found   | index |  order   |     Error      |
-        +-------------------+----------+-------+----------+----------------+
-        | x < a[min]        |   FALSE  |  min  |  less    |      0         |
-        | a[i] < x < a[i+1] |   FALSE  |   i   |  greater |      0         |
-        | x = a[i]          |   TRUE   |   i   |  equal   |      0         |
-        | a[max] < x        |   FALSE  |  max  |  greater |      0         |
-        +-------------------+----------+-------+----------+----------------+
+        +-------------------+----------+-------+----------+
+        | Case              |  found   | index |  order   |
+        +-------------------+----------+-------+----------+
+        | x < a[min]        |   FALSE  |  min  |  less    |
+        | a[i] < x < a[i+1] |   FALSE  |   i   |  greater |
+        | x = a[i]          |   TRUE   |   i   |  equal   |
+        | a[max] < x        |   FALSE  |  max  |  greater |
+        +-------------------+----------+-------+----------+
 "
   (if (zerop (length vector))
       (values nil 0 -1)
@@ -1425,13 +1425,16 @@ POST:	(<= start index end)
         (when (and (< start index) (< order 0))
           (setf order 1)
           (decf index))
-        (assert
-         (or (< (funcall compare value (funcall key (aref vector index))) 0)
-             (and (> (funcall compare value (funcall key (aref vector index))) 0)
-                  (or (>= (1+ index) end)
-                      (< (funcall compare value
-                                  (funcall key (aref vector (1+  index)))) 0)))
-             (= (funcall compare value (funcall key (aref vector index))) 0)))
+        (assert (or (minusp (funcall compare value (funcall key (aref vector index))))
+                    (and (plusp (funcall compare value (funcall key (aref vector index))))
+                         (or (>= (1+ index) end)
+                             (minusp (funcall compare value
+                                              (funcall key (aref vector (1+  index)))))))
+                    (zerop (funcall compare value (funcall key (aref vector index)))))
+
+                (index)
+                "The compare function is invalid: value<a[~D] or a[~:*~D]<value<a[~D] or a[~D]<value or a[~0@*~D]=value"
+                index (1+ index) end)
         (values (= order 0) index order))))


@@ -1547,21 +1550,21 @@ RETURN: If TABLE is NIL, then NIL,


 (defun hashtable (&key (test (function eql))
-                  (size nil sizep)
-                  (rehash-size nil rehash-size-p)
-                  (rehash-threshold nil rehash-threshold-p)
-                  elements)
+                    (size nil sizep)
+                    (rehash-size nil rehash-size-p)
+                    (rehash-threshold nil rehash-threshold-p)
+                    elements)
   "Creates a new hash-table, filled with the given ELEMENTS.
 ELEMENTS must be a list of lists of two items, the key and the value.
 Note: we use the name HASHTABLE to avoid name collision."
   (let ((table (apply (function make-hash-table)
-                :test test
-                (append (when sizep
-                          (list :size size))
-                        (when rehash-size-p
-                          (list :rehash-size rehash-size))
-                        (when rehash-threshold-p
-                          (list :rehash-threshold rehash-threshold))))))
+                      :test test
+                      (append (when sizep
+                                (list :size size))
+                              (when rehash-size-p
+                                (list :rehash-size rehash-size))
+                              (when rehash-threshold-p
+                                (list :rehash-threshold rehash-threshold))))))
     (dolist (item elements table)
       (setf (gethash (first item) table) (second item)))))

@@ -1589,7 +1592,7 @@ The other key parameter are passed to MAKE-HASH-TABLE.
                                 (list :rehash-threshold rehash-threshold))))))
     (map nil (lambda (element)
                (setf (gethash (funcall key element) table) (funcall value element)))
-         sequence)
+      sequence)
     table))


@@ -1669,7 +1672,7 @@ Like LET, but prints on the *trace-output* the value of the bindings.
 "
   (let ((vals (mapcar (lambda (clause)
                         (gensym (symbol-name
-                                  (if (symbolp clause) clause (first clause)))))
+                                 (if (symbolp clause) clause (first clause)))))
                       clauses))
         (res (gensym)))
     `(let ,(mapcar
@@ -1694,13 +1697,13 @@ Like LET, but prints on the *trace-output* the value of the bindings.


 (defmacro tracing-let* (clauses &body body)
-    "
+  "
 Like LET*, but prints on the *trace-output* the value of the bindings.
 "
   (if (null clauses)
       `(progn ,@body)
       `(tracing-let (,(first clauses))
-                    (tracing-let* ,(rest clauses) ,@body))))
+         (tracing-let* ,(rest clauses) ,@body))))


 (defmacro tracing-labels (defs &body body)
@@ -1713,20 +1716,20 @@ the local functions."
                              (parse-lambda-list (second def) :ordinary)))
                  (res (gensym "RESULTS")))
              `(,(first def) ,(second def)
-                ,@(when (stringp (third def))
-                        (list (third def)))
-                (format *trace-output*
-                  "~&Entering ~A (~@{:~A ~S~^ ~})~%" ',(first def)
-                  ,@(mapcan (lambda (arg) (list `',arg arg)) arguments))
-                (unwind-protect
-                     (progn (format *trace-output*
-                              "~&Exiting ~A --> ~{~S~^; ~}~%"
-                              ',(first def)
-                              (setf ,res (multiple-value-list
-                                          (progn ,@(cddr def)))))
-                            (values-list ,res))
-                  (format *trace-output*
-                    "~&Unwinding ~A~%" ',(first def))))))
+               ,@(when (stringp (third def))
+                   (list (third def)))
+               (format *trace-output*
+                       "~&Entering ~A (~@{:~A ~S~^ ~})~%" ',(first def)
+                       ,@(mapcan (lambda (arg) (list `',arg arg)) arguments))
+               (unwind-protect
+                    (progn (format *trace-output*
+                                   "~&Exiting ~A --> ~{~S~^; ~}~%"
+                                   ',(first def)
+                                   (setf ,res (multiple-value-list
+                                               (progn ,@(cddr def)))))
+                           (values-list ,res))
+                 (format *trace-output*
+                         "~&Unwinding ~A~%" ',(first def))))))
          defs)
      ,@body))

@@ -1749,7 +1752,7 @@ the local functions."
                             (itt items (1+ pivot) end)))))))
       (let ((vect (coerce sequence 'vector)))
         (itt vect 0 (length vect)))))
-
+
   (defun map-tree-postfix (fun tree)
     (if (null tree)
         nil
@@ -1782,8 +1785,8 @@ DO:       Evaluate the expression, which must be a real,
            (flet ((gen-case ()
                     (incf index)
                     (if (zerop index)
-                       `(progn ,@(cdr less))
-                       `(progn ,@(cdr (aref clauses (1- index)))))))
+                        `(progn ,@(cdr less))
+                        `(progn ,@(cdr (aref clauses (1- index)))))))
              (lambda (node left right)
                (if (and (null left) (null right))
                    `(if (< ,vexpr ,(car node))
diff --git a/common-lisp/interactive/browser.lisp b/common-lisp/interactive/browser.lisp
index 7614312..1ecd8a7 100644
--- a/common-lisp/interactive/browser.lisp
+++ b/common-lisp/interactive/browser.lisp
@@ -105,7 +105,7 @@ Client code can rebind it to another universal date or set it to (now).")

 (defun parse-short-month (short-month-name)
   (let ((pos (position short-month-name *short-month-names*
-              :test (function string-equal))))
+                       :test (function string-equal))))
     (and pos (1+ pos))))


@@ -123,20 +123,20 @@ Client code can rebind it to another universal date or set it to (now).")
   (declare (ignore at arguments))
   (multiple-value-bind (se mi ho da mo ye) (decode-universal-time date)
     (if colon
-     (cond
-       ((< (- *today* date) (* 24 60 60))
-        (format stream  "~2,'0D:~2,'0D:~2,'0D   " ho mi se))
-       ((< (- *today* date) (* 6 30 24 60 60))
-        (format stream "~2,'0D-~2,'0D ~2,'0D:~2,'0D" mo da ho mi))
-       (t
-        (format stream "~4,'0D-~2,'0D-~2,'0D " ye mo da)))
-     (cond
-       ((< (- *today* date) (* 6 30 24 60 60))
-        (format stream "~3A ~2D ~2,'0D:~2,'0D"
-                (aref *short-month-names* (1- mo)) da ho mi))
-       (t
-        (format stream "~3A ~2D ~5D"
-                (aref *short-month-names* (1- mo)) da ye))))))
+        (cond
+          ((< (- *today* date) (* 24 60 60))
+           (format stream  "~2,'0D:~2,'0D:~2,'0D   " ho mi se))
+          ((< (- *today* date) (* 6 30 24 60 60))
+           (format stream "~2,'0D-~2,'0D ~2,'0D:~2,'0D" mo da ho mi))
+          (t
+           (format stream "~4,'0D-~2,'0D-~2,'0D " ye mo da)))
+        (cond
+          ((< (- *today* date) (* 6 30 24 60 60))
+           (format stream "~3A ~2D ~2,'0D:~2,'0D"
+                   (aref *short-month-names* (1- mo)) da ho mi))
+          (t
+           (format stream "~3A ~2D ~5D"
+                   (aref *short-month-names* (1- mo)) da ye))))))


 (defun shorter-date (universal-time)
@@ -167,7 +167,7 @@ Client code can rebind it to another universal date or set it to (now).")
                                     (symbol (string-downcase item))
                                     (otherwise item))) (cons name args)))))
       (error "Please assign a shell function to ~S" '*shell*)))
-
+
 (defmacro defcommand (name &optional docstring)
   "Define a macro named NAME taking any number of arguments, and
 calling the external program of same name thru the shell."
@@ -212,30 +212,30 @@ three synchronized.
   "Return: whether all the directories in PATH exist;
            the path to the first directory that doesn't exist."
   (let* ((non-existent
-          (find-if-not
-           (lambda (dir)
-             #+ccl (declare (ignore dir))
-
-             ;; We cannot use directory to check whether a directory
-             ;; exists.  So we try a file pattern, and if not found
-             ;; but no error is signaled, assume the directory exists.
-
-             ;; Of course, this doesn't work on some implementations
-             ;; such as ccl.
-
-             ;; On ccl, if we try to create a file in an inexistant
-             ;; directory, it will create it!!!  But we can use
-             ;; probe-file to test directories in ccl…
-
-
-             (ignore-errors
+           (find-if-not
+            (lambda (dir)
+              #+ccl (declare (ignore dir))
+
+              ;; We cannot use directory to check whether a directory
+              ;; exists.  So we try a file pattern, and if not found
+              ;; but no error is signaled, assume the directory exists.
+
+              ;; Of course, this doesn't work on some implementations
+              ;; such as ccl.
+
+              ;; On ccl, if we try to create a file in an inexistant
+              ;; directory, it will create it!!!  But we can use
+              ;; probe-file to test directories in ccl…
+
+
+              (ignore-errors
                (or
                 #-ccl (directory (make-pathname :directory dir :name "RARE" :type "RARE" :defaults path))
                 #+ccl (probe-file path)
                 t))
-             )
-           (nreverse
-            (loop
+              )
+            (nreverse
+             (loop
                :for dir :on (reverse (pathname-directory path))
                :collect (reverse dir))))))
     (values (not non-existent)
@@ -261,7 +261,7 @@ RETURN: *WORKING-DIRECTORY*
   *working-directory*)


-
+
 (defun parent-directory (dirpath)
   (make-pathname :directory (let ((dir (pathname-directory dirpath)))
                               (cons (car dir) (butlast (cdr dir))))
@@ -330,48 +330,48 @@ DO:         Displays the contents of the working directory and
             to load files.
 "
   (loop
-     (let* ((subdirs     (sort (subdirectories-names (working-directory))
-                               (function string<)))
-            (files       (sort (files (working-directory) :type "lisp")
-                               (lambda (a b) (string< (car a) (car b)))))
-            (item-count  (+ (length subdirs) (length files)))
-            (count-width (if (= 0 item-count) 1 (ceiling (log item-count 10)))))
-       (format t "~&")
-       (format t "--- current directory ----------------------------~%")
-       (format t "~V,A  ~A~%" count-width "" (working-directory))
-       (format t "--- parent directory ----------------------------~%")
-       (format t "~V,D) ~A~%"
-               count-width 0 (parent-directory (working-directory)))
-       (when subdirs
-         (format t "--- subdirectories -------------------------------~%")
-         (print-list t subdirs 1 :index-width count-width))
-       (when files
-         (format t "--- files ----------------------------------------~%")
-         (print-list t (mapcar (function car) files)
-                     (1+ (length subdirs)) :index-width count-width))
-       (format t "--------------------------------------------------~%")
-       (let ((answer
+    (let* ((subdirs     (sort (subdirectories-names (working-directory))
+                              (function string<)))
+           (files       (sort (files (working-directory) :type "lisp")
+                              (lambda (a b) (string< (car a) (car b)))))
+           (item-count  (+ (length subdirs) (length files)))
+           (count-width (if (= 0 item-count) 1 (ceiling (log item-count 10)))))
+      (format t "~&")
+      (format t "--- current directory ----------------------------~%")
+      (format t "~V,A  ~A~%" count-width "" (working-directory))
+      (format t "--- parent directory ----------------------------~%")
+      (format t "~V,D) ~A~%"
+              count-width 0 (parent-directory (working-directory)))
+      (when subdirs
+        (format t "--- subdirectories -------------------------------~%")
+        (print-list t subdirs 1 :index-width count-width))
+      (when files
+        (format t "--- files ----------------------------------------~%")
+        (print-list t (mapcar (function car) files)
+                    (1+ (length subdirs)) :index-width count-width))
+      (format t "--------------------------------------------------~%")
+      (let ((answer
               (block :answer
                 (loop
-                   (format t "~&Change directory number, ~
+                  (format t "~&Change directory number, ~
                             load file number, or -1 to quit: ")
-                   (finish-output)
-                   (let ((answer (read t nil nil)))
-                     (typecase answer
-                       (integer (if (<= -1 answer item-count)
-                                    (return-from :answer answer)
-                                    (format t "~&Input out of range.~%")))
-                       (otherwise (format t "~&Bad input type.~%"))))))))
-         (cond
-           ((= -1 answer) (return))
-           ((= 0 answer)
-            (change-working-directory (parent-directory (working-directory))))
-           ((<= answer (length subdirs))
-            (change-working-directory
-             (child-directory (working-directory) (elt subdirs (1- answer)))))
-           (t (load (cdr (elt files (- answer (length subdirs) 1)))
-                    :verbose t)))))))
-
+                  (finish-output)
+                  (let ((answer (read t nil nil)))
+                    (typecase answer
+                      (integer (if (<= -1 answer item-count)
+                                   (return-from :answer answer)
+                                   (format t "~&Input out of range.~%")))
+                      (otherwise (format t "~&Bad input type.~%"))))))))
+        (cond
+          ((= -1 answer) (return))
+          ((= 0 answer)
+           (change-working-directory (parent-directory (working-directory))))
+          ((<= answer (length subdirs))
+           (change-working-directory
+            (child-directory (working-directory) (elt subdirs (1- answer)))))
+          (t (load (cdr (elt files (- answer (length subdirs) 1)))
+                   :verbose t)))))))
+

 (defun resolve (path &key (directory nil))
   (setf path (typecase path
@@ -422,8 +422,8 @@ RETURN: A list of options; a list of arguments
                      (otherwise (format nil "~A" (car args))))))
       (if (and (< 0 (length current))
                (char= (character "-") (char current 0)))
-           (push current options)
-           (push current arguments)))))
+          (push current options)
+          (push current arguments)))))


 (defun relativize (path default)
@@ -501,48 +501,58 @@ ARGUMENTS:  A list of paths. If name or type is not nil, then the file name
                :directory t))))


-
 (defun ls (&rest args)
   "COMMAND
 DO:         List the files or directories.
 OPTIONS:    -L long listing: item kind, size, date, name; otherwise only name.
+            -A all entries: list also entries whose name starts with a dot or ends with a tilde.
 ARGUMENTS:  A list of paths possibly containing wildcards.
             If none is given, then \"*\" is used.
 "
   (setf *today* (get-universal-time))
   (multiple-value-bind (opts args) (split-options args)
-    (let ((opt-long nil))
+    (let ((opt-long nil)
+          (opt-all  nil))
       (dolist (opt opts)
-        (cond ((string-equal  "-l" opt) (setf opt-long t))
-              (t (error "Invalid option ~A" opt))))
+        (cond ((or (eq :l opt) (string-equal  "-l" opt)) (setf opt-long t))
+              ((or (eq :a opt) (string-equal  "-a" opt)) (setf opt-all  t))
+              (t (error "Invalid option ~S" opt))))
       (dolist (entry
-                (sort
-                 (delete-duplicates
-                  ;; SBCL RETURNS DIRECTORIES FOR "*" AS WELL AS FOR "*/".
-                  (mapcan
-                   (lambda (path) (handler-case (directory path) (error () nil)))
-                   (mapcar
-                    (lambda (path) (resolve path :directory nil))
-                    (or (delete-duplicates
-                         (mapcan (function wilder-path) args)
-                         :key (function namestring)
-                         :test (function string=))
-                        '("*/" "*"))))
-                  :key (function namestring)
-                  :test (function string=))
-                 (function string<) :key (function namestring)))
-        (if opt-long
-            (format t "~1A ~10A ~11A ~A~%"
-                    (if (pathname-name entry) "-" "d")
-                    (handler-case
-                        (with-open-file (file entry :direction :input)
-                          (format nil "~10D" (file-length file)))
-                      (error () ""))
-                    (handler-case (shorter-date (file-write-date entry))
-                      (error () ""))
-                    (namestring (relativize entry (working-directory))))
-            (format t "~A~%"
-                    (namestring (relativize entry (working-directory))))))))
+               (sort
+                (delete-duplicates
+                 ;; SBCL RETURNS DIRECTORIES FOR "*" AS WELL AS FOR "*/".
+                 (mapcan
+                  (lambda (path) (handler-case (directory path) (error () nil)))
+                  (mapcar
+                   (lambda (path) (resolve path :directory nil))
+                   (or (delete-duplicates
+                        (mapcan (function wilder-path) args)
+                        :key (function namestring)
+                        :test (function string=))
+                       '("*/" "*" "*.*"))))
+                 :key (function namestring)
+                 :test (function string=))
+                (function string<) :key (function namestring)))
+        (when (or  opt-all
+                   (let* ((fns  (file-namestring entry))
+                          (name (if (string/= "" fns)
+                                    fns
+                                    (first (last (pathname-directory entry))))))
+                     (not (or (prefixp "."   name)
+                              #+ccl  (prefixp "\\." name)
+                              (suffixp "~"   name)))))
+          (if opt-long
+              (format t "~1A ~10A ~11A ~A~%"
+                      (if (pathname-name entry) "-" "d")
+                      (handler-case
+                          (with-open-file (file entry :direction :input)
+                            (format nil "~10D" (file-length file)))
+                        (error () ""))
+                      (handler-case (shorter-date (file-write-date entry))
+                        (error () ""))
+                      (namestring (relativize entry (working-directory))))
+              (format t "~A~%"
+                      (namestring (relativize entry (working-directory)))))))))
   (values))


@@ -593,7 +603,7 @@ SEE:        MORE
 DO:         Same as more, but force no pagination.
 "
   (apply (function more) :page nil paths))
-
+

 (defvar *directory-stack* nil)

diff --git a/common-lisp/interactive/interactive.lisp b/common-lisp/interactive/interactive.lisp
index 18a5ffc..0a48245 100644
--- a/common-lisp/interactive/interactive.lisp
+++ b/common-lisp/interactive/interactive.lisp
@@ -328,29 +328,31 @@ dumping all the exported symbols when :SHOW-EXPORTS is specified,
 and not dumping the used-by list when :HIDE-USED-BY is specified.
 The keywords are tested with STRING-EQUAL."
   (let ((options '((:show-exports :exports :export :t)
-                   (:hide-used-by :short           :s))))
+                   (:hide-used-by :short           :s)
+                   (:very-short                    :ss))))
     (flet ((list-package (name options)
              (let* ((show-exports (not (not (member :show-exports options))))
                     (show-used-by (not (member :hide-used-by options)))
+                    (very-short   (intersection '(:very-short :ss) options))
                     (packlist
-                     (sort (cond
-                             ((null name)  (copy-list (list-all-packages)))
-                             ((stringp name)
-                              ;; remove-if-not may return the argument!
-                              (delete-if-not
-                               (lambda (pack)
-                                 (some (lambda (pname)
-                                         (string-match-p name pname))
-                                       (cons (package-name pack)
-                                             (package-nicknames pack))))
-                               (copy-list (list-all-packages))))
-                             (t (list (find-package name))))
-                           (function string<) :key (function package-name)))
+                      (sort (cond
+                              ((null name)  (copy-list (list-all-packages)))
+                              ((stringp name)
+                               ;; remove-if-not may return the argument!
+                               (delete-if-not
+                                (lambda (pack)
+                                  (some (lambda (pname)
+                                          (string-match-p name pname))
+                                        (cons (package-name pack)
+                                              (package-nicknames pack))))
+                                (copy-list (list-all-packages))))
+                              (t (list (find-package name))))
+                            (function string<) :key (function package-name)))
                     #+(or)(name-width
-                           (loop for p in packlist
-                              maximize (length (package-name p))))
+                            (loop for p in packlist
+                                  maximize (length (package-name p))))
                     (numb-width
-                     (loop
+                      (loop
                         :for p :in packlist
                         :maximize (truncate
                                    (1+ (log
@@ -358,18 +360,21 @@ The keywords are tested with STRING-EQUAL."
                                              (length (list-all-symbols p)) 3)
                                         10))))))
                ;; (print `(,name show-exports ,show-exports show-used-by ,show-used-by))
-               (dolist (package packlist)
-                 (format t "~%~A~%   ~14A ~VD exported, ~VD total.~%"
-                         (package-name package)
-                         "Symbols:"
-                         numb-width (length (list-external-symbols package))
-                         numb-width (length (list-all-symbols package)))
-                 (flow-list "Nicknames:" (package-nicknames package))
-                 (flow-list "Uses:"      (package-use-list package))
-                 (when show-used-by
-                   (flow-list "Used by:"   (package-used-by-list package)))
-                 (when show-exports
-                   (flow-list "Exported:" (list-external-symbols package))))
+               (if very-short
+                   (dolist (package packlist)
+                     (format t "~&~A~%" (package-name package)))
+                   (dolist (package packlist)
+                     (format t "~%~A~%   ~14A ~VD exported, ~VD total.~%"
+                             (package-name package)
+                             "Symbols:"
+                             numb-width (length (list-external-symbols package))
+                             numb-width (length (list-all-symbols package)))
+                     (flow-list "Nicknames:" (package-nicknames package))
+                     (flow-list "Uses:"      (package-use-list package))
+                     (when show-used-by
+                       (flow-list "Used by:"   (package-used-by-list package)))
+                     (when show-exports
+                       (flow-list "Exported:" (list-external-symbols package)))))
                (values)))
            (eat-options (arguments)
              "
diff --git a/tools/asdf-file.lisp b/tools/asdf-file.lisp
index 298a1c0..b50fe3e 100644
--- a/tools/asdf-file.lisp
+++ b/tools/asdf-file.lisp
@@ -11,13 +11,14 @@
 ;;;;AUTHORS
 ;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
 ;;;;MODIFICATIONS
+;;;;    2014-09-02 <PJB> Added generate-dot.
 ;;;;    2013-09-06 <PJB> Updated for publication.
 ;;;;    2012-04-09 <PJB> Created.
 ;;;;BUGS
 ;;;;LEGAL
 ;;;;    AGPL3
 ;;;;
-;;;;    Copyright Pascal J. Bourguignon 2012 - 2013
+;;;;    Copyright Pascal J. Bourguignon 2012 - 2014
 ;;;;
 ;;;;    This program is free software: you can redistribute it and/or modify
 ;;;;    it under the terms of the GNU Affero General Public License as published by
@@ -36,15 +37,20 @@
 (defpackage "COM.INFORMATIMAGO.TOOLS.ASDF-FILE"
   (:use "COMMON-LISP"
         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.UTILITY"
+        "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.LIST"
         "COM.INFORMATIMAGO.COMMON-LISP.CESARUM.GRAPH"
         "COM.INFORMATIMAGO.TOOLS.DEPENDENCY-CYCLES")
+  (:import-from "COM.INFORMATIMAGO.COMMON-LISP.SCRIPT"
+                "SHELL")
   (:export "LOAD-SIMPLE-ASD-FILE"

            "ASDF-FILE" "ASDF-FILE-P" "MAKE-ASDF-FILE" "COPY-ASDF-FILE"
            "ASDF-FILE-PATH" "ASDF-FILE-DEPENDS-ON" "ASDF-FILE-REACHABLE"

            "ADJACENCY-LIST" "REACHABLE-LIST"
-           "DEPENDENCIES")
+           "DEPENDENCIES"
+
+           "GENERATE-DOT" "DOT")
   (:documentation "

 Reads simple .asd files, without instanciating ASDF objects.
@@ -59,7 +65,7 @@ License:

     AGPL3

-    Copyright Pascal J. Bourguignon 2012 - 2013
+    Copyright Pascal J. Bourguignon 2012 - 2014

     This program is free software: you can redistribute it and/or modify
     it under the terms of the GNU Affero General Public License as published by
@@ -117,7 +123,7 @@ RETURN: A hash-table mapping file paths to ASDF-FILE structures.
           (maphash (lambda (path file)
                      (declare (ignore path))
                      (setf (asdf-file-reachable file)
-                           (compute-closure (function asdf-file-depends-on) (asdf-file-depends-on file))))
+                           (transitive-closure (function asdf-file-depends-on) (asdf-file-depends-on file))))
                    asdf-files)
           asdf-files)))

@@ -132,6 +138,73 @@ RETURN: A hash-table mapping file paths to ASDF-FILE structures.
 (defun dependencies  (p q) (member q (asdf-file-reachable p)))


+(defmethod generate-dot ((file asdf-file))
+  (let ((style     "filled")
+        (color     "black")
+        (fillcolor "LightYellow")
+        (label     (pathname-name (asdf-file-path file))))
+    (format nil "~S [ style=~A color=~A fillcolor=~A label=\"~A\" ];~%"
+            (pathname-name (asdf-file-path file)) style color fillcolor label)))
+
+(defmethod generate-dot ((edge cons))
+  (format nil "~S -> ~S [ weight=~D, style=~A, color=~A ];~%"
+          (pathname-name (asdf-file-path (car edge)))
+          (pathname-name (asdf-file-path (cdr edge)))
+          1
+          "solid" ; "dotted" "dashed" "bold"
+          "black"))
+
+(defmethod generate-dot ((path pathname))
+  "
+RETURN: A string containing the dot file data for this graph.
+"
+  (let ((files (load-simple-asd-file path)))
+    (with-output-to-string (*standard-output*)
+      (format t "digraph ~S~%" (pathname-name path))
+      (format t "{~%")
+      (format t "rankdir=~A;~%" "TB")
+      (format t "concentrate=~:[false~;true~];~%" t)
+      (mapc 'write-string '(
+                            "// attributes of graph:~%"
+                            "// page=8,11.4;    // page size (NeXTprinter:A4).~%"
+                            "// size=30,8;     // graph size (please edit to fit).~%"
+                            "// rotate=90;    // graph orientation (please edit to fit).~%"
+                            "// ratio=fill;  // fill the size (or compress, auto, aspect/ratio).~%"
+                            "nodesep=0.3;~%"
+                            "ranksep=0.3;~%"
+                            "center=1;~%"
+                            "// common attributes of NODES:~%"
+                            "node [height=0.2 width=0.5 shape=box fontsize=8 fontname=Times] ;~%"))
+      (maphash (lambda (key file)
+                 (declare (ignore key))
+                 (write-string (generate-dot file))) files)
+      (format t "// common attributes of edges:~%edge [style=solid];~%")
+      (maphash (lambda (key file)
+                 (declare (ignore key))
+                 (dolist (dependency (asdf-file-depends-on file))
+                   (write-string (generate-dot (cons file dependency)))))
+               files)
+      (format t "}~%"))))
+
+;; (COM.INFORMATIMAGO.TOOLS.ASDF-FILE:generate-dot #P"/Users/pjb/src/public/lisp/tools/com.informatimago.tools.check-asdf.asd")
+
+(defun dot (path)
+  (let ((path.dot (make-pathname :defaults path :type "dot"))
+        (path.pdf (make-pathname :defaults path :type "pdf")))
+    (with-open-file (dot path.dot
+                         :direction :output
+                         :if-does-not-exist :create
+                         :if-exists :supersede)
+      (write-string (generate-dot path) dot))
+    (shell "/opt/local/bin/dot -Tpdf -o ~S ~S"
+           (#+ccl ccl:native-translated-namestring #-ccl namestring path.pdf)
+           (#+ccl ccl:native-translated-namestring #-ccl namestring path.dot))
+    (shell "open ~S"
+           (#+ccl ccl:native-translated-namestring #-ccl namestring path.pdf))))
+
+;; (dot  #P"/Users/pjb/src/public/lisp/tools/com.informatimago.tools.check-asdf.asd")
+
+


 ;;;; THE END ;;;;
diff --git a/tools/com.informatimago.tools.asd b/tools/com.informatimago.tools.asd
index e8138fe..34c9660 100644
--- a/tools/com.informatimago.tools.asd
+++ b/tools/com.informatimago.tools.asd
@@ -49,7 +49,7 @@

   :name "Informatimago Common Lisp Tools Agregate"

-  :version "1.0.1"
+  :version "1.0.2"

   :properties ((#:author-email                   . "pjb@informatimago.com")
                (#:date                           . "Spring 2014")
@@ -61,12 +61,12 @@

   #+asdf-unicode :encoding #+asdf-unicode :utf-8

-  :depends-on ("com.informatimago.tools.check-asdf"
-               "com.informatimago.tools.make-depends"
-               "com.informatimago.tools.manifest"
-               "com.informatimago.tools.pathname"
-               "com.informatimago.tools.symbol"
-               "com.informatimago.tools.quicklisp"))
+  :defsystem-depends-on ("com.informatimago.tools.check-asdf"
+                         "com.informatimago.tools.make-depends"
+                         "com.informatimago.tools.manifest"
+                         "com.informatimago.tools.pathname"
+                         "com.informatimago.tools.symbol"
+                         "com.informatimago.tools.quicklisp"))



diff --git a/tools/com.informatimago.tools.check-asdf.asd b/tools/com.informatimago.tools.check-asdf.asd
index 6c2c43c..fe32e92 100644
--- a/tools/com.informatimago.tools.check-asdf.asd
+++ b/tools/com.informatimago.tools.check-asdf.asd
@@ -36,12 +36,13 @@
     :name "com.informatimago.check-asdf"
     :description "Checks ASD Files and reports circular dependencies."
     :author "Pascal J. Bourguignon"
-    :version "1.0.1"
+    :version "1.0.4"
     :license "GPL3"
     :depends-on ("com.informatimago.common-lisp.cesarum"
                  "com.informatimago.clext")
     :components ((:file "dependency-cycles")
-                 (:file "asdf-file"  :depends-on ("dependency-cycles"))
+                 (:file "asdf-file"  :depends-on ("dependency-cycles" "script"))
+                 (:file "script")
                  (:file "check-asdf" :depends-on ("dependency-cycles" "asdf-file"))))

 ;;;; THE END ;;;;
diff --git a/tools/script.lisp b/tools/script.lisp
index 7d3dfdf..bdc9cab 100644
--- a/tools/script.lisp
+++ b/tools/script.lisp
@@ -99,7 +99,8 @@ otherwise we fallback to *PROGRAM-NAME*.")
         (princ ,verror *error-output*)
         (terpri *error-output*)
         (terpri *error-output*)
-        #-testing-script (ext:exit 1)))))
+        #+(and clisp (not testing-script)) (ext:exit 1)
+        #+(and (not clisp) (not testing-script)) (error "Missing EXIT for ~A" (lisp-implementation-type))))))



diff --git a/tools/symbol.lisp b/tools/symbol.lisp
index d4ed395..f095c68 100644
--- a/tools/symbol.lisp
+++ b/tools/symbol.lisp
@@ -43,9 +43,16 @@ A tool to check duplicate/un-exported/imported symbols.
 (in-package "COM.INFORMATIMAGO.TOOLS.SYMBOL")


-(defun report-duplicates (symbols &optional (*standard-output* *standard-output*))
+(defun report-duplicates (duplicates &optional (*standard-output* *standard-output*))
   (let ((*package* (find-package "KEYWORD")))
-    (format t "~&~S~%" symbols)))
+    (dolist (symbols (sort duplicates
+                           (function string<)
+                           :key (lambda (syms) (symbol-name (first syms))))
+                     (values))
+      (format t "~20A ~{~A~^ ~}~%"
+              (symbol-name (first symbols))
+              (sort (mapcar (lambda (sym) (package-name (symbol-package sym))) symbols)
+                    (function string<))))))

 (defun duplicate-symbols (&key (packages (list-all-packages)) (exported nil))
   "Return: a list of list of symbols that have the same name."
@@ -70,10 +77,8 @@ A tool to check duplicate/un-exported/imported symbols.
         duplicates)))

 (defun check-duplicate-symbols (&key (packages (list-all-packages)) (exported nil))
-  (report-duplicates (duplicate-symbols :packages packages :exported exported))
-  (values))
+  (report-duplicates (duplicate-symbols :packages packages :exported exported)))



 ;;;; THE END ;;;;
-
ViewGit