From pbrochard at common-lisp.net  Sun Jun  3 13:06:47 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Sun, 03 Jun 2012 06:06:47 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-57-g4519205
Message-ID: <E1SbAW6-00073l-PF@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  45192056686a6053098c861562b757f944db5fd0 (commit)
      from  0ff435ca00f6ab1f2e434087dfa38048a1527808 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 45192056686a6053098c861562b757f944db5fd0
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Sun Jun 3 15:06:40 2012 +0200

    src/clfswm-placement.lisp: Add an optional border size in all placement functions.

diff --git a/ChangeLog b/ChangeLog
index 1cf1374..af5e2df 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-06-03  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* src/clfswm-placement.lisp: Add an optional border size in all
+	placement functions.
+
 2012-05-30  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* contrib/toolbar.lisp (clock): Add a clock module.
diff --git a/contrib/toolbar.lisp b/contrib/toolbar.lisp
index 17205b3..22b9464 100644
--- a/contrib/toolbar.lisp
+++ b/contrib/toolbar.lisp
@@ -32,24 +32,31 @@
 
 (format t "Loading Toolbar code... ")
 
-(defstruct toolbar root-x root-y root direction size thickness placement autohide modules font window gc)
+(defstruct toolbar root-x root-y root direction size thickness placement refresh-delay
+           autohide modules font window gc border-size)
 
 (defparameter *toolbar-list* nil)
 (defparameter *toolbar-module-list* nil)
 
 ;;; CONFIG - Toolbar window string colors
 (defconfig *toolbar-window-font-string* *default-font-string*
-  'Toolbar-Window "Toolbar window font string")
+  'Toolbar "Toolbar window font string")
 (defconfig *toolbar-window-background* "black"
-  'Toolbar-Window "Toolbar Window background color")
+  'Toolbar "Toolbar Window background color")
 (defconfig *toolbar-window-foreground* "green"
-  'Toolbar-Window "Toolbar Window foreground color")
+  'Toolbar "Toolbar Window foreground color")
 (defconfig *toolbar-window-border* "red"
-  'Toolbar-Window "Toolbar Window border color")
+  'Toolbar "Toolbar Window border color")
+(defconfig *toolbar-default-border-size* 0
+  'Toolbar "Toolbar Window border size")
 (defconfig *toolbar-window-transparency* *default-transparency*
-  'Toolbar-window "Toolbar window background transparency")
+  'Toolbar "Toolbar window background transparency")
 (defconfig *toolbar-default-thickness* 20
-  'toolbar-window "Toolbar default thickness")
+  'Toolbar "Toolbar default thickness")
+(defconfig *toolbar-default-refresh-delay* 30
+  'Toolbar "Toolbar default refresh delay")
+(defconfig *toolbar-default-autohide* nil
+  'Toolbar "Toolbar default autohide value")
 
 (defconfig *toolbar-window-placement* 'top-left-placement
   'Placement "Toolbar window placement")
@@ -61,7 +68,7 @@
   (unless (toolbar-autohide toolbar)
     (let ((root (toolbar-root toolbar))
           (placement-name (symbol-name (toolbar-placement toolbar)))
-          (thickness (+ (toolbar-thickness toolbar) (* 2 *border-size*))))
+          (thickness (+ (toolbar-thickness toolbar) (* 2 (toolbar-border-size toolbar)))))
       (when (root-p root)
         (case (toolbar-direction toolbar)
           (:horiz (cond ((search "TOP" placement-name)
@@ -106,13 +113,11 @@
     (and (xlib:window-p win) (member win windows-list :test 'xlib:window-equal)))
 
   (defun refresh-toolbar (toolbar)
-    (add-timer 1 (lambda ()
-                   (refresh-toolbar toolbar))
+    (add-timer (toolbar-refresh-delay toolbar)
+               (lambda ()
+                 (refresh-toolbar toolbar))
                :refresh-toolbar)
     (clear-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar))
-;;    (toolbar-draw-text toolbar 0 (/ *toolbar-default-thickness* 2) "This is a test!!! abcpdj")
-;;    (toolbar-draw-text toolbar 100 (/ *toolbar-default-thickness* 2) "This ijTjjs a test!!! abcpdj")
-    ;;    (dbg (toolbar-modules toolbar))
     (dolist (module (toolbar-modules toolbar))
       (let ((fun (toolbar-symbol-fun (first module))))
         (when (fboundp fun)
@@ -147,15 +152,16 @@
                  (height (if (equal (toolbar-direction toolbar) :horiz)
                              (toolbar-thickness toolbar)
                              (round (/ (* (root-h root) (toolbar-size toolbar)) 100)))))
-            (with-placement ((toolbar-placement toolbar) x y width height)
+            (with-placement ((toolbar-placement toolbar) x y width height (toolbar-border-size toolbar))
               (setf (toolbar-window toolbar) (xlib:create-window :parent *root*
                                                                  :x x
                                                                  :y y
                                                                  :width width
                                                                  :height height
                                                                  :background (get-color *toolbar-window-background*)
-                                                                 :border-width 0
-                                                                 :border (get-color *toolbar-window-border*)
+                                                                 :border-width (toolbar-border-size toolbar)
+                                                                 :border (when (plusp (toolbar-border-size toolbar))
+                                                                           (get-color *toolbar-window-border*))
                                                                  :colormap (xlib:screen-default-colormap *screen*)
                                                                  :event-mask '(:exposure :key-press))
                     (toolbar-gc toolbar) (xlib:create-gcontext :drawable (toolbar-window toolbar)
@@ -183,7 +189,7 @@
     (close-toolbar toolbar)))
 
 
-(defun add-toolbar (root-x root-y direction size placement autohide &rest modules)
+(defun add-toolbar (root-x root-y direction size placement &rest modules)
   "Add a new toolbar.
      root-x, root-y: root coordinates
      direction: one of :horiz or :vert
@@ -192,7 +198,9 @@
                       :direction direction :size size
                       :thickness *toolbar-default-thickness*
                       :placement placement
-                      :autohide autohide
+                      :autohide *toolbar-default-autohide*
+                      :refresh-delay *toolbar-default-refresh-delay*
+                      :border-size *toolbar-default-border-size*
                       :modules modules)))
     (push toolbar *toolbar-list*)
     toolbar))
diff --git a/contrib/volume-mode.lisp b/contrib/volume-mode.lisp
index 752663c..5809f26 100644
--- a/contrib/volume-mode.lisp
+++ b/contrib/volume-mode.lisp
@@ -85,13 +85,15 @@
 
 ;;; CONFIG - Volume mode
 (defconfig *volume-font-string* *default-font-string*
-  'Volume-mode "Volume string window font string")
+  'Volume-mode "Volume window font string")
 (defconfig *volume-background* "black"
-  'Volume-mode "Volume string window background color")
+  'Volume-mode "Volume window background color")
 (defconfig *volume-foreground* "green"
-  'Volume-mode "Volume string window foreground color")
+  'Volume-mode "Volume window foreground color")
 (defconfig *volume-border* "red"
-  'Volume-mode "Volume string window border color")
+  'Volume-mode "Volume window border color")
+(defconfig *volume-border-size* 1
+  'Volume-mode "Volume window border size")
 (defconfig *volume-width* 400
   'Volume-mode "Volume mode window width")
 (defconfig *volume-height* 15
@@ -174,7 +176,7 @@
          (erase-timer :volume-mode-timer))))
 
 (defun volume-enter-function ()
-  (with-placement (*volume-mode-placement* x y *volume-width* *volume-height*)
+  (with-placement (*volume-mode-placement* x y *volume-width* *volume-height* *volume-border-size*)
     (setf *volume-font* (xlib:open-font *display* *volume-font-string*)
           *volume-window* (xlib:create-window :parent *root*
                                               :x x
@@ -182,8 +184,9 @@
                                               :width *volume-width*
                                               :height *volume-height*
                                               :background (get-color *volume-background*)
-                                              :border-width 1
-                                              :border (get-color *volume-border*)
+                                              :border-width *volume-border-size*
+                                              :border (when (plusp *volume-border-size*)
+                                                        (get-color *volume-border*))
                                               :colormap (xlib:screen-default-colormap *screen*)
                                               :event-mask '(:exposure :key-press))
           *volume-gc* (xlib:create-gcontext :drawable *volume-window*
diff --git a/src/clfswm-placement.lisp b/src/clfswm-placement.lisp
index e04ac20..d7e3d01 100644
--- a/src/clfswm-placement.lisp
+++ b/src/clfswm-placement.lisp
@@ -25,19 +25,19 @@
 
 (in-package :clfswm)
 
-(defun get-placement-values (placement &optional (width 0) (height 0))
+(defun get-placement-values (placement &optional (width 0) (height 0) (border-size *border-size*))
   (typecase placement
     (list (values-list placement))
-    (function (funcall placement width height))
+    (function (funcall placement width height border-size))
     (symbol
      (if (fboundp placement)
-	 (funcall placement width height)
+	 (funcall placement width height border-size)
 	 (values 0 0 width height)))
     (t (values 0 0 width height))))
 
-(defmacro with-placement ((placement x y &optional (width 0) (height 0)) &body body)
+(defmacro with-placement ((placement x y &optional (width 0) (height 0) (border-size *border-size*)) &body body)
   `(multiple-value-bind (,x ,y width height)
-       (get-placement-values ,placement ,width ,height)
+       (get-placement-values ,placement ,width ,height ,border-size)
      (declare (ignorable width height))
      , at body))
 
@@ -58,50 +58,54 @@
 ;;;
 ;;; Absolute placement
 ;;;
-(defun top-left-placement (&optional (width 0) (height 0))
+(defun top-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (values 0 0 width height))
 
-(defun top-middle-placement (&optional (width 0) (height 0))
+(defun top-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
 	  0
           width height))
 
-(defun top-right-placement (&optional (width 0) (height 0))
-  (values (- (xlib:screen-width *screen*) width (* *border-size* 2))
+(defun top-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (values (- (xlib:screen-width *screen*) width (* border-size 2))
 	  0
           width height))
 
 
 
-(defun middle-left-placement (&optional (width 0) (height 0))
+(defun middle-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (values 0
 	  (truncate (/ (- (xlib:screen-height *screen*) height) 2))
           width height))
 
-(defun middle-middle-placement (&optional (width 0) (height 0))
+(defun middle-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
 	  (truncate (/ (- (xlib:screen-height *screen*) height) 2))
           width height))
 
-(defun middle-right-placement (&optional (width 0) (height 0))
-  (values (- (xlib:screen-width *screen*) width (* *border-size* 2))
+(defun middle-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (values (- (xlib:screen-width *screen*) width (* border-size 2))
 	  (truncate (/ (- (xlib:screen-height *screen*) height) 2))
           width height))
 
 
-(defun bottom-left-placement (&optional (width 0) (height 0))
+(defun bottom-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (values 0
-	  (- (xlib:screen-height *screen*) height (* *border-size* 2))
+	  (- (xlib:screen-height *screen*) height (* border-size 2))
           width height))
 
-(defun bottom-middle-placement (&optional (width 0) (height 0))
+(defun bottom-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
-	  (- (xlib:screen-height *screen*) height (* *border-size* 2))
+	  (- (xlib:screen-height *screen*) height (* border-size 2))
           width height))
 
-(defun bottom-right-placement (&optional (width 0) (height 0))
-  (values (- (xlib:screen-width *screen*) width (* *border-size* 2))
-	  (- (xlib:screen-height *screen*) height (* *border-size* 2))
+(defun bottom-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (values (- (xlib:screen-width *screen*) width (* border-size 2))
+	  (- (xlib:screen-height *screen*) height (* border-size 2))
           width height))
 
 
@@ -126,7 +130,8 @@
      , at body))
 
 
-(defun top-left-child-placement (&optional (width 0) (height 0))
+(defun top-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (with-current-child-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
@@ -134,7 +139,8 @@
               (+ y 2)
               width height))))
 
-(defun top-middle-child-placement (&optional (width 0) (height 0))
+(defun top-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (with-current-child-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
@@ -142,7 +148,8 @@
               (+ y 2)
               width height))))
 
-(defun top-right-child-placement (&optional (width 0) (height 0))
+(defun top-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (with-current-child-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
@@ -152,7 +159,8 @@
 
 
 
-(defun middle-left-child-placement (&optional (width 0) (height 0))
+(defun middle-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (with-current-child-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
@@ -160,7 +168,8 @@
               (+ y (truncate (/ (- h height) 2)))
               width height))))
 
-(defun middle-middle-child-placement (&optional (width 0) (height 0))
+(defun middle-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (with-current-child-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
@@ -168,7 +177,8 @@
               (+ y (truncate (/ (- h height) 2)))
               width height))))
 
-(defun middle-right-child-placement (&optional (width 0) (height 0))
+(defun middle-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (with-current-child-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
@@ -177,7 +187,8 @@
               width height))))
 
 
-(defun bottom-left-child-placement (&optional (width 0) (height 0))
+(defun bottom-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (with-current-child-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
@@ -185,7 +196,8 @@
               (+ y (- h height 2))
               width height))))
 
-(defun bottom-middle-child-placement (&optional (width 0) (height 0))
+(defun bottom-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (with-current-child-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
@@ -193,7 +205,8 @@
               (+ y (- h height 2))
               width height))))
 
-(defun bottom-right-child-placement (&optional (width 0) (height 0))
+(defun bottom-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (with-current-child-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
@@ -222,41 +235,42 @@
      , at body))
 
 
-(defun top-left-root-placement (&optional (width 0) (height 0))
+(defun top-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x 2)
-              (+ y 2)
+      (values (+ x border-size 1)
+              (+ y border-size 1)
               width height))))
 
-(defun top-middle-root-placement (&optional (width 0) (height 0))
+(defun top-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
       (values (+ x (truncate (/ (- w width) 2)))
-              (+ y 2)
+              (+ y border-size 1)
               width height))))
 
-(defun top-right-root-placement (&optional (width 0) (height 0))
+(defun top-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x (- w width 2))
-              (+ y 2)
+      (values (+ x (- w width border-size 1))
+              (+ y border-size 1)
               width height))))
 
 
 
-(defun middle-left-root-placement (&optional (width 0) (height 0))
+(defun middle-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x 2)
+      (values (+ x border-size 1)
               (+ y (truncate (/ (- h height) 2)))
               width height))))
 
-(defun middle-middle-root-placement (&optional (width 0) (height 0))
+(defun middle-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
+  (declare (ignore border-size))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
@@ -264,36 +278,36 @@
 	    (+ y (truncate (/ (- h height) 2)))
             width height))))
 
-(defun middle-right-root-placement (&optional (width 0) (height 0))
+(defun middle-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x (- w width 2))
+      (values (+ x (- w width border-size 1))
               (+ y (truncate (/ (- h height) 2)))
               width height))))
 
 
-(defun bottom-left-root-placement (&optional (width 0) (height 0))
+(defun bottom-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x 2)
-              (+ y (- h height 2))
+      (values (+ x border-size 1)
+              (+ y (- h height border-size 1))
               width height))))
 
-(defun bottom-middle-root-placement (&optional (width 0) (height 0))
+(defun bottom-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
       (values (+ x (truncate (/ (- w width) 2)))
-              (+ y (- h height 2))
+              (+ y (- h height border-size 1))
               width height))))
 
-(defun bottom-right-root-placement (&optional (width 0) (height 0))
+(defun bottom-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x (- w width 2))
-              (+ y (- h height 2))
+      (values (+ x (- w width border-size 1))
+              (+ y (- h height border-size 1))
               width height))))
 

-----------------------------------------------------------------------

Summary of changes:
 ChangeLog                 |    5 ++
 contrib/toolbar.lisp      |   44 ++++++++++-------
 contrib/volume-mode.lisp  |   17 ++++---
 src/clfswm-placement.lisp |  114 +++++++++++++++++++++++++--------------------
 4 files changed, 105 insertions(+), 75 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Sun Jun  3 20:18:11 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Sun, 03 Jun 2012 13:18:11 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-58-g1e5611e
Message-ID: <E1SbHFb-0000QL-7K@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  1e5611e4818034b5dc32938ea5a4675e96d2d20f (commit)
      from  45192056686a6053098c861562b757f944db5fd0 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 1e5611e4818034b5dc32938ea5a4675e96d2d20f
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Sun Jun 3 22:18:04 2012 +0200

    Switch to asdf2 in contrib directory

diff --git a/contrib/asdf.lisp b/contrib/asdf.lisp
index 1518e38..a69fe3c 100644
--- a/contrib/asdf.lisp
+++ b/contrib/asdf.lisp
@@ -1,5 +1,5 @@
-;;; -*- mode: common-lisp; package: asdf; -*-
-;;; This is ASDF: Another System Definition Facility.
+;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; This is ASDF 2.20: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel at common-lisp.net>.
@@ -10,16 +10,16 @@
 ;;; trouble using it, or find bugs, you may want to check at the
 ;;; location above for a more recent version (and for documentation
 ;;; and test files, if your copy came without them) before reporting
-;;; bugs.  There are usually two "supported" revisions - the git HEAD
-;;; is the latest development version, whereas the revision tagged
-;;; RELEASE may be slightly older but is considered `stable'
+;;; bugs.  There are usually two "supported" revisions - the git master
+;;; branch is the latest development version, whereas the git release
+;;; branch may be slightly older but is considered `stable'
 
 ;;; -- LICENSE START
 ;;; (This is the MIT / X Consortium license as taken from
 ;;;  http://www.opensource.org/licenses/mit-license.html on or about
 ;;;  Monday; July 13, 2009)
 ;;;
-;;; Copyright (c) 2001-2010 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
 ;;;
 ;;; Permission is hereby granted, free of charge, to any person obtaining
 ;;; a copy of this software and associated documentation files (the
@@ -47,46 +47,89 @@
 
 #+xcvb (module ())
 
-(cl:in-package :cl-user)
+(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
+
+#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
+(error "ASDF is not supported on your implementation. Please help us port it.")
+
+#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
 
 (eval-when (:compile-toplevel :load-toplevel :execute)
-  ;;; make package if it doesn't exist yet.
-  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
-  (unless (find-package :asdf)
-    (make-package :asdf :use '(:cl)))
   ;;; Implementation-dependent tweaks
-  ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
+  ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
   #+allegro
   (setf excl::*autoload-package-name-alist*
         (remove "asdf" excl::*autoload-package-name-alist*
-                :test 'equalp :key 'car))
-  #+ecl (require :cmp))
+                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
+  #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
+  #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
+  #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
+  (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
+            (and (= system::*gcl-major-version* 2)
+                 (< system::*gcl-minor-version* 7)))
+    (pushnew :gcl-pre2.7 *features*))
+  ;;; make package if it doesn't exist yet.
+  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
+  (unless (find-package :asdf)
+    (make-package :asdf :use '(:common-lisp))))
 
 (in-package :asdf)
 
 ;;;; Create packages in a way that is compatible with hot-upgrade.
 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;; See more at the end of the file.
+;;;; See more near the end of the file.
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
   (defvar *asdf-version* nil)
   (defvar *upgraded-p* nil)
-  (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
-          (subseq "VERSION:2.131" (1+ (length "VERSION"))))
-         (existing-asdf (fboundp 'find-system))
+  (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
+  (defun find-symbol* (s p)
+    (find-symbol (string s) p))
+  ;; Strip out formatting that is not supported on Genera.
+  ;; Has to be inside the eval-when to make Lispworks happy (!)
+  (defun strcat (&rest strings)
+    (apply 'concatenate 'string strings))
+  (defmacro compatfmt (format)
+    #-(or gcl genera) format
+    #+(or gcl genera)
+    (loop :for (unsupported . replacement) :in
+      (append
+       '(("~3i~_" . ""))
+       #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
+      (loop :for found = (search unsupported format) :while found :do
+        (setf format (strcat (subseq format 0 found) replacement
+                             (subseq format (+ found (length unsupported)))))))
+    format)
+  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
+         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
+         ;; can help you do these changes in synch (look at the source for documentation).
+         ;; Relying on its automation, the version is now redundantly present on top of this file.
+         ;; "2.345" would be an official release
+         ;; "2.345.6" would be a development version in the official upstream
+         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
+         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
+         (asdf-version "2.20")
+         (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
     (unless (and existing-asdf already-there)
-      (when existing-asdf
+      (when (and existing-asdf *asdf-verbose*)
         (format *trace-output*
-                "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%"
+                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
                 existing-version asdf-version))
       (labels
-          ((unlink-package (package)
+          ((present-symbol-p (symbol package)
+             (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
+           (present-symbols (package)
+             ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
+             (let (l)
+               (do-symbols (s package)
+                 (when (present-symbol-p s package) (push s l)))
+               (reverse l)))
+           (unlink-package (package)
              (let ((u (find-package package)))
                (when u
-                 (ensure-unintern u
-                   (loop :for s :being :each :present-symbol :in u :collect s))
+                 (ensure-unintern u (present-symbols u))
                  (loop :for p :in (package-used-by-list u) :do
                    (unuse-package u p))
                  (delete-package u))))
@@ -106,14 +149,12 @@
                     p)
                    (t
                     (make-package name :nicknames nicknames :use use))))))
-           (find-sym (symbol package)
-             (find-symbol (string symbol) package))
            (intern* (symbol package)
              (intern (string symbol) package))
            (remove-symbol (symbol package)
-             (let ((sym (find-sym symbol package)))
+             (let ((sym (find-symbol* symbol package)))
                (when sym
-                 (unexport sym package)
+                 #-cormanlisp (unexport sym package)
                  (unintern sym package)
                  sym)))
            (ensure-unintern (package symbols)
@@ -122,87 +163,88 @@
                :for removed = (remove-symbol sym package)
                :when removed :do
                (loop :for p :in packages :do
-                 (when (eq removed (find-sym sym p))
+                 (when (eq removed (find-symbol* sym p))
                    (unintern removed p)))))
            (ensure-shadow (package symbols)
              (shadow symbols package))
            (ensure-use (package use)
              (dolist (used (reverse use))
                (do-external-symbols (sym used)
-                 (unless (eq sym (find-sym sym package))
+                 (unless (eq sym (find-symbol* sym package))
                    (remove-symbol sym package)))
                (use-package used package)))
            (ensure-fmakunbound (package symbols)
              (loop :for name :in symbols
-               :for sym = (find-sym name package)
+               :for sym = (find-symbol* name package)
                :when sym :do (fmakunbound sym)))
            (ensure-export (package export)
              (let ((formerly-exported-symbols nil)
                    (bothly-exported-symbols nil)
                    (newly-exported-symbols nil))
-               (loop :for sym :being :each :external-symbol :in package :do
+               (do-external-symbols (sym package)
                  (if (member sym export :test 'string-equal)
                      (push sym bothly-exported-symbols)
                      (push sym formerly-exported-symbols)))
                (loop :for sym :in export :do
-                 (unless (member sym bothly-exported-symbols :test 'string-equal)
+                 (unless (member sym bothly-exported-symbols :test 'equal)
                    (push sym newly-exported-symbols)))
                (loop :for user :in (package-used-by-list package)
                  :for shadowing = (package-shadowing-symbols user) :do
                  (loop :for new :in newly-exported-symbols
-                   :for old = (find-sym new user)
+                   :for old = (find-symbol* new user)
                    :when (and old (not (member old shadowing)))
                    :do (unintern old user)))
                (loop :for x :in newly-exported-symbols :do
                  (export (intern* x package)))))
-           (ensure-package (name &key nicknames use unintern fmakunbound shadow export)
+           (ensure-package (name &key nicknames use unintern
+                                 shadow export redefined-functions)
              (let* ((p (ensure-exists name nicknames use)))
                (ensure-unintern p unintern)
                (ensure-shadow p shadow)
                (ensure-export p export)
-               (ensure-fmakunbound p fmakunbound)
+               (ensure-fmakunbound p redefined-functions)
                p)))
         (macrolet
             ((pkgdcl (name &key nicknames use export
-                           redefined-functions unintern fmakunbound shadow)
+                           redefined-functions unintern shadow)
                  `(ensure-package
                    ',name :nicknames ',nicknames :use ',use :export ',export
                    :shadow ',shadow
-                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
-                   :fmakunbound ',(append fmakunbound))))
-          (unlink-package :asdf-utilities)
+                   :unintern ',unintern
+                   :redefined-functions ',redefined-functions)))
           (pkgdcl
            :asdf
+           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
            :use (:common-lisp)
            :redefined-functions
            (#:perform #:explain #:output-files #:operation-done-p
             #:perform-with-restarts #:component-relative-pathname
             #:system-source-file #:operate #:find-component #:find-system
-            #:apply-output-translations #:translate-pathname*)
+            #:apply-output-translations #:translate-pathname* #:resolve-location
+            #:system-relative-pathname
+            #:inherit-source-registry #:process-source-registry
+            #:process-source-registry-directive
+            #:compile-file* #:source-file-type)
            :unintern
            (#:*asdf-revision* #:around #:asdf-method-combination
-            #:split #:make-collector)
-           :fmakunbound
-           (#:system-source-file
-            #:component-relative-pathname #:system-relative-pathname
-            #:process-source-registry
-            #:inherit-source-registry #:process-source-registry-directive)
+            #:split #:make-collector #:do-dep #:do-one-dep
+            #:resolve-relative-location-component #:resolve-absolute-location-component
+            #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
            :export
-           (#:defsystem #:oos #:operate #:find-system #:run-shell-command
-            #:system-definition-pathname #:find-component ; miscellaneous
-            #:compile-system #:load-system #:test-system #:clear-system
-            #:compile-op #:load-op #:load-source-op
-            #:test-op
-            #:operation               ; operations
-            #:feature                 ; sort-of operation
-            #:version                 ; metaphorically sort-of an operation
-            #:version-satisfies
-
-            #:input-files #:output-files #:output-file #:perform ; operation methods
+           (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
+            #:system-definition-pathname #:with-system-definitions
+            #:search-for-system-definition #:find-component #:component-find-path
+            #:compile-system #:load-system #:load-systems #:test-system #:clear-system
+            #:operation #:compile-op #:load-op #:load-source-op #:test-op
+            #:feature #:version #:version-satisfies
+            #:upgrade-asdf
+            #:implementation-identifier #:implementation-type
+            #:input-files #:output-files #:output-file #:perform
             #:operation-done-p #:explain
 
             #:component #:source-file
             #:c-source-file #:cl-source-file #:java-source-file
+            #:cl-source-file.cl #:cl-source-file.lsp
             #:static-file
             #:doc-file
             #:html-file
@@ -235,6 +277,7 @@
             #:system-relative-pathname
             #:map-systems
 
+            #:operation-description
             #:operation-on-warnings
             #:operation-on-failure
             #:component-visited-p
@@ -244,7 +287,9 @@
             #:*compile-file-warnings-behaviour*
             #:*compile-file-failure-behaviour*
             #:*resolve-symlinks*
+            #:*require-asdf-operator*
             #:*asdf-verbose*
+            #:*verbose-out*
 
             #:asdf-version
 
@@ -268,6 +313,7 @@
             #:remove-entry-from-registry
 
             #:clear-configuration
+            #:*output-translations-parameter*
             #:initialize-output-translations
             #:disable-output-translations
             #:clear-output-translations
@@ -277,6 +323,7 @@
             #:compile-file-pathname*
             #:enable-asdf-binary-locations-compatibility
             #:*default-source-registries*
+            #:*source-registry-parameter*
             #:initialize-source-registry
             #:compute-source-registry
             #:clear-source-registry
@@ -284,61 +331,47 @@
             #:process-source-registry
             #:system-registered-p
             #:asdf-message
+            #:user-output-translations-pathname
+            #:system-output-translations-pathname
+            #:user-output-translations-directory-pathname
+            #:system-output-translations-directory-pathname
+            #:user-source-registry
+            #:system-source-registry
+            #:user-source-registry-directory
+            #:system-source-registry-directory
 
             ;; Utilities
             #:absolute-pathname-p
-	    ;; #:aif #:it
-            ;; #:appendf
+            ;; #:aif #:it
+            ;; #:appendf #:orf
             #:coerce-name
             #:directory-pathname-p
             ;; #:ends-with
             #:ensure-directory-pathname
             #:getenv
-            ;; #:get-uid
             ;; #:length=n-p
-            #:merge-pathnames*
+            ;; #:find-symbol*
+            #:merge-pathnames* #:coerce-pathname #:subpathname
             #:pathname-directory-pathname
             #:read-file-forms
-	    ;; #:remove-keys
-	    ;; #:remove-keyword
+            ;; #:remove-keys
+            ;; #:remove-keyword
             #:resolve-symlinks
             #:split-string
             #:component-name-to-pathname-components
             #:split-name-type
+            #:subdirectories
             #:truenamize
             #:while-collecting)))
+        #+genera (import 'scl:boolean :asdf)
         (setf *asdf-version* asdf-version
               *upgraded-p* (if existing-version
                                (cons existing-version *upgraded-p*)
                                *upgraded-p*))))))
 
-;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
-(when *upgraded-p*
-   #+ecl
-   (when (find-class 'compile-op nil)
-     (defmethod update-instance-for-redefined-class :after
-         ((c compile-op) added deleted plist &key)
-       (declare (ignore added deleted))
-       (let ((system-p (getf plist 'system-p)))
-         (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p)))))
-   (when (find-class 'module nil)
-     (eval
-      '(defmethod update-instance-for-redefined-class :after
-           ((m module) added deleted plist &key)
-         (declare (ignorable deleted plist))
-         (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m))
-         (when (member 'components-by-name added)
-           (compute-module-components-by-name m))))))
-
 ;;;; -------------------------------------------------------------------------
 ;;;; User-visible parameters
 ;;;;
-(defun asdf-version ()
-  "Exported interface to the version of ASDF currently installed. A string.
-You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.000\")."
-  *asdf-version*)
-
 (defvar *resolve-symlinks* t
   "Determine whether or not ASDF resolves symlinks when defining systems.
 
@@ -357,8 +390,6 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
 
 (defvar *verbose-out* nil)
 
-(defvar *asdf-verbose* t)
-
 (defparameter +asdf-methods+
   '(perform-with-restarts perform explain output-files operation-done-p))
 
@@ -371,125 +402,66 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when
     (setf excl:*warn-on-nested-reader-conditionals* nil)))
 
 ;;;; -------------------------------------------------------------------------
-;;;; ASDF Interface, in terms of generic functions.
+;;;; Resolve forward references
+
+(declaim (ftype (function (t) t)
+                format-arguments format-control
+                error-name error-pathname error-condition
+                duplicate-names-name
+                error-component error-operation
+                module-components module-components-by-name
+                circular-dependency-components
+                condition-arguments condition-form
+                condition-format condition-location
+                coerce-name)
+         (ftype (function (&optional t) (values)) initialize-source-registry)
+         #-(or cormanlisp gcl-pre2.7)
+         (ftype (function (t t) t) (setf module-components-by-name)))
+
+;;;; -------------------------------------------------------------------------
+;;;; Compatibility various implementations
+#+cormanlisp
+(progn
+  (deftype logical-pathname () nil)
+  (defun make-broadcast-stream () *error-output*)
+  (defun file-namestring (p)
+    (setf p (pathname p))
+    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
+
+#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
+      (read-from-string
+       "(eval-when (:compile-toplevel :load-toplevel :execute)
+          (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
+          (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
+          ;; Note: ASDF may expect user-homedir-pathname to provide
+          ;; the pathname of the current user's home directory, whereas
+          ;; MCL by default provides the directory from which MCL was started.
+          ;; See http://code.google.com/p/mcl/wiki/Portability
+          (defun current-user-homedir-pathname ()
+            (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
+          (defun probe-posix (posix-namestring)
+            \"If a file exists for the posix namestring, return the pathname\"
+            (ccl::with-cstrs ((cpath posix-namestring))
+              (ccl::rlet ((is-dir :boolean)
+                          (fsref :fsref))
+                (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
+                  (ccl::%path-from-fsref fsref is-dir))))))"))
+
+;;;; -------------------------------------------------------------------------
+;;;; General Purpose Utilities
+
 (macrolet
     ((defdef (def* def)
        `(defmacro ,def* (name formals &rest rest)
           `(progn
-             #+(or ecl gcl) (fmakunbound ',name)
-             ,(when (and #+ecl (symbolp name))
-                `(declaim (notinline ,name))) ; fails for setf functions on ecl
+             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
+             #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
+             ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
+                `(declaim (notinline ,name)))
              (,',def ,name ,formals , at rest)))))
   (defdef defgeneric* defgeneric)
   (defdef defun* defun))
 
-(defgeneric* find-system (system &optional error-p))
-(defgeneric* perform-with-restarts (operation component))
-(defgeneric* perform (operation component))
-(defgeneric* operation-done-p (operation component))
-(defgeneric* explain (operation component))
-(defgeneric* output-files (operation component))
-(defgeneric* input-files (operation component))
-(defgeneric* component-operation-time (operation component))
-(defgeneric* operation-description (operation component)
-  (:documentation "returns a phrase that describes performing this operation
-on this component, e.g. \"loading /a/b/c\".
-You can put together sentences using this phrase."))
-
-(defgeneric* system-source-file (system)
-  (:documentation "Return the source file in which system is defined."))
-
-(defgeneric* component-system (component)
-  (:documentation "Find the top-level system containing COMPONENT"))
-
-(defgeneric* component-pathname (component)
-  (:documentation "Extracts the pathname applicable for a particular component."))
-
-(defgeneric* component-relative-pathname (component)
-  (:documentation "Returns a pathname for the component argument intended to be
-interpreted relative to the pathname of that component's parent.
-Despite the function's name, the return value may be an absolute
-pathname, because an absolute pathname may be interpreted relative to
-another pathname in a degenerate way."))
-
-(defgeneric* component-property (component property))
-
-(defgeneric* (setf component-property) (new-value component property))
-
-(defgeneric* version-satisfies (component version))
-
-(defgeneric* find-component (base path)
-  (:documentation "Finds the component with PATH starting from BASE module;
-if BASE is nil, then the component is assumed to be a system."))
-
-(defgeneric* source-file-type (component system))
-
-(defgeneric* operation-ancestor (operation)
-  (:documentation
-   "Recursively chase the operation's parent pointer until we get to
-the head of the tree"))
-
-(defgeneric* component-visited-p (operation component)
-  (:documentation "Returns the value stored by a call to
-VISIT-COMPONENT, if that has been called, otherwise NIL.
-This value stored will be a cons cell, the first element
-of which is a computed key, so not interesting.  The
-CDR wil be the DATA value stored by VISIT-COMPONENT; recover
-it as (cdr (component-visited-p op c)).
-  In the current form of ASDF, the DATA value retrieved is
-effectively a boolean, indicating whether some operations are
-to be performed in order to do OPERATION X COMPONENT.  If the
-data value is NIL, the combination had been explored, but no
-operations needed to be performed."))
-
-(defgeneric* visit-component (operation component data)
-  (:documentation "Record DATA as being associated with OPERATION
-and COMPONENT.  This is a side-effecting function:  the association
-will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
-OPERATION\).
-  No evidence that DATA is ever interesting, beyond just being
-non-NIL.  Using the data field is probably very risky; if there is
-already a record for OPERATION X COMPONENT, DATA will be quietly
-discarded instead of recorded.
-  Starting with 2.006, TRAVERSE will store an integer in data,
-so that nodes can be sorted in decreasing order of traversal."))
-
-
-(defgeneric* (setf visiting-component) (new-value operation component))
-
-(defgeneric* component-visiting-p (operation component))
-
-(defgeneric* component-depends-on (operation component)
-  (:documentation
-   "Returns a list of dependencies needed by the component to perform
-    the operation.  A dependency has one of the following forms:
-
-      (<operation> <component>*), where <operation> is a class
-        designator and each <component> is a component
-        designator, which means that the component depends on
-        <operation> having been performed on each <component>; or
-
-      (FEATURE <feature>), which means that the component depends
-        on <feature>'s presence in *FEATURES*.
-
-    Methods specialized on subclasses of existing component types
-    should usually append the results of CALL-NEXT-METHOD to the
-    list."))
-
-(defgeneric* component-self-dependencies (operation component))
-
-(defgeneric* traverse (operation component)
-  (:documentation
-"Generate and return a plan for performing OPERATION on COMPONENT.
-
-The plan returned is a list of dotted-pairs. Each pair is the CONS
-of ASDF operation object and a COMPONENT object. The pairs will be
-processed in order by OPERATE."))
-
-
-;;;; -------------------------------------------------------------------------
-;;;; General Purpose Utilities
-
 (defmacro while-collecting ((&rest collectors) &body body)
   "COLLECTORS should be a list of names for collections.  A collector
 defines a function that, when applied to an argument inside BODY, will
@@ -517,54 +489,90 @@ and NIL NAME, TYPE and VERSION components"
   (when pathname
     (make-pathname :name nil :type nil :version nil :defaults pathname)))
 
+(defun* normalize-pathname-directory-component (directory)
+  (cond
+    #-(or cmu sbcl scl)
+    ((stringp directory) `(:absolute ,directory) directory)
+    #+gcl
+    ((and (consp directory) (stringp (first directory)))
+     `(:absolute , at directory))
+    ((or (null directory)
+         (and (consp directory) (member (first directory) '(:absolute :relative))))
+     directory)
+    (t
+     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
+
+(defun* merge-pathname-directory-components (specified defaults)
+  (let ((directory (normalize-pathname-directory-component specified)))
+    (ecase (first directory)
+      ((nil) defaults)
+      (:absolute specified)
+      (:relative
+       (let ((defdir (normalize-pathname-directory-component defaults))
+             (reldir (cdr directory)))
+         (cond
+           ((null defdir)
+            directory)
+           ((not (eq :back (first reldir)))
+            (append defdir reldir))
+           (t
+            (loop :with defabs = (first defdir)
+              :with defrev = (reverse (rest defdir))
+              :while (and (eq :back (car reldir))
+                          (or (and (eq :absolute defabs) (null defrev))
+                              (stringp (car defrev))))
+              :do (pop reldir) (pop defrev)
+              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
+
+(defun* ununspecific (x)
+  (if (eq x :unspecific) nil x))
+
 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
-  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
-does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
+  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
+if the SPECIFIED pathname does not have an absolute directory,
+then the HOST and DEVICE both come from the DEFAULTS, whereas
+if the SPECIFIED pathname does have an absolute directory,
+then the HOST and DEVICE both come from the SPECIFIED.
 Also, if either argument is NIL, then the other argument is returned unmodified."
   (when (null specified) (return-from merge-pathnames* defaults))
   (when (null defaults) (return-from merge-pathnames* specified))
+  #+scl
+  (ext:resolve-pathname specified defaults)
+  #-scl
   (let* ((specified (pathname specified))
          (defaults (pathname defaults))
-         (directory (pathname-directory specified))
-         #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory))
+         (directory (normalize-pathname-directory-component (pathname-directory specified)))
          (name (or (pathname-name specified) (pathname-name defaults)))
          (type (or (pathname-type specified) (pathname-type defaults)))
          (version (or (pathname-version specified) (pathname-version defaults))))
-    (labels ((ununspecific (x)
-               (if (eq x :unspecific) nil x))
-             (unspecific-handler (p)
+    (labels ((unspecific-handler (p)
                (if (typep p 'logical-pathname) #'ununspecific #'identity)))
       (multiple-value-bind (host device directory unspecific-handler)
-          (#-gcl ecase #+gcl case (first directory)
-            ((nil)
-             (values (pathname-host defaults)
-                     (pathname-device defaults)
-                     (pathname-directory defaults)
-                     (unspecific-handler defaults)))
+          (ecase (first directory)
             ((:absolute)
              (values (pathname-host specified)
                      (pathname-device specified)
                      directory
                      (unspecific-handler specified)))
-            ((:relative)
+            ((nil :relative)
              (values (pathname-host defaults)
                      (pathname-device defaults)
-                     (if (pathname-directory defaults)
-                         (append (pathname-directory defaults) (cdr directory))
-                         directory)
-                     (unspecific-handler defaults)))
-            #+gcl
-            (t
-             (assert (stringp (first directory)))
-             (values (pathname-host defaults)
-                     (pathname-device defaults)
-                     (append (pathname-directory defaults) directory)
+                     (merge-pathname-directory-components directory (pathname-directory defaults))
                      (unspecific-handler defaults))))
         (make-pathname :host host :device device :directory directory
                        :name (funcall unspecific-handler name)
                        :type (funcall unspecific-handler type)
                        :version (funcall unspecific-handler version))))))
 
+(defun* pathname-parent-directory-pathname (pathname)
+  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
+and NIL NAME, TYPE and VERSION components"
+  (when pathname
+    (make-pathname :name nil :type nil :version nil
+                   :directory (merge-pathname-directory-components
+                               '(:relative :back) (pathname-directory pathname))
+                   :defaults pathname)))
+
 (define-modify-macro appendf (&rest args)
   append "Append onto list") ;; only to be used on short lists.
 
@@ -577,9 +585,10 @@ Also, if either argument is NIL, then the other argument is returned unmodified.
 (defun* last-char (s)
   (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
 
+
 (defun* asdf-message (format-string &rest format-args)
   (declare (dynamic-extent format-args))
-  (apply #'format *verbose-out* format-string format-args))
+  (apply 'format *verbose-out* format-string format-args))
 
 (defun* split-string (string &key max (separator '(#\Space #\Tab)))
   "Split STRING into a list of components separated by
@@ -587,10 +596,10 @@ any of the characters in the sequence SEPARATOR.
 If MAX is specified, then no more than max(1,MAX) components will be returned,
 starting the separation from the end, e.g. when called with arguments
  \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
-  (block nil
+  (catch nil
     (let ((list nil) (words 0) (end (length string)))
       (flet ((separatorp (char) (find char separator))
-             (done () (return (cons (subseq string 0 end) list))))
+             (done () (throw nil (cons (subseq string 0 end) list))))
         (loop
           :for start = (if (and max (>= words (1- max)))
                            (done)
@@ -606,14 +615,14 @@ starting the separation from the end, e.g. when called with arguments
          ;; Giving :unspecific as argument to make-pathname is not portable.
          ;; See CLHS make-pathname and 19.2.2.2.3.
          ;; We only use it on implementations that support it.
-         (or #+(or ccl ecl gcl lispworks sbcl) :unspecific)))
+         (or #+(or clozure gcl lispworks sbcl) :unspecific)))
     (destructuring-bind (name &optional (type unspecific))
         (split-string filename :max 2 :separator ".")
       (if (equal name "")
           (values filename unspecific)
           (values name type)))))
 
-(defun* component-name-to-pathname-components (s &optional force-directory)
+(defun* component-name-to-pathname-components (s &key force-directory force-relative)
   "Splits the path string S, returning three values:
 A flag that is either :absolute or :relative, indicating
    how the rest of the values are to be interpreted.
@@ -630,15 +639,21 @@ The intention of this function is to support structured component names,
 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
 pathnames."
   (check-type s string)
+  (when (find #\: s)
+    (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
   (let* ((components (split-string s :separator "/"))
          (last-comp (car (last components))))
     (multiple-value-bind (relative components)
         (if (equal (first components) "")
             (if (equal (first-char s) #\/)
-                (values :absolute (cdr components))
+                (progn
+                  (when force-relative
+                    (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
+                  (values :absolute (cdr components)))
                 (values :relative nil))
           (values :relative components))
-      (setf components (remove "" components :test #'equal))
+      (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
+      (setf components (substitute :back ".." components :test #'equal))
       (cond
         ((equal last-comp "")
          (values relative components nil)) ; "" already removed
@@ -659,16 +674,31 @@ pathnames."
     :append (list k v)))
 
 (defun* getenv (x)
-  (#+abcl ext:getenv
-   #+allegro sys:getenv
-   #+clisp ext:getenv
-   #+clozure ccl:getenv
-   #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=)))
-   #+ecl si:getenv
-   #+gcl system:getenv
-   #+lispworks lispworks:environment-variable
-   #+sbcl sb-ext:posix-getenv
-   x))
+  (declare (ignorable x))
+  #+(or abcl clisp ecl xcl) (ext:getenv x)
+  #+allegro (sys:getenv x)
+  #+clozure (ccl:getenv x)
+  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
+  #+cormanlisp
+  (let* ((buffer (ct:malloc 1))
+         (cname (ct:lisp-string-to-c-string x))
+         (needed-size (win:getenvironmentvariable cname buffer 0))
+         (buffer1 (ct:malloc (1+ needed-size))))
+    (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
+               nil
+               (ct:c-string-to-lisp-string buffer1))
+      (ct:free buffer)
+      (ct:free buffer1)))
+  #+gcl (system:getenv x)
+  #+genera nil
+  #+lispworks (lispworks:environment-variable x)
+  #+mcl (ccl:with-cstrs ((name x))
+          (let ((value (_getenv name)))
+            (unless (ccl:%null-ptr-p value)
+              (ccl:%get-cstring value))))
+  #+sbcl (sb-ext:posix-getenv x)
+  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
+  (error "~S is not supported on your implementation" 'getenv))
 
 (defun* directory-pathname-p (pathname)
   "Does PATHNAME represent a directory?
@@ -679,11 +709,14 @@ ways that the filename components can be missing are for it to be NIL,
 
 Note that this does _not_ check to see that PATHNAME points to an
 actually-existing directory."
-  (flet ((check-one (x)
-           (member x '(nil :unspecific "") :test 'equal)))
-    (and (check-one (pathname-name pathname))
-         (check-one (pathname-type pathname))
-         t)))
+  (when pathname
+    (let ((pathname (pathname pathname)))
+      (flet ((check-one (x)
+               (member x '(nil :unspecific "") :test 'equal)))
+        (and (not (wild-pathname-p pathname))
+             (check-one (pathname-name pathname))
+             (check-one (pathname-type pathname))
+             t)))))
 
 (defun* ensure-directory-pathname (pathspec)
   "Converts the non-wild pathname designator PATHSPEC to directory form."
@@ -691,9 +724,9 @@ actually-existing directory."
    ((stringp pathspec)
     (ensure-directory-pathname (pathname pathspec)))
    ((not (pathnamep pathspec))
-    (error "Invalid pathname designator ~S" pathspec))
+    (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
    ((wild-pathname-p pathspec)
-    (error "Can't reliably convert wild pathnames."))
+    (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
    ((directory-pathname-p pathspec)
     pathspec)
    (t
@@ -703,8 +736,14 @@ actually-existing directory."
                    :name nil :type nil :version nil
                    :defaults pathspec))))
 
+#+genera
+(unless (fboundp 'ensure-directories-exist)
+  (defun* ensure-directories-exist (path)
+    (fs:create-directories-recursively (pathname path))))
+
 (defun* absolute-pathname-p (pathspec)
-  (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec))))))
+  (and (typep pathspec '(or pathname string))
+       (eq :absolute (car (pathname-directory (pathname pathspec))))))
 
 (defun* length=n-p (x n) ;is it that (= (length x) n) ?
   (check-type n (integer 0 *))
@@ -729,57 +768,39 @@ actually-existing directory."
      :until (eq form eof)
      :collect form)))
 
-#-(and (or win32 windows mswindows mingw32) (not cygwin))
-(progn
-  #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
-                  '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
-  (defun* get-uid ()
-    #+allegro (excl.osi:getuid)
-    #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
-	          :for f = (ignore-errors (read-from-string s))
-                  :when f :return (funcall f))
-    #+(or cmu scl) (unix:unix-getuid)
-    #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
-                   '(ffi:c-inline () () :int "getuid()" :one-liner t)
-                   '(ext::getuid))
-    #+sbcl (sb-unix:unix-getuid)
-    #-(or allegro clisp cmu ecl sbcl scl)
-    (let ((uid-string
-           (with-output-to-string (*verbose-out*)
-             (run-shell-command "id -ur"))))
-      (with-input-from-string (stream uid-string)
-        (read-line stream)
-        (handler-case (parse-integer (read-line stream))
-          (error () (error "Unable to find out user ID")))))))
-
 (defun* pathname-root (pathname)
-  (make-pathname :host (pathname-host pathname)
-                 :device (pathname-device pathname)
-                 :directory '(:absolute)
-                 :name nil :type nil :version nil))
+  (make-pathname :directory '(:absolute)
+                 :name nil :type nil :version nil
+                 :defaults pathname ;; host device, and on scl, *some*
+                 ;; scheme-specific parts: port username password, not others:
+                 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
 
 (defun* probe-file* (p)
   "when given a pathname P, probes the filesystem for a file or directory
 with given pathname and if it exists return its truename."
   (etypecase p
-   (null nil)
-   (string (probe-file* (parse-namestring p)))
-   (pathname (unless (wild-pathname-p p)
-               #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p)
-               #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p))
-	       '(ignore-errors (truename p)))))))
-
-(defun* truenamize (p)
+    (null nil)
+    (string (probe-file* (parse-namestring p)))
+    (pathname (unless (wild-pathname-p p)
+                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
+                      '(probe-file p)
+                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
+                                   `(ignore-errors (,it p)))
+                      '(ignore-errors (truename p)))))))
+
+(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
   "Resolve as much of a pathname as possible"
   (block nil
-    (when (typep p 'logical-pathname) (return p))
-    (let* ((p (merge-pathnames* p))
-           (directory (pathname-directory p)))
+    (when (typep pathname '(or null logical-pathname)) (return pathname))
+    (let ((p (merge-pathnames* pathname defaults)))
       (when (typep p 'logical-pathname) (return p))
       (let ((found (probe-file* p)))
         (when found (return found)))
-      #-(or sbcl cmu) (when (stringp directory) (return p))
-      (when (not (eq :absolute (car directory))) (return p))
+      (unless (absolute-pathname-p p)
+        (let ((true-defaults (ignore-errors (truename defaults))))
+          (when true-defaults
+            (setf p (merge-pathnames pathname true-defaults)))))
+      (unless (absolute-pathname-p p) (return p))
       (let ((sofar (probe-file* (pathname-root p))))
         (unless sofar (return p))
         (flet ((solution (directories)
@@ -790,7 +811,9 @@ with given pathname and if it exists return its truename."
                                  :type (pathname-type p)
                                  :version (pathname-version p))
                   sofar)))
-          (loop :for component :in (cdr directory)
+          (loop :with directory = (normalize-pathname-directory-component
+                                   (pathname-directory p))
+            :for component :in (cdr directory)
             :for rest :on (cdr directory)
             :for more = (probe-file*
                          (merge-pathnames*
@@ -804,7 +827,23 @@ with given pathname and if it exists return its truename."
 
 (defun* resolve-symlinks (path)
   #-allegro (truenamize path)
-  #+allegro (excl:pathname-resolve-symbolic-links path))
+  #+allegro (if (typep path 'logical-pathname)
+                path
+                (excl:pathname-resolve-symbolic-links path)))
+
+(defun* resolve-symlinks* (path)
+  (if *resolve-symlinks*
+      (and path (resolve-symlinks path))
+      path))
+
+(defun* ensure-pathname-absolute (path)
+  (cond
+    ((absolute-pathname-p path) path)
+    ((stringp path) (ensure-pathname-absolute (pathname path)))
+    ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
+    (t (let ((resolved (resolve-symlinks path)))
+         (assert (absolute-pathname-p resolved))
+         resolved))))
 
 (defun* default-directory ()
   (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
@@ -812,33 +851,197 @@ with given pathname and if it exists return its truename."
 (defun* lispize-pathname (input-file)
   (make-pathname :type "lisp" :defaults input-file))
 
+(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
+(defparameter *wild-file*
+  (make-pathname :name *wild* :type *wild*
+                 :version (or #-(or abcl xcl) *wild*) :directory nil))
+(defparameter *wild-directory*
+  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
+(defparameter *wild-inferiors*
+  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
 (defparameter *wild-path*
-  (make-pathname :directory '(:relative :wild-inferiors)
-                 :name :wild :type :wild :version :wild))
+  (merge-pathnames *wild-file* *wild-inferiors*))
 
 (defun* wilden (path)
   (merge-pathnames* *wild-path* path))
 
+#-scl
+(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
+  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
+    (last-char (namestring foo))))
+
+#-scl
 (defun* directorize-pathname-host-device (pathname)
   (let* ((root (pathname-root pathname))
          (wild-root (wilden root))
          (absolute-pathname (merge-pathnames* pathname root))
-         (foo (make-pathname :directory '(:absolute "FOO") :defaults root))
-         (separator (last-char (namestring foo)))
+         (separator (directory-separator-for-host root))
          (root-namestring (namestring root))
          (root-string
           (substitute-if #\/
-                         (lambda (x) (or (eql x #\:)
-                                         (eql x separator)))
+                         #'(lambda (x) (or (eql x #\:)
+                                           (eql x separator)))
                          root-namestring)))
     (multiple-value-bind (relative path filename)
-        (component-name-to-pathname-components root-string t)
+        (component-name-to-pathname-components root-string :force-directory t)
       (declare (ignore relative filename))
       (let ((new-base
              (make-pathname :defaults root
                             :directory `(:absolute , at path))))
         (translate-pathname absolute-pathname wild-root (wilden new-base))))))
 
+#+scl
+(defun* directorize-pathname-host-device (pathname)
+  (let ((scheme (ext:pathname-scheme pathname))
+        (host (pathname-host pathname))
+        (port (ext:pathname-port pathname))
+        (directory (pathname-directory pathname)))
+    (if (or (ununspecific port)
+            (and (ununspecific host) (plusp (length host)))
+            (ununspecific scheme))
+        (let ((prefix ""))
+          (when (ununspecific port)
+            (setf prefix (format nil ":~D" port)))
+          (when (and (ununspecific host) (plusp (length host)))
+            (setf prefix (strcat host prefix)))
+          (setf prefix (strcat ":" prefix))
+          (when (ununspecific scheme)
+            (setf prefix (strcat scheme prefix)))
+          (assert (and directory (eq (first directory) :absolute)))
+          (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
+                         :defaults pathname)))
+    pathname))
+
+;;;; -------------------------------------------------------------------------
+;;;; ASDF Interface, in terms of generic functions.
+(defgeneric* find-system (system &optional error-p))
+(defgeneric* perform-with-restarts (operation component))
+(defgeneric* perform (operation component))
+(defgeneric* operation-done-p (operation component))
+(defgeneric* mark-operation-done (operation component))
+(defgeneric* explain (operation component))
+(defgeneric* output-files (operation component))
+(defgeneric* input-files (operation component))
+(defgeneric* component-operation-time (operation component))
+(defgeneric* operation-description (operation component)
+  (:documentation "returns a phrase that describes performing this operation
+on this component, e.g. \"loading /a/b/c\".
+You can put together sentences using this phrase."))
+
+(defgeneric* system-source-file (system)
+  (:documentation "Return the source file in which system is defined."))
+
+(defgeneric* component-system (component)
+  (:documentation "Find the top-level system containing COMPONENT"))
+
+(defgeneric* component-pathname (component)
+  (:documentation "Extracts the pathname applicable for a particular component."))
+
+(defgeneric* component-relative-pathname (component)
+  (:documentation "Returns a pathname for the component argument intended to be
+interpreted relative to the pathname of that component's parent.
+Despite the function's name, the return value may be an absolute
+pathname, because an absolute pathname may be interpreted relative to
+another pathname in a degenerate way."))
+
+(defgeneric* component-property (component property))
+
+(defgeneric* (setf component-property) (new-value component property))
+
+(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
+  (defgeneric* (setf module-components-by-name) (new-value module)))
+
+(defgeneric* version-satisfies (component version))
+
+(defgeneric* find-component (base path)
+  (:documentation "Finds the component with PATH starting from BASE module;
+if BASE is nil, then the component is assumed to be a system."))
+
+(defgeneric* source-file-type (component system))
+
+(defgeneric* operation-ancestor (operation)
+  (:documentation
+   "Recursively chase the operation's parent pointer until we get to
+the head of the tree"))
+
+(defgeneric* component-visited-p (operation component)
+  (:documentation "Returns the value stored by a call to
+VISIT-COMPONENT, if that has been called, otherwise NIL.
+This value stored will be a cons cell, the first element
+of which is a computed key, so not interesting.  The
+CDR wil be the DATA value stored by VISIT-COMPONENT; recover
+it as (cdr (component-visited-p op c)).
+  In the current form of ASDF, the DATA value retrieved is
+effectively a boolean, indicating whether some operations are
+to be performed in order to do OPERATION X COMPONENT.  If the
+data value is NIL, the combination had been explored, but no
+operations needed to be performed."))
+
+(defgeneric* visit-component (operation component data)
+  (:documentation "Record DATA as being associated with OPERATION
+and COMPONENT.  This is a side-effecting function:  the association
+will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
+OPERATION\).
+  No evidence that DATA is ever interesting, beyond just being
+non-NIL.  Using the data field is probably very risky; if there is
+already a record for OPERATION X COMPONENT, DATA will be quietly
+discarded instead of recorded.
+  Starting with 2.006, TRAVERSE will store an integer in data,
+so that nodes can be sorted in decreasing order of traversal."))
+
+
+(defgeneric* (setf visiting-component) (new-value operation component))
+
+(defgeneric* component-visiting-p (operation component))
+
+(defgeneric* component-depends-on (operation component)
+  (:documentation
+   "Returns a list of dependencies needed by the component to perform
+    the operation.  A dependency has one of the following forms:
+
+      (<operation> <component>*), where <operation> is a class
+        designator and each <component> is a component
+        designator, which means that the component depends on
+        <operation> having been performed on each <component>; or
+
+      (FEATURE <feature>), which means that the component depends
+        on <feature>'s presence in *FEATURES*.
+
+    Methods specialized on subclasses of existing component types
+    should usually append the results of CALL-NEXT-METHOD to the
+    list."))
+
+(defgeneric* component-self-dependencies (operation component))
+
+(defgeneric* traverse (operation component)
+  (:documentation
+"Generate and return a plan for performing OPERATION on COMPONENT.
+
+The plan returned is a list of dotted-pairs. Each pair is the CONS
+of ASDF operation object and a COMPONENT object. The pairs will be
+processed in order by OPERATE."))
+
+
+;;;; -------------------------------------------------------------------------
+;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
+(when *upgraded-p*
+   (when (find-class 'module nil)
+     (eval
+      '(defmethod update-instance-for-redefined-class :after
+           ((m module) added deleted plist &key)
+         (declare (ignorable deleted plist))
+         (when *asdf-verbose*
+           (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
+                         m (asdf-version)))
+         (when (member 'components-by-name added)
+           (compute-module-components-by-name m))
+         (when (typep m 'system)
+           (when (member 'source-file added)
+             (%set-system-source-file
+              (probe-asd (component-name m) (component-pathname m)) m)
+             (when (equal (component-name m) "asdf")
+               (setf (component-version m) *asdf-version*))))))))
+
 ;;;; -------------------------------------------------------------------------
 ;;;; Classes, Conditions
 
@@ -851,39 +1054,30 @@ with given pathname and if it exists return its truename."
   ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
   #+cmu (:report print-object))
 
-(declaim (ftype (function (t) t)
-                format-arguments format-control
-                error-name error-pathname error-condition
-                duplicate-names-name
-                error-component error-operation
-                module-components module-components-by-name
-                circular-dependency-components)
-         (ftype (function (t t) t) (setf module-components-by-name)))
-
-
 (define-condition formatted-system-definition-error (system-definition-error)
   ((format-control :initarg :format-control :reader format-control)
    (format-arguments :initarg :format-arguments :reader format-arguments))
   (:report (lambda (c s)
-             (apply #'format s (format-control c) (format-arguments c)))))
+               (apply 'format s (format-control c) (format-arguments c)))))
 
 (define-condition load-system-definition-error (system-definition-error)
   ((name :initarg :name :reader error-name)
    (pathname :initarg :pathname :reader error-pathname)
    (condition :initarg :condition :reader error-condition))
   (:report (lambda (c s)
-             (format s "~@<Error while trying to load definition for system ~A from pathname ~A: ~A~@:>"
+             (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
                      (error-name c) (error-pathname c) (error-condition c)))))
 
 (define-condition circular-dependency (system-definition-error)
   ((components :initarg :components :reader circular-dependency-components))
   (:report (lambda (c s)
-             (format s "~@<Circular dependency: ~S~@:>" (circular-dependency-components c)))))
+             (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
+                     (circular-dependency-components c)))))
 
 (define-condition duplicate-names (system-definition-error)
   ((name :initarg :name :reader duplicate-names-name))
   (:report (lambda (c s)
-             (format s "~@<Error while defining system: multiple components are given same name ~A~@:>"
+             (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
                      (duplicate-names-name c)))))
 
 (define-condition missing-component (system-definition-error)
@@ -904,23 +1098,61 @@ with given pathname and if it exists return its truename."
   ((component :reader error-component :initarg :component)
    (operation :reader error-operation :initarg :operation))
   (:report (lambda (c s)
-             (format s "~@<erred while invoking ~A on ~A~@:>"
-                     (error-operation c) (error-component c)))))
+               (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
+                       (error-operation c) (error-component c)))))
 (define-condition compile-error (operation-error) ())
 (define-condition compile-failed (compile-error) ())
 (define-condition compile-warned (compile-error) ())
 
+(define-condition invalid-configuration ()
+  ((form :reader condition-form :initarg :form)
+   (location :reader condition-location :initarg :location)
+   (format :reader condition-format :initarg :format)
+   (arguments :reader condition-arguments :initarg :arguments :initform nil))
+  (:report (lambda (c s)
+               (format s (compatfmt "~@<~? (will be skipped)~@:>")
+                       (condition-format c)
+                       (list* (condition-form c) (condition-location c)
+                              (condition-arguments c))))))
+(define-condition invalid-source-registry (invalid-configuration warning)
+  ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
+(define-condition invalid-output-translation (invalid-configuration warning)
+  ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
+
 (defclass component ()
-  ((name :accessor component-name :initarg :name :documentation
+  ((name :accessor component-name :initarg :name :type string :documentation
          "Component name: designator for a string composed of portable pathname characters")
+   ;; We might want to constrain version with
+   ;; :type (and string (satisfies parse-version))
+   ;; but we cannot until we fix all systems that don't use it correctly!
    (version :accessor component-version :initarg :version)
+   (description :accessor component-description :initarg :description)
+   (long-description :accessor component-long-description :initarg :long-description)
+   ;; This one below is used by POIU - http://www.cliki.net/poiu
+   ;; a parallelizing extension of ASDF that compiles in multiple parallel
+   ;; slave processes (forked on demand) and loads in the master process.
+   ;; Maybe in the future ASDF may use it internally instead of in-order-to.
+   (load-dependencies :accessor component-load-dependencies :initform nil)
+   ;; In the ASDF object model, dependencies exist between *actions*
+   ;; (an action is a pair of operation and component). They are represented
+   ;; alists of operations to dependencies (other actions) in each component.
+   ;; There are two kinds of dependencies, each stored in its own slot:
+   ;; in-order-to and do-first dependencies. These two kinds are related to
+   ;; the fact that some actions modify the filesystem,
+   ;; whereas other actions modify the current image, and
+   ;; this implies a difference in how to interpret timestamps.
+   ;; in-order-to dependencies will trigger re-performing the action
+   ;; when the timestamp of some dependency
+   ;; makes the timestamp of current action out-of-date;
+   ;; do-first dependencies do not trigger such re-performing.
+   ;; Therefore, a FASL must be recompiled if it is obsoleted
+   ;; by any of its FASL dependencies (in-order-to); but
+   ;; it needn't be recompiled just because one of these dependencies
+   ;; hasn't yet been loaded in the current image (do-first).
+   ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
+   ;; See our ASDF 2 paper for more complete explanations.
    (in-order-to :initform nil :initarg :in-order-to
                 :accessor component-in-order-to)
-   ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to?
-   ;; POIU is a parallel (multi-process build) extension of ASDF.  See
-   ;; http://www.cliki.net/poiu
-   (load-dependencies :accessor component-load-dependencies :initform nil)
-   ;; XXX crap name, but it's an official API name!
    (do-first :initform nil :initarg :do-first
              :accessor component-do-first)
    ;; methods defined using the "inline" style inside a defsystem form:
@@ -931,9 +1163,11 @@ with given pathname and if it exists return its truename."
    ;; no direct accessor for pathname, we do this as a method to allow
    ;; it to default in funky ways if not supplied
    (relative-pathname :initarg :pathname)
+   ;; the absolute-pathname is computed based on relative-pathname...
    (absolute-pathname)
    (operation-times :initform (make-hash-table)
                     :accessor component-operation-times)
+   (around-compile :initarg :around-compile)
    ;; XXX we should provide some atomic interface for updating the
    ;; component properties
    (properties :accessor component-properties :initarg :properties
@@ -946,13 +1180,13 @@ with given pathname and if it exists return its truename."
 
 (defmethod print-object ((c component) stream)
   (print-unreadable-object (c stream :type t :identity nil)
-    (format stream "~@<~{~S~^ ~}~@:>" (component-find-path c))))
+    (format stream "~{~S~^ ~}" (component-find-path c))))
 
 
 ;;;; methods: conditions
 
 (defmethod print-object ((c missing-dependency) s)
-  (format s "~@<~A, required by ~A~@:>"
+  (format s (compatfmt "~@<~A, required by ~A~@:>")
           (call-next-method c nil) (missing-required-by c)))
 
 (defun* sysdef-error (format &rest arguments)
@@ -962,17 +1196,17 @@ with given pathname and if it exists return its truename."
 ;;;; methods: components
 
 (defmethod print-object ((c missing-component) s)
-  (format s "~@<component ~S not found~@[ in ~A~]~@:>"
+  (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
           (missing-requires c)
           (when (missing-parent c)
-            (component-name (missing-parent c)))))
+            (coerce-name (missing-parent c)))))
 
 (defmethod print-object ((c missing-component-of-version) s)
-  (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>"
+  (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
           (missing-requires c)
           (missing-version c)
           (when (missing-parent c)
-            (component-name (missing-parent c)))))
+            (coerce-name (missing-parent c)))))
 
 (defmethod component-system ((component component))
   (aif (component-parent component)
@@ -1025,10 +1259,10 @@ with given pathname and if it exists return its truename."
       (slot-value component 'absolute-pathname)
       (let ((pathname
              (merge-pathnames*
-             (component-relative-pathname component)
-             (pathname-directory-pathname (component-parent-pathname component)))))
+              (component-relative-pathname component)
+              (pathname-directory-pathname (component-parent-pathname component)))))
         (unless (or (null pathname) (absolute-pathname-p pathname))
-          (error "Invalid relative pathname ~S for component ~S"
+          (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
                  pathname (component-find-path component)))
         (setf (slot-value component 'absolute-pathname) pathname)
         pathname)))
@@ -1044,39 +1278,146 @@ with given pathname and if it exists return its truename."
               (acons property new-value (slot-value c 'properties)))))
   new-value)
 
-(defclass system (module)
-  ((description :accessor system-description :initarg :description)
-   (long-description
-    :accessor system-long-description :initarg :long-description)
+(defclass proto-system () ; slots to keep when resetting a system
+  ;; To preserve identity for all objects, we'd need keep the components slots
+  ;; but also to modify parse-component-form to reset the recycled objects.
+  ((name) #|(components) (components-by-names)|#))
+
+(defclass system (module proto-system)
+  (;; description and long-description are now available for all component's,
+   ;; but now also inherited from component, but we add the legacy accessor
+   (description :accessor system-description :initarg :description)
+   (long-description :accessor system-long-description :initarg :long-description)
    (author :accessor system-author :initarg :author)
    (maintainer :accessor system-maintainer :initarg :maintainer)
    (licence :accessor system-licence :initarg :licence
             :accessor system-license :initarg :license)
-   (source-file :reader system-source-file :initarg :source-file
-                :writer %set-system-source-file)))
+   (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
+                :writer %set-system-source-file)
+   (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; version-satisfies
 
 (defmethod version-satisfies ((c component) version)
   (unless (and version (slot-boundp c 'version))
+    (when version
+      (warn "Requested version ~S but component ~S has no version" version c))
     (return-from version-satisfies t))
   (version-satisfies (component-version c) version))
 
+(defun* asdf-version ()
+  "Exported interface to the version of ASDF currently installed. A string.
+You can compare this string with e.g.:
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
+  *asdf-version*)
+
+(defun* parse-version (string &optional on-error)
+  "Parse a version string as a series of natural integers separated by dots.
+Return a (non-null) list of integers if the string is valid, NIL otherwise.
+If on-error is error, warn, or designates a function of compatible signature,
+the function is called with an explanation of what is wrong with the argument.
+NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
+  (and
+   (or (stringp string)
+       (when on-error
+         (funcall on-error "~S: ~S is not a string"
+                  'parse-version string)) nil)
+   (or (loop :for prev = nil :then c :for c :across string
+         :always (or (digit-char-p c)
+                     (and (eql c #\.) prev (not (eql prev #\.))))
+         :finally (return (and c (digit-char-p c))))
+       (when on-error
+         (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
+                  'parse-version string)) nil)
+   (mapcar #'parse-integer (split-string string :separator "."))))
+
 (defmethod version-satisfies ((cver string) version)
-  (let ((x (mapcar #'parse-integer
-                   (split-string cver :separator ".")))
-        (y (mapcar #'parse-integer
-                   (split-string version :separator "."))))
+  (let ((x (parse-version cver 'warn))
+        (y (parse-version version 'warn)))
     (labels ((bigger (x y)
                (cond ((not y) t)
                      ((not x) nil)
                      ((> (car x) (car y)) t)
                      ((= (car x) (car y))
                       (bigger (cdr x) (cdr y))))))
-      (and (= (car x) (car y))
+      (and x y (= (car x) (car y))
            (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
 
+;;;; -----------------------------------------------------------------
+;;;; Windows shortcut support.  Based on:
+;;;;
+;;;; Jesse Hager: The Windows Shortcut File Format.
+;;;; http://www.wotsit.org/list.asp?fc=13
+
+#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
+(progn
+(defparameter *link-initial-dword* 76)
+(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
+
+(defun* read-null-terminated-string (s)
+  (with-output-to-string (out)
+    (loop :for code = (read-byte s)
+      :until (zerop code)
+      :do (write-char (code-char code) out))))
+
+(defun* read-little-endian (s &optional (bytes 4))
+  (loop :for i :from 0 :below bytes
+    :sum (ash (read-byte s) (* 8 i))))
+
+(defun* parse-file-location-info (s)
+  (let ((start (file-position s))
+        (total-length (read-little-endian s))
+        (end-of-header (read-little-endian s))
+        (fli-flags (read-little-endian s))
+        (local-volume-offset (read-little-endian s))
+        (local-offset (read-little-endian s))
+        (network-volume-offset (read-little-endian s))
+        (remaining-offset (read-little-endian s)))
+    (declare (ignore total-length end-of-header local-volume-offset))
+    (unless (zerop fli-flags)
+      (cond
+        ((logbitp 0 fli-flags)
+          (file-position s (+ start local-offset)))
+        ((logbitp 1 fli-flags)
+          (file-position s (+ start
+                              network-volume-offset
+                              #x14))))
+      (strcat (read-null-terminated-string s)
+              (progn
+                (file-position s (+ start remaining-offset))
+                (read-null-terminated-string s))))))
+
+(defun* parse-windows-shortcut (pathname)
+  (with-open-file (s pathname :element-type '(unsigned-byte 8))
+    (handler-case
+        (when (and (= (read-little-endian s) *link-initial-dword*)
+                   (let ((header (make-array (length *link-guid*))))
+                     (read-sequence header s)
+                     (equalp header *link-guid*)))
+          (let ((flags (read-little-endian s)))
+            (file-position s 76)        ;skip rest of header
+            (when (logbitp 0 flags)
+              ;; skip shell item id list
+              (let ((length (read-little-endian s 2)))
+                (file-position s (+ length (file-position s)))))
+            (cond
+              ((logbitp 1 flags)
+                (parse-file-location-info s))
+              (t
+                (when (logbitp 2 flags)
+                  ;; skip description string
+                  (let ((length (read-little-endian s 2)))
+                    (file-position s (+ length (file-position s)))))
+                (when (logbitp 3 flags)
+                  ;; finally, our pathname
+                  (let* ((length (read-little-endian s 2))
+                         (buffer (make-array length)))
+                    (read-sequence buffer s)
+                    (map 'string #'code-char buffer)))))))
+      (end-of-file ()
+        nil)))))
+
 ;;;; -------------------------------------------------------------------------
 ;;;; Finding systems
 
@@ -1095,48 +1436,62 @@ of which is a system object.")
     (component (component-name name))
     (symbol (string-downcase (symbol-name name)))
     (string name)
-    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
+    (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
 
 (defun* system-registered-p (name)
   (gethash (coerce-name name) *defined-systems*))
 
+(defun* register-system (system)
+  (check-type system system)
+  (let ((name (component-name system)))
+    (check-type name string)
+    (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
+    (unless (eq system (cdr (gethash name *defined-systems*)))
+      (setf (gethash name *defined-systems*)
+            (cons (get-universal-time) system)))))
+
 (defun* clear-system (name)
   "Clear the entry for a system in the database of systems previously loaded.
 Note that this does NOT in any way cause the code of the system to be unloaded."
-  ;; There is no "unload" operation in Common Lisp, and a general such operation
-  ;; cannot be portably written, considering how much CL relies on side-effects
-  ;; of global data structures.
-  ;; Note that this does a setf gethash instead of a remhash
-  ;; this way there remains a hint in the *defined-systems* table
-  ;; that the system was loaded at some point.
-  (setf (gethash (coerce-name name) *defined-systems*) nil))
+  ;; There is no "unload" operation in Common Lisp, and
+  ;; a general such operation cannot be portably written,
+  ;; considering how much CL relies on side-effects to global data structures.
+  (remhash (coerce-name name) *defined-systems*))
 
 (defun* map-systems (fn)
   "Apply FN to each defined system.
 
 FN should be a function of one argument. It will be
 called with an object of type asdf:system."
-  (maphash (lambda (_ datum)
-             (declare (ignore _))
-             (destructuring-bind (_ . def) datum
+  (maphash #'(lambda (_ datum)
                (declare (ignore _))
-               (funcall fn def)))
+               (destructuring-bind (_ . def) datum
+                 (declare (ignore _))
+                 (funcall fn def)))
            *defined-systems*))
 
 ;;; for the sake of keeping things reasonably neat, we adopt a
 ;;; convention that functions in this list are prefixed SYSDEF-
 
-(defparameter *system-definition-search-functions*
-  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
-
-(defun* system-definition-pathname (system)
-  (let ((system-name (coerce-name system)))
-    (or
-     (some (lambda (x) (funcall x system-name))
-           *system-definition-search-functions*)
-     (let ((system-pair (system-registered-p system-name)))
-       (and system-pair
-            (system-source-file (cdr system-pair)))))))
+(defvar *system-definition-search-functions* '())
+
+(setf *system-definition-search-functions*
+      (append
+       ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
+       (remove 'contrib-sysdef-search *system-definition-search-functions*)
+       ;; Tuck our defaults at the end of the list if they were absent.
+       ;; This is imperfect, in case they were removed on purpose,
+       ;; but then it will be the responsibility of whoever does that
+       ;; to upgrade asdf before he does such a thing rather than after.
+       (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
+                  '(sysdef-central-registry-search
+                    sysdef-source-registry-search
+                    sysdef-find-asdf))))
+
+(defun* search-for-system-definition (system)
+  (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
+        (cons 'find-system-if-being-defined
+              *system-definition-search-functions*)))
 
 (defvar *central-registry* nil
 "A list of 'system directory designators' ASDF uses to find systems.
@@ -1153,26 +1508,45 @@ This is for backward compatibilily.
 Going forward, we recommend new users should be using the source-registry.
 ")
 
+(defun* featurep (x &optional (features *features*))
+  (cond
+    ((atom x)
+     (and (member x features) t))
+    ((eq :not (car x))
+     (assert (null (cddr x)))
+     (not (featurep (cadr x) features)))
+    ((eq :or (car x))
+     (some #'(lambda (x) (featurep x features)) (cdr x)))
+    ((eq :and (car x))
+     (every #'(lambda (x) (featurep x features)) (cdr x)))
+    (t
+     (error "Malformed feature specification ~S" x))))
+
+(defun* os-unix-p ()
+  (featurep '(:or :unix :cygwin :darwin)))
+
+(defun* os-windows-p ()
+  (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
+
 (defun* probe-asd (name defaults)
   (block nil
     (when (directory-pathname-p defaults)
-      (let ((file
-             (make-pathname
-              :defaults defaults :version :newest :case :local
-              :name name
-              :type "asd")))
-        (when (probe-file file)
+      (let ((file (make-pathname
+                   :defaults defaults :name name
+                   :version :newest :case :local :type "asd")))
+        (when (probe-file* file)
           (return file)))
-      #+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
-      (let ((shortcut
-             (make-pathname
-              :defaults defaults :version :newest :case :local
-              :name (concatenate 'string name ".asd")
-              :type "lnk")))
-        (when (probe-file shortcut)
-          (let ((target (parse-windows-shortcut shortcut)))
-            (when target
-              (return (pathname target)))))))))
+      #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
+      (when (os-windows-p)
+        (let ((shortcut
+               (make-pathname
+                :defaults defaults :version :newest :case :local
+                :name (strcat name ".asd")
+                :type "lnk")))
+          (when (probe-file* shortcut)
+            (let ((target (parse-windows-shortcut shortcut)))
+              (when target
+                (return (pathname target))))))))))
 
 (defun* sysdef-central-registry-search (system)
   (let ((name (coerce-name system))
@@ -1192,7 +1566,7 @@ Going forward, we recommend new users should be using the source-registry.
                             (let* ((*print-circle* nil)
                                    (message
                                     (format nil
-                                            "~@<While searching for system ~S: ~S evaluated to ~S which is not a directory.~@:>"
+                                            (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
                                             system dir defaults)))
                               (error message))
                           (remove-entry-from-registry ()
@@ -1200,7 +1574,7 @@ Going forward, we recommend new users should be using the source-registry.
                             (push dir to-remove))
                           (coerce-entry-to-directory ()
                             :report (lambda (s)
-                                      (format s "Coerce entry to ~a, replace ~a and continue."
+                                      (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
                                               (ensure-directory-pathname defaults) dir))
                             (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
         ;; cleanup
@@ -1233,66 +1607,129 @@ Going forward, we recommend new users should be using the source-registry.
   ;; and we can survive and we will continue the planning
   ;; as if the file were very old.
   ;; (or should we treat the case in a different, special way?)
-  (or (and pathname (probe-file pathname) (file-write-date pathname))
+  (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
       (progn
         (when (and pathname *asdf-verbose*)
-          (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
+          (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
                 pathname))
         0)))
 
+(defmethod find-system ((name null) &optional (error-p t))
+  (declare (ignorable name))
+  (when error-p
+    (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
+
 (defmethod find-system (name &optional (error-p t))
   (find-system (coerce-name name) error-p))
 
+(defvar *systems-being-defined* nil
+  "A hash-table of systems currently being defined keyed by name, or NIL")
+
+(defun* find-system-if-being-defined (name)
+  (when *systems-being-defined*
+    (gethash (coerce-name name) *systems-being-defined*)))
+
+(defun* call-with-system-definitions (thunk)
+  (if *systems-being-defined*
+      (funcall thunk)
+      (let ((*systems-being-defined* (make-hash-table :test 'equal)))
+        (funcall thunk))))
+
+(defmacro with-system-definitions ((&optional) &body body)
+  `(call-with-system-definitions #'(lambda () , at body)))
+
+(defun* load-sysdef (name pathname)
+  ;; Tries to load system definition with canonical NAME from PATHNAME.
+  (with-system-definitions ()
+    (let ((package (make-temporary-package)))
+      (unwind-protect
+           (handler-bind
+               ((error #'(lambda (condition)
+                           (error 'load-system-definition-error
+                                  :name name :pathname pathname
+                                  :condition condition))))
+             (let ((*package* package)
+                   (*default-pathname-defaults*
+                    (pathname-directory-pathname pathname)))
+               (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
+                             pathname package)
+               (load pathname)))
+        (delete-package package)))))
+
+(defun* locate-system (name)
+  "Given a system NAME designator, try to locate where to load the system from.
+Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
+FOUNDP is true when a new was found, either a new unregistered one or a previously registered one.
+FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
+PATHNAME when not null is a path from where to load the system, associated with FOUND-SYSTEM, or with the PREVIOUS system.
+PREVIOUS when not null is a previously loaded SYSTEM object of same name.
+PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
+  (let* ((name (coerce-name name))
+         (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
+         (previous (cdr in-memory))
+         (previous (and (typep previous 'system) previous))
+         (previous-time (car in-memory))
+           (found (search-for-system-definition name))
+         (found-system (and (typep found 'system) found))
+         (pathname (or (and (typep found '(or pathname string)) (pathname found))
+                       (and found-system (system-source-file found-system))
+                       (and previous (system-source-file previous))))
+         (foundp (and (or found-system pathname previous) t)))
+    (check-type found (or null pathname system))
+    (when foundp
+      (setf pathname (resolve-symlinks* pathname))
+      (when (and pathname (not (absolute-pathname-p pathname)))
+        (setf pathname (ensure-pathname-absolute pathname))
+        (when found-system
+          (%set-system-source-file pathname found-system)))
+      (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
+                                             (system-source-file previous) pathname)))
+        (%set-system-source-file pathname previous)
+        (setf previous-time nil))
+      (values foundp found-system pathname previous previous-time))))
+
 (defmethod find-system ((name string) &optional (error-p t))
-  (catch 'find-system
-    (let* ((in-memory (system-registered-p name))
-           (on-disk (system-definition-pathname name)))
-      (when (and on-disk
-                 (or (not in-memory)
-                     (< (car in-memory) (safe-file-write-date on-disk))))
-        (let ((package (make-temporary-package)))
-          (unwind-protect
-               (handler-bind
-                   ((error (lambda (condition)
-                             (error 'load-system-definition-error
-                                    :name name :pathname on-disk
-                                    :condition condition))))
-                 (let ((*package* package))
-                   (asdf-message
-                    "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
-                    on-disk *package*)
-                   (load on-disk)))
-            (delete-package package))))
-      (let ((in-memory (system-registered-p name)))
-        (cond
-          (in-memory
-           (when on-disk
-             (setf (car in-memory) (safe-file-write-date on-disk)))
-           (cdr in-memory))
-          (error-p
-           (error 'missing-component :requires name)))))))
-
-(defun* register-system (name system)
-  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
-  (setf (gethash (coerce-name name) *defined-systems*)
-        (cons (get-universal-time) system)))
-
-(defun* find-system-fallback (requested fallback &optional source-file)
+  (with-system-definitions ()
+    (loop
+      (restart-case
+          (multiple-value-bind (foundp found-system pathname previous previous-time)
+              (locate-system name)
+            (declare (ignore foundp))
+            (when (and found-system (not previous))
+              (register-system found-system))
+            (when (and pathname
+                       (or (not previous-time)
+                           ;; don't reload if it's already been loaded,
+                           ;; or its filestamp is in the future which means some clock is skewed
+                           ;; and trying to load might cause an infinite loop.
+                           (< previous-time (safe-file-write-date pathname) (get-universal-time))))
+              (load-sysdef name pathname))
+            (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
+              (return
+                (cond
+                  (in-memory
+                   (when pathname
+                     (setf (car in-memory) (safe-file-write-date pathname)))
+                   (cdr in-memory))
+                  (error-p
+                   (error 'missing-component :requires name))))))
+        (reinitialize-source-registry-and-retry ()
+          :report (lambda (s)
+                    (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name))
+          (initialize-source-registry))))))
+
+(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
   (setf fallback (coerce-name fallback)
-        source-file (or source-file *compile-file-truename* *load-truename*)
         requested (coerce-name requested))
   (when (equal requested fallback)
-    (let* ((registered (cdr (gethash fallback *defined-systems*)))
-           (system (or registered
-                       (make-instance
-                        'system :name fallback
-                        :source-file source-file))))
-      (unless registered
-        (register-system fallback system))
-      (throw 'find-system system))))
+    (let ((registered (cdr (gethash fallback *defined-systems*))))
+      (or registered
+          (apply 'make-instance 'system
+                 :name fallback :source-file source-file keys)))))
 
 (defun* sysdef-find-asdf (name)
-  (find-system-fallback name "asdf"))
+  ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
+  (find-system-fallback name "asdf" :version *asdf-version*))
 
 
 ;;;; -------------------------------------------------------------------------
@@ -1332,6 +1769,10 @@ Going forward, we recommend new users should be using the source-registry.
 
 (defclass cl-source-file (source-file)
   ((type :initform "lisp")))
+(defclass cl-source-file.cl (cl-source-file)
+  ((type :initform "cl")))
+(defclass cl-source-file.lsp (cl-source-file)
+  ((type :initform "lsp")))
 (defclass c-source-file (source-file)
   ((type :initform "c")))
 (defclass java-source-file (source-file)
@@ -1348,22 +1789,31 @@ Going forward, we recommend new users should be using the source-registry.
   (declare (ignorable s))
   (source-file-explicit-type component))
 
-(defun* merge-component-name-type (name &key type defaults)
+(defun* coerce-pathname (name &key type defaults)
+  "coerce NAME into a PATHNAME.
+When given a string, portably decompose it into a relative pathname:
+#\\/ separates subdirectories. The last #\\/-separated string is as follows:
+if TYPE is NIL, its last #\\. if any separates name and type from from type;
+if TYPE is a string, it is the type, and the whole string is the name;
+if TYPE is :DIRECTORY, the string is a directory component;
+if the string is empty, it's a directory.
+Any directory named .. is read as :BACK.
+Host, device and version components are taken from DEFAULTS."
   ;; The defaults are required notably because they provide the default host
   ;; to the below make-pathname, which may crucially matter to people using
   ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
   ;; NOTE that the host and device slots will be taken from the defaults,
-  ;; but that should only matter if you either (a) use absolute pathnames, or
-  ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
-  ;; ASDF:MERGE-PATHNAMES*
+  ;; but that should only matter if you later merge relative pathnames with
+  ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
   (etypecase name
-    (pathname
+    ((or null pathname)
      name)
     (symbol
-     (merge-component-name-type (string-downcase name) :type type :defaults defaults))
+     (coerce-pathname (string-downcase name) :type type :defaults defaults))
     (string
      (multiple-value-bind (relative path filename)
-         (component-name-to-pathname-components name (eq type :directory))
+         (component-name-to-pathname-components name :force-directory (eq type :directory)
+                                                :force-relative t)
        (multiple-value-bind (name type)
            (cond
              ((or (eq type :directory) (null filename))
@@ -1372,35 +1822,44 @@ Going forward, we recommend new users should be using the source-registry.
               (values filename type))
              (t
               (split-name-type filename)))
-         (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
-                (host (pathname-host defaults))
-                (device (pathname-device defaults)))
-           (make-pathname :directory `(,relative , at path)
-                          :name name :type type
-                          :host host :device device)))))))
+         (apply 'make-pathname :directory (cons relative path) :name name :type type
+                (when defaults `(:defaults ,defaults))))))))
+
+(defun* merge-component-name-type (name &key type defaults)
+  ;; For backwards compatibility only, for people using internals.
+  ;; Will be removed in a future release, e.g. 2.016.
+  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
+  (coerce-pathname name :type type :defaults defaults))
 
 (defmethod component-relative-pathname ((component component))
-  (merge-component-name-type
+  (coerce-pathname
    (or (slot-value component 'relative-pathname)
        (component-name component))
    :type (source-file-type component (component-system component))
    :defaults (component-parent-pathname component)))
 
+(defun* subpathname (pathname subpath &key type)
+  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
+                                  (pathname-directory-pathname pathname))))
+
+(defun subpathname* (pathname subpath &key type)
+  (and pathname
+       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
+
 ;;;; -------------------------------------------------------------------------
 ;;;; Operations
 
 ;;; one of these is instantiated whenever #'operate is called
 
 (defclass operation ()
-  (
-   ;; as of danb's 2003-03-16 commit e0d02781, :force can be:
-   ;; T to force the inside of existing system,
+  (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
+   ;; T to force the inside of the specified system,
    ;;   but not recurse to other systems we depend on.
    ;; :ALL (or any other atom) to force all systems
    ;;   including other systems we depend on.
    ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    ;;   to force systems named in a given list
-   ;; However, but this feature never worked before ASDF 1.700 and is currently cerror'ed out.
+   ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
    (forced :initform nil :initarg :force :accessor operation-forced)
    (original-initargs :initform nil :initarg :original-initargs
                       :accessor operation-original-initargs)
@@ -1442,13 +1901,13 @@ class specifier, not an operation."
                 (not (eql c dep-c)))
            (when (eql force-p t)
              (setf (getf args :force) nil))
-           (apply #'make-instance dep-o
+           (apply 'make-instance dep-o
                   :parent o
                   :original-initargs args args))
           ((subtypep (type-of o) dep-o)
            o)
           (t
-           (apply #'make-instance dep-o
+           (apply 'make-instance dep-o
                   :parent o :original-initargs args args)))))
 
 
@@ -1480,26 +1939,27 @@ class specifier, not an operation."
     (gethash node (operation-visiting-nodes (operation-ancestor o)))))
 
 (defmethod component-depends-on ((op-spec symbol) (c component))
+  ;; Note: we go from op-spec to operation via make-instance
+  ;; to allow for specialization through defmethod's, even though
+  ;; it's a detour in the default case below.
   (component-depends-on (make-instance op-spec) c))
 
 (defmethod component-depends-on ((o operation) (c component))
-  (cdr (assoc (class-name (class-of o))
-              (component-in-order-to c))))
+  (cdr (assoc (type-of o) (component-in-order-to c))))
 
 (defmethod component-self-dependencies ((o operation) (c component))
-  (let ((all-deps (component-depends-on o c)))
-    (remove-if-not (lambda (x)
-                     (member (component-name c) (cdr x) :test #'string=))
-                   all-deps)))
+  (remove-if-not
+   #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
+   (component-depends-on o c)))
 
 (defmethod input-files ((operation operation) (c component))
   (let ((parent (component-parent c))
         (self-deps (component-self-dependencies operation c)))
     (if self-deps
-        (mapcan (lambda (dep)
-                  (destructuring-bind (op name) dep
-                    (output-files (make-instance op)
-                                  (find-component parent name))))
+        (mapcan #'(lambda (dep)
+                    (destructuring-bind (op name) dep
+                      (output-files (make-instance op)
+                                    (find-component parent name))))
                 self-deps)
         ;; no previous operations needed?  I guess we work with the
         ;; original source file, then
@@ -1534,7 +1994,7 @@ class specifier, not an operation."
          ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
          (and op-time (>= op-time (latest-in))))
         ((not in-files)
-         ;; an operation without output-files and no input-files
+         ;; an operation with output-files and no input-files
          ;; is probably meant for its side-effects on the file-system,
          ;; assumed to have to be done everytime.
          ;; (I don't think there is any such case in ASDF unless extended)
@@ -1553,8 +2013,8 @@ class specifier, not an operation."
          ;; than one second of filesystem time (or just crosses the
          ;; second). So that's cool.
          (and
-          (every #'probe-file in-files)
-          (every #'probe-file out-files)
+          (every #'probe-file* in-files)
+          (every #'probe-file* out-files)
           (>= (earliest-out) (latest-in))))))))
 
 
@@ -1576,84 +2036,89 @@ recursive calls to traverse.")
 
 (defgeneric* do-traverse (operation component collect))
 
-(defun* %do-one-dep (operation c collect required-op required-c required-v)
-  ;; collects a partial plan that results from performing required-op
-  ;; on required-c, possibly with a required-vERSION
-  (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
-                      (and d (version-satisfies d required-v) d))
-                    (if required-v
-                        (error 'missing-dependency-of-version
-                               :required-by c
-                               :version required-v
-                               :requires required-c)
-                        (error 'missing-dependency
-                               :required-by c
-                               :requires required-c))))
-         (op (make-sub-operation c operation dep-c required-op)))
-    (do-traverse op dep-c collect)))
-
-(defun* do-one-dep (operation c collect required-op required-c required-v)
-  ;; this function is a thin, error-handling wrapper around
-  ;; %do-one-dep.  Returns a partial plan per that function.
+(defun* resolve-dependency-name (component name &optional version)
   (loop
     (restart-case
-        (return (%do-one-dep operation c collect
-                             required-op required-c required-v))
+        (return
+          (let ((comp (find-component (component-parent component) name)))
+            (unless comp
+              (error 'missing-dependency
+                     :required-by component
+                     :requires name))
+            (when version
+              (unless (version-satisfies comp version)
+                (error 'missing-dependency-of-version
+                       :required-by component
+                       :version version
+                       :requires name)))
+            comp))
       (retry ()
         :report (lambda (s)
-                  (format s "~@<Retry loading component ~S.~@:>"
-                          (component-find-path required-c)))
+                  (format s "~@<Retry loading ~3i~_~A.~@:>" name))
         :test
         (lambda (c)
-          #|
-          (print (list :c1 c (typep c 'missing-dependency)))
-          (when (typep c 'missing-dependency)
-          (print (list :c2 (missing-requires c) required-c
-          (equalp (missing-requires c)
-          required-c))))
-          |#
           (or (null c)
               (and (typep c 'missing-dependency)
-                   (equalp (missing-requires c)
-                           required-c))))))))
-
-(defun* do-dep (operation c collect op dep)
-  ;; type of arguments uncertain:
-  ;; op seems to at least potentially be a symbol, rather than an operation
-  ;; dep is a list of component names
-  (cond ((eq op 'feature)
-         (if (member (car dep) *features*)
+                   (eq (missing-required-by c) component)
+                   (equal (missing-requires c) name))))))))
+
+(defun* resolve-dependency-spec (component dep-spec)
+  (cond
+    ((atom dep-spec)
+     (resolve-dependency-name component dep-spec))
+    ;; Structured dependencies --- this parses keywords.
+    ;; The keywords could conceivably be broken out and cleanly (extensibly)
+    ;; processed by EQL methods. But for now, here's what we've got.
+    ((eq :version (first dep-spec))
+     ;; https://bugs.launchpad.net/asdf/+bug/527788
+     (resolve-dependency-name component (second dep-spec) (third dep-spec)))
+    ((eq :feature (first dep-spec))
+     ;; This particular subform is not documented and
+     ;; has always been broken in the past.
+     ;; Therefore no one uses it, and I'm cerroring it out,
+     ;; after fixing it
+     ;; See https://bugs.launchpad.net/asdf/+bug/518467
+     (cerror "Continue nonetheless."
+             "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
+     (when (find (second dep-spec) *features* :test 'string-equal)
+       (resolve-dependency-name component (third dep-spec))))
+    (t
+     (error (compatfmt "~@<Bad dependency ~s.  Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
+
+(defun* do-one-dep (op c collect dep-op dep-c)
+  ;; Collects a partial plan for performing dep-op on dep-c
+  ;; as dependencies of a larger plan involving op and c.
+  ;; Returns t if this should force recompilation of those who depend on us.
+  ;; dep-op is an operation class name (not an operation object),
+  ;; whereas dep-c is a component object.n
+  (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
+
+(defun* do-dep (op c collect dep-op-spec dep-c-specs)
+  ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
+  ;; as dependencies of a larger plan involving op and c.
+  ;; Returns t if this should force recompilation of those who depend on us.
+  ;; dep-op-spec is either an operation class name (not an operation object),
+  ;; or the magic symbol asdf:feature.
+  ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
+  ;; and the plan will succeed if that keyword is present in *feature*,
+  ;; or fail if it isn't
+  ;; (at which point c's :if-component-dep-fails will kick in).
+  ;; If dep-op-spec is an operation class name,
+  ;; then dep-c-specs specifies a list of sibling component of c,
+  ;; as per resolve-dependency-spec, such that operating op on c
+  ;; depends on operating dep-op-spec on each of them.
+  (cond ((eq dep-op-spec 'feature)
+         (if (member (car dep-c-specs) *features*)
              nil
              (error 'missing-dependency
                     :required-by c
-                    :requires (car dep))))
+                    :requires (list :feature (car dep-c-specs)))))
         (t
          (let ((flag nil))
-           (flet ((dep (op comp ver)
-                    (when (do-one-dep operation c collect
-                                      op comp ver)
-                      (setf flag t))))
-             (dolist (d dep)
-               (if (atom d)
-                   (dep op d nil)
-                   ;; structured dependencies --- this parses keywords
-                   ;; the keywords could be broken out and cleanly (extensibly)
-                   ;; processed by EQL methods
-                   (cond ((eq :version (first d))
-                          ;; https://bugs.launchpad.net/asdf/+bug/527788
-                          (dep op (second d) (third d)))
-                         ;; This particular subform is not documented and
-                         ;; has always been broken in the past.
-                         ;; Therefore no one uses it, and I'm cerroring it out,
-                         ;; after fixing it
-                         ;; See https://bugs.launchpad.net/asdf/+bug/518467
-                         ((eq :feature (first d))
-                          (cerror "Continue nonetheless."
-                                  "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
-                          (when (find (second d) *features* :test 'string-equal)
-                            (dep op (third d) nil)))
-                         (t
-                          (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))))
+           (dolist (d dep-c-specs)
+             (when (do-one-dep op c collect dep-op-spec
+                               (resolve-dependency-spec c d))
+               (setf flag t)))
            flag))))
 
 (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
@@ -1662,11 +2127,11 @@ recursive calls to traverse.")
   (funcall collect x))
 
 (defmethod do-traverse ((operation operation) (c component) collect)
-  (let ((flag nil)) ;; return value: must we rebuild this and its dependencies?
+  (let ((*forcing* *forcing*)
+        (flag nil)) ;; return value: must we rebuild this and its dependencies?
     (labels
         ((update-flag (x)
-           (when x
-             (setf flag t)))
+           (orf flag x))
          (dep (op comp)
            (update-flag (do-dep operation c collect op comp))))
       ;; Have we been visited yet? If so, just process the result.
@@ -1680,6 +2145,13 @@ recursive calls to traverse.")
       (setf (visiting-component operation c) t)
       (unwind-protect
            (progn
+             (let ((f (operation-forced
+                       (operation-ancestor operation))))
+               (when (and f (or (not (consp f)) ;; T or :ALL
+                                (and (typep c 'system) ;; list of names of systems to force
+                                     (member (component-name c) f
+                                             :test #'string=))))
+                 (setf *forcing* t)))
              ;; first we check and do all the dependencies for the module.
              ;; Operations planned in this loop will show up
              ;; in the results, and are consumed below.
@@ -1707,6 +2179,7 @@ recursive calls to traverse.")
                             (handler-case
                                 (update-flag
                                  (do-traverse operation kid #'internal-collect))
+                              #-genera
                               (missing-dependency (condition)
                                 (when (eq (module-if-component-dep-fails c)
                                           :fail)
@@ -1719,22 +2192,13 @@ recursive calls to traverse.")
                                          :try-next)
                                      (not at-least-one))
                             (error error)))))))
-               (update-flag
-                (or
-                 *forcing*
-                 (not (operation-done-p operation c))
+               (update-flag (or *forcing* (not (operation-done-p operation c))))
                  ;; For sub-operations, check whether
                  ;; the original ancestor operation was forced,
                  ;; or names us amongst an explicit list of things to force...
                  ;; except that this check doesn't distinguish
                  ;; between all the things with a given name. Sigh.
                  ;; BROKEN!
-                 (let ((f (operation-forced
-                           (operation-ancestor operation))))
-                   (and f (or (not (consp f)) ;; T or :ALL
-                              (and (typep c 'system) ;; list of names of systems to force
-                                   (member (component-name c) f
-                                           :test #'string=)))))))
                (when flag
                  (let ((do-first (cdr (assoc (class-name (class-of operation))
                                              (component-do-first c)))))
@@ -1763,12 +2227,7 @@ recursive calls to traverse.")
       (r* l))))
 
 (defmethod traverse ((operation operation) (c component))
-  ;; cerror'ing a feature that seems to have NEVER EVER worked
-  ;; ever since danb created it in his 2003-03-16 commit e0d02781.
-  ;; It was both fixed and disabled in the 1.700 rewrite.
   (when (consp (operation-forced operation))
-    (cerror "Continue nonetheless."
-            "Congratulations, you're the first ever user of the :force (list of system names) feature! Please contact the asdf-devel mailing-list to collect a cookie.")
     (setf (operation-forced operation)
           (mapcar #'coerce-name (operation-forced operation))))
   (flatten-tree
@@ -1778,18 +2237,49 @@ recursive calls to traverse.")
 
 (defmethod perform ((operation operation) (c source-file))
   (sysdef-error
-   "~@<required method PERFORM not implemented for operation ~A, component ~A~@:>"
+   (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
    (class-of operation) (class-of c)))
 
 (defmethod perform ((operation operation) (c module))
   (declare (ignorable operation c))
   nil)
 
+(defmethod mark-operation-done ((operation operation) (c component))
+  (setf (gethash (type-of operation) (component-operation-times c))
+    (reduce #'max
+            (cons (get-universal-time)
+                  (mapcar #'safe-file-write-date (input-files operation c))))))
+
+(defmethod perform-with-restarts (operation component)
+  ;; TOO verbose, especially as the default. Add your own :before method
+  ;; to perform-with-restart or perform if you want that:
+  #|(when *asdf-verbose* (explain operation component))|#
+  (perform operation component))
+
+(defmethod perform-with-restarts :around (operation component)
+  (loop
+    (restart-case
+        (return (call-next-method))
+      (retry ()
+        :report
+        (lambda (s)
+          (format s (compatfmt "~@<Retry ~A.~@:>")
+                  (operation-description operation component))))
+      (accept ()
+        :report
+        (lambda (s)
+          (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
+                  (operation-description operation component)))
+        (mark-operation-done operation component)
+        (return)))))
+
 (defmethod explain ((operation operation) (component component))
-  (asdf-message "~&;;; ~A~%" (operation-description operation component)))
+  (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
+                (operation-description operation component)))
 
 (defmethod operation-description (operation component)
-  (format nil "~A on component ~S" (class-of operation) (component-find-path component)))
+  (format nil (compatfmt "~@<~A on ~A~@:>")
+          (class-of operation) component))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; compile-op
@@ -1801,33 +2291,53 @@ recursive calls to traverse.")
    (on-failure :initarg :on-failure :accessor operation-on-failure
                :initform *compile-file-failure-behaviour*)
    (flags :initarg :flags :accessor compile-op-flags
-          :initform #-ecl nil #+ecl '(:system-p t))))
+          :initform nil)))
 
-(defun output-file (operation component)
+(defun* output-file (operation component)
   "The unique output file of performing OPERATION on COMPONENT"
   (let ((files (output-files operation component)))
     (assert (length=n-p files 1))
     (first files)))
 
-(defmethod perform :before ((operation compile-op) (c source-file))
-  (map nil #'ensure-directories-exist (output-files operation c)))
+(defun* ensure-all-directories-exist (pathnames)
+   (loop :for pn :in pathnames
+     :for pathname = (if (typep pn 'logical-pathname)
+                         (translate-logical-pathname pn)
+                         pn)
+     :do (ensure-directories-exist pathname)))
 
-#+ecl
-(defmethod perform :after ((o compile-op) (c cl-source-file))
-  ;; Note how we use OUTPUT-FILES to find the binary locations
-  ;; This allows the user to override the names.
-  (let* ((files (output-files o c))
-         (object (first files))
-         (fasl (second files)))
-    (c:build-fasl fasl :lisp-files (list object))))
+(defmethod perform :before ((operation compile-op) (c source-file))
+  (ensure-all-directories-exist (asdf:output-files operation c)))
 
 (defmethod perform :after ((operation operation) (c component))
-  (setf (gethash (type-of operation) (component-operation-times c))
-        (get-universal-time)))
+  (mark-operation-done operation c))
+
+(defgeneric* around-compile-hook (component))
+(defgeneric* call-with-around-compile-hook (component thunk))
 
-(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
-                          (values t t t))
-                compile-file*))
+(defmethod around-compile-hook ((c component))
+  (cond
+    ((slot-boundp c 'around-compile)
+     (slot-value c 'around-compile))
+    ((component-parent c)
+     (around-compile-hook (component-parent c)))))
+
+(defun ensure-function (fun &key (package :asdf))
+  (etypecase fun
+    ((or symbol function) fun)
+    (cons (eval `(function ,fun)))
+    (string (eval `(function ,(with-standard-io-syntax
+                               (let ((*package* (find-package package)))
+                                 (read-from-string fun))))))))
+
+(defmethod call-with-around-compile-hook ((c component) thunk)
+  (let ((hook (around-compile-hook c)))
+    (if hook
+        (funcall (ensure-function hook) thunk)
+        (funcall thunk))))
+
+(defvar *compile-op-compile-file-function* 'compile-file*
+  "Function used to compile lisp files.")
 
 ;;; perform is required to check output-files to find out where to put
 ;;; its answers, in case it has been overridden for site policy
@@ -1840,32 +2350,32 @@ recursive calls to traverse.")
         (*compile-file-warnings-behaviour* (operation-on-warnings operation))
         (*compile-file-failure-behaviour* (operation-on-failure operation)))
     (multiple-value-bind (output warnings-p failure-p)
-        (apply #'compile-file* source-file :output-file output-file
-               (compile-op-flags operation))
-      (when warnings-p
-        (case (operation-on-warnings operation)
-          (:warn (warn
-                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
-                  operation c))
-          (:error (error 'compile-warned :component c :operation operation))
-          (:ignore nil)))
+        (call-with-around-compile-hook
+         c #'(lambda ()
+               (apply *compile-op-compile-file-function* source-file
+                      :output-file output-file (compile-op-flags operation))))
+      (unless output
+        (error 'compile-error :component c :operation operation))
       (when failure-p
         (case (operation-on-failure operation)
           (:warn (warn
-                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
+                  (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
                   operation c))
           (:error (error 'compile-failed :component c :operation operation))
           (:ignore nil)))
-      (unless output
-        (error 'compile-error :component c :operation operation)))))
+      (when warnings-p
+        (case (operation-on-warnings operation)
+          (:warn (warn
+                  (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
+                  operation c))
+          (:error (error 'compile-warned :component c :operation operation))
+          (:ignore nil))))))
 
 (defmethod output-files ((operation compile-op) (c cl-source-file))
   (declare (ignorable operation))
   (let ((p (lispize-pathname (component-pathname c))))
-    #-:broken-fasl-loader
-    (list (compile-file-pathname p #+ecl :type #+ecl :object)
-          #+ecl (compile-file-pathname p :type :fasl))
-    #+:broken-fasl-loader (list p)))
+    #-broken-fasl-loader (list (compile-file-pathname p))
+    #+broken-fasl-loader (list p)))
 
 (defmethod perform ((operation compile-op) (c static-file))
   (declare (ignorable operation c))
@@ -1881,7 +2391,12 @@ recursive calls to traverse.")
 
 (defmethod operation-description ((operation compile-op) component)
   (declare (ignorable operation))
-  (format nil "compiling component ~S" (component-find-path component)))
+  (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
+
+(defmethod operation-description ((operation compile-op) (component module))
+  (declare (ignorable operation))
+  (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
+
 
 ;;;; -------------------------------------------------------------------------
 ;;;; load-op
@@ -1890,56 +2405,18 @@ recursive calls to traverse.")
 
 (defclass load-op (basic-load-op) ())
 
-(defmethod perform ((o load-op) (c cl-source-file))
-  #-ecl (mapcar #'load (input-files o c))
-  #+ecl (loop :for i :in (input-files o c)
-          :unless (string= (pathname-type i) "fas")
-          :collect (let ((output (compile-file-pathname (lispize-pathname i))))
-                     (load output))))
-
-(defmethod perform-with-restarts (operation component)
-  (perform operation component))
-
 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
-  (declare (ignorable o))
-  (loop :with state = :initial
-    :until (or (eq state :success)
-               (eq state :failure)) :do
-    (case state
-      (:recompiled
-       (setf state :failure)
-       (call-next-method)
-       (setf state :success))
-      (:failed-load
-       (setf state :recompiled)
-       (perform (make-instance 'compile-op) c))
-      (t
-       (with-simple-restart
-           (try-recompiling "Recompile ~a and try loading it again"
-                            (component-name c))
-         (setf state :failed-load)
-         (call-next-method)
-         (setf state :success))))))
-
-(defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
-  (loop :with state = :initial
-    :until (or (eq state :success)
-               (eq state :failure)) :do
-    (case state
-      (:recompiled
-       (setf state :failure)
-       (call-next-method)
-       (setf state :success))
-      (:failed-compile
-       (setf state :recompiled)
-       (perform-with-restarts o c))
-      (t
-       (with-simple-restart
-           (try-recompiling "Try recompiling ~a"
-                            (component-name c))
-         (setf state :failed-compile)
-         (call-next-method)
-         (setf state :success))))))
+  (loop
+    (restart-case
+        (return (call-next-method))
+      (try-recompiling ()
+        :report (lambda (s)
+                  (format s "Recompile ~a and try loading it again"
+                          (component-name c)))
+        (perform (make-sub-operation c o c 'compile-op) c)))))
+
+(defmethod perform ((o load-op) (c cl-source-file))
+  (map () #'load (input-files o c)))
 
 (defmethod perform ((operation load-op) (c static-file))
   (declare (ignorable operation c))
@@ -1960,8 +2437,18 @@ recursive calls to traverse.")
 
 (defmethod operation-description ((operation load-op) component)
   (declare (ignorable operation))
-  (format nil "loading component ~S" (component-find-path component)))
+  (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
+          component))
+
+(defmethod operation-description ((operation load-op) (component cl-source-file))
+  (declare (ignorable operation))
+  (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
+          component))
 
+(defmethod operation-description ((operation load-op) (component module))
+  (declare (ignorable operation))
+  (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
+          component))
 
 ;;;; -------------------------------------------------------------------------
 ;;;; load-source-op
@@ -1972,7 +2459,7 @@ recursive calls to traverse.")
   (declare (ignorable o))
   (let ((source (component-pathname c)))
     (setf (component-property c 'last-loaded-as-source)
-          (and (load source)
+          (and (call-with-around-compile-hook c #'(lambda () (load source)))
                (get-universal-time)))))
 
 (defmethod perform ((operation load-source-op) (c static-file))
@@ -1983,16 +2470,12 @@ recursive calls to traverse.")
   (declare (ignorable operation c))
   nil)
 
-;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
+;;; FIXME: We simply copy load-op's dependencies.  This is Just Not Right.
 (defmethod component-depends-on ((o load-source-op) (c component))
   (declare (ignorable o))
-  (let ((what-would-load-op-do (cdr (assoc 'load-op
-                                           (component-in-order-to c)))))
-    (mapcar (lambda (dep)
-              (if (eq (car dep) 'load-op)
-                  (cons 'load-source-op (cdr dep))
-                  dep))
-            what-would-load-op-do)))
+  (loop :with what-would-load-op-do = (component-depends-on 'load-op c)
+    :for (op . co) :in what-would-load-op-do
+    :when (eq op 'load-op) :collect (cons 'load-source-op co)))
 
 (defmethod operation-done-p ((o load-source-op) (c source-file))
   (declare (ignorable o))
@@ -2003,7 +2486,12 @@ recursive calls to traverse.")
 
 (defmethod operation-description ((operation load-source-op) component)
   (declare (ignorable operation))
-  (format nil "loading component ~S" (component-find-path component)))
+  (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>")
+          component))
+
+(defmethod operation-description ((operation load-source-op) (component module))
+  (declare (ignorable operation))
+  (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") component))
 
 
 ;;;; -------------------------------------------------------------------------
@@ -2029,47 +2517,82 @@ recursive calls to traverse.")
 ;;;; Invoking Operations
 
 (defgeneric* operate (operation-class system &key &allow-other-keys))
+(defgeneric* perform-plan (plan &key))
+
+;;;; Separating this into a different function makes it more forward-compatible
+(defun* cleanup-upgraded-asdf (old-version)
+  (let ((new-version (asdf:asdf-version)))
+    (unless (equal old-version new-version)
+      (cond
+        ((version-satisfies new-version old-version)
+         (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
+                       old-version new-version))
+        ((version-satisfies old-version new-version)
+         (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
+               old-version new-version))
+        (t
+         (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
+                       old-version new-version)))
+      (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
+        ;; Invalidate all systems but ASDF itself.
+        (setf *defined-systems* (make-defined-systems-table))
+        (register-system asdf)
+        ;; If we're in the middle of something, restart it.
+        (when *systems-being-defined*
+          (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
+            (clrhash *systems-being-defined*)
+            (dolist (s l) (find-system s nil))))
+        t))))
+
+;;;; Try to upgrade of ASDF. If a different version was used, return T.
+;;;; We need do that before we operate on anything that depends on ASDF.
+(defun* upgrade-asdf ()
+  (let ((version (asdf:asdf-version)))
+    (handler-bind (((or style-warning warning) #'muffle-warning))
+      (operate 'load-op :asdf :verbose nil))
+    (cleanup-upgraded-asdf version)))
+
+(defmethod perform-plan ((steps list) &key)
+  (let ((*package* *package*)
+        (*readtable* *readtable*))
+    (with-compilation-unit ()
+      (loop :for (op . component) :in steps :do
+        (perform-with-restarts op component)))))
 
 (defmethod operate (operation-class system &rest args
                     &key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
                     &allow-other-keys)
   (declare (ignore force))
-  (let* ((*package* *package*)
-         (*readtable* *readtable*)
-         (op (apply #'make-instance operation-class
-                    :original-initargs args
-                    args))
-         (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
-         (system (if (typep system 'component) system (find-system system))))
-    (unless (version-satisfies system version)
-      (error 'missing-component-of-version :requires system :version version))
-    (let ((steps (traverse op system)))
-      (with-compilation-unit ()
-        (loop :for (op . component) :in steps :do
-          (loop
-            (restart-case
-                (progn
-                  (perform-with-restarts op component)
-                  (return))
-              (retry ()
-                :report
-                (lambda (s)
-                  (format s "~@<Retry ~A.~@:>" (operation-description op component))))
-              (accept ()
-                :report
-                (lambda (s)
-                  (format s "~@<Continue, treating ~A as having been successful.~@:>"
-                          (operation-description op component)))
-                (setf (gethash (type-of op)
-                               (component-operation-times component))
-                      (get-universal-time))
-                (return))))))
-      (values op steps))))
+  (with-system-definitions ()
+    (let* ((op (apply 'make-instance operation-class
+                      :original-initargs args
+                      args))
+           (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
+           (system (etypecase system
+                     (system system)
+                     ((or string symbol) (find-system system)))))
+      (unless (version-satisfies system version)
+        (error 'missing-component-of-version :requires system :version version))
+      (let ((steps (traverse op system)))
+        (when (and (not (equal '("asdf") (component-find-path system)))
+                   (find '("asdf") (mapcar 'cdr steps)
+                         :test 'equal :key 'component-find-path)
+                   (upgrade-asdf))
+          ;; If we needed to upgrade ASDF to achieve our goal,
+          ;; then do it specially as the first thing, then
+          ;; invalidate all existing system
+          ;; retry the whole thing with the new OPERATE function,
+          ;; which on some implementations
+          ;; has a new symbol shadowing the current one.
+          (return-from operate
+            (apply (find-symbol* 'operate :asdf) operation-class system args)))
+        (perform-plan steps)
+        (values op steps)))))
 
 (defun* oos (operation-class system &rest args &key force verbose version
             &allow-other-keys)
   (declare (ignore force verbose version))
-  (apply #'operate operation-class system args))
+  (apply 'operate operation-class system args))
 
 (let ((operate-docstring
   "Operate does three things:
@@ -2091,42 +2614,44 @@ created with the same initargs as the original one.
 "))
   (setf (documentation 'oos 'function)
         (format nil
-                "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
+                "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
                 operate-docstring))
   (setf (documentation 'operate 'function)
         operate-docstring))
 
-(defun* load-system (system &rest args &key force verbose version
-                    &allow-other-keys)
-  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
-details."
+(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
+  "Shorthand for `(operate 'asdf:load-op system)`.
+See OPERATE for details."
   (declare (ignore force verbose version))
-  (apply #'operate 'load-op system args))
+  (apply 'operate 'load-op system args)
+  t)
+
+(defun* load-systems (&rest systems)
+  (map () 'load-system systems))
 
 (defun* compile-system (system &rest args &key force verbose version
                        &allow-other-keys)
   "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
 for details."
   (declare (ignore force verbose version))
-  (apply #'operate 'compile-op system args))
+  (apply 'operate 'compile-op system args)
+  t)
 
 (defun* test-system (system &rest args &key force verbose version
                     &allow-other-keys)
   "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
 details."
   (declare (ignore force verbose version))
-  (apply #'operate 'test-op system args))
+  (apply 'operate 'test-op system args)
+  t)
 
 ;;;; -------------------------------------------------------------------------
 ;;;; Defsystem
 
 (defun* load-pathname ()
-  (let ((pn (or *load-pathname* *compile-file-pathname*)))
-    (if *resolve-symlinks*
-        (and pn (resolve-symlinks pn))
-        pn)))
+  (resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
 
-(defun* determine-system-pathname (pathname pathname-supplied-p)
+(defun* determine-system-pathname (pathname)
   ;; The defsystem macro calls us to determine
   ;; the pathname of a system as follows:
   ;; 1. the one supplied,
@@ -2134,50 +2659,24 @@ details."
   ;; 3. taken from the *default-pathname-defaults* via default-directory
   (let* ((file-pathname (load-pathname))
          (directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
-    (or (and pathname-supplied-p (merge-pathnames* pathname directory-pathname))
+    (or (and pathname (subpathname directory-pathname pathname :type :directory))
         directory-pathname
         (default-directory))))
 
-(defmacro defsystem (name &body options)
-  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
-                            defsystem-depends-on &allow-other-keys)
-      options
-    (let ((component-options (remove-keys '(:defsystem-depends-on :class) options)))
-      `(progn
-         ;; system must be registered before we parse the body, otherwise
-         ;; we recur when trying to find an existing system of the same name
-         ;; to reuse options (e.g. pathname) from
-         ,@(loop :for system :in defsystem-depends-on
-             :collect `(load-system ,system))
-         (let ((s (system-registered-p ',name)))
-           (cond ((and s (eq (type-of (cdr s)) ',class))
-                  (setf (car s) (get-universal-time)))
-                 (s
-                  (change-class (cdr s) ',class))
-                 (t
-                  (register-system (quote ,name)
-                                   (make-instance ',class :name ',name))))
-           (%set-system-source-file (load-pathname)
-                                    (cdr (system-registered-p ',name))))
-         (parse-component-form
-          nil (list*
-               :module (coerce-name ',name)
-               :pathname
-               ,(determine-system-pathname pathname pathname-arg-p)
-               ',component-options))))))
-
 (defun* class-for-type (parent type)
   (or (loop :for symbol :in (list
-                             (unless (keywordp type) type)
-                             (find-symbol (symbol-name type) *package*)
-                             (find-symbol (symbol-name type) :asdf))
+                             type
+                             (find-symbol* type *package*)
+                             (find-symbol* type :asdf))
         :for class = (and symbol (find-class symbol nil))
-        :when (and class (subtypep class 'component))
+        :when (and class
+                   (#-cormanlisp subtypep #+cormanlisp cl::subclassp
+                                 class (find-class 'component)))
         :return class)
       (and (eq type :file)
-           (or (module-default-component-class parent)
+           (or (and parent (module-default-component-class parent))
                (find-class *default-component-class*)))
-      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
+      (sysdef-error "don't recognize component type ~A" type)))
 
 (defun* maybe-add-tree (tree op1 op2 c)
   "Add the node C at /OP1/OP2 in TREE, unless it's there already.
@@ -2186,7 +2685,7 @@ Returns the new tree (which probably shares structure with the old one)"
     (if first-op-tree
         (progn
           (aif (assoc op2 (cdr first-op-tree))
-               (if (find c (cdr it))
+               (if (find c (cdr it) :test #'equal)
                    nil
                    (setf (cdr it) (cons c (cdr it))))
                (setf (cdr first-op-tree)
@@ -2208,8 +2707,7 @@ Returns the new tree (which probably shares structure with the old one)"
 (defvar *serial-depends-on* nil)
 
 (defun* sysdef-error-component (msg type name value)
-  (sysdef-error (concatenate 'string msg
-                             "~&The value specified for ~(~A~) ~A is ~S")
+  (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
                 type name value))
 
 (defun* check-component-input (type name weakly-depends-on
@@ -2234,8 +2732,8 @@ Returns the new tree (which probably shares structure with the old one)"
          ;; this is inefficient as most of the stored
          ;; methods will not be for this particular gf
          ;; But this is hardly performance-critical
-         (lambda (m)
-           (remove-method (symbol-function name) m))
+         #'(lambda (m)
+             (remove-method (symbol-function name) m))
          (component-inline-methods component)))
   ;; clear methods, then add the new ones
   (setf (component-inline-methods component) nil))
@@ -2266,7 +2764,8 @@ Returns the new tree (which probably shares structure with the old one)"
               components pathname default-component-class
               perform explain output-files operation-done-p
               weakly-depends-on
-              depends-on serial in-order-to
+              depends-on serial in-order-to do-first
+              (version nil versionp)
               ;; list ends
               &allow-other-keys) options
     (declare (ignorable perform explain output-files operation-done-p))
@@ -2280,24 +2779,27 @@ Returns the new tree (which probably shares structure with the old one)"
                        (class-for-type parent type))))
       (error 'duplicate-names :name name))
 
-    (let* ((other-args (remove-keys
-                        '(components pathname default-component-class
-                          perform explain output-files operation-done-p
-                          weakly-depends-on
-                          depends-on serial in-order-to)
-                        rest))
-           (ret
-            (or (find-component parent name)
-                (make-instance (class-for-type parent type)))))
+    (when versionp
+      (unless (parse-version version nil)
+        (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
+              version name parent)))
+
+    (let* ((args (list* :name (coerce-name name)
+                        :pathname pathname
+                        :parent parent
+                        (remove-keys
+                         '(components pathname default-component-class
+                           perform explain output-files operation-done-p
+                           weakly-depends-on depends-on serial in-order-to)
+                         rest)))
+           (ret (find-component parent name)))
       (when weakly-depends-on
-        (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
+        (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
       (when *serial-depends-on*
         (push *serial-depends-on* depends-on))
-      (apply #'reinitialize-instance ret
-             :name (coerce-name name)
-             :pathname pathname
-             :parent parent
-             other-args)
+      (if ret ; preserve identity
+          (apply 'reinitialize-instance ret args)
+          (setf ret (apply 'make-instance (class-for-type parent type) args)))
       (component-pathname ret) ; eagerly compute the absolute pathname
       (when (typep ret 'module)
         (setf (module-default-component-class ret)
@@ -2321,11 +2823,52 @@ Returns the new tree (which probably shares structure with the old one)"
              in-order-to
              `((compile-op (compile-op , at depends-on))
                (load-op (load-op , at depends-on)))))
-      (setf (component-do-first ret) `((compile-op (load-op , at depends-on))))
+      (setf (component-do-first ret)
+            (union-of-dependencies
+             do-first
+             `((compile-op (load-op , at depends-on)))))
 
       (%refresh-component-inline-methods ret rest)
       ret)))
 
+(defun* reset-system (system &rest keys &key &allow-other-keys)
+  (change-class (change-class system 'proto-system) 'system)
+  (apply 'reinitialize-instance system keys))
+
+(defun* do-defsystem (name &rest options
+                           &key pathname (class 'system)
+                           defsystem-depends-on &allow-other-keys)
+  ;; The system must be registered before we parse the body,
+  ;; otherwise we recur when trying to find an existing system
+  ;; of the same name to reuse options (e.g. pathname) from.
+  ;; To avoid infinite recursion in cases where you defsystem a system
+  ;; that is registered to a different location to find-system,
+  ;; we also need to remember it in a special variable *systems-being-defined*.
+  (with-system-definitions ()
+    (let* ((name (coerce-name name))
+           (registered (system-registered-p name))
+           (registered! (if registered
+                            (rplaca registered (get-universal-time))
+                            (register-system (make-instance 'system :name name))))
+           (system (reset-system (cdr registered!)
+                                :name name :source-file (load-pathname)))
+           (component-options (remove-keys '(:class) options)))
+      (setf (gethash name *systems-being-defined*) system)
+      (apply 'load-systems defsystem-depends-on)
+      ;; We change-class (when necessary) AFTER we load the defsystem-dep's
+      ;; since the class might not be defined as part of those.
+      (let ((class (class-for-type nil class)))
+        (unless (eq (type-of system) class)
+          (change-class system class)))
+      (parse-component-form
+       nil (list*
+            :module name
+            :pathname (determine-system-pathname pathname)
+            component-options)))))
+
+(defmacro defsystem (name &body options)
+  `(apply 'do-defsystem ',name ',options))
+
 ;;;; ---------------------------------------------------------------------------
 ;;;; run-shell-command
 ;;;;
@@ -2333,17 +2876,31 @@ Returns the new tree (which probably shares structure with the old one)"
 ;;;; gratefully accepted, if they do the same thing.
 ;;;; If the docstring is ambiguous, send a bug report.
 ;;;;
+;;;; WARNING! The function below is mostly dysfunctional.
+;;;; For instance, it will probably run fine on most implementations on Unix,
+;;;; which will hopefully use the shell /bin/sh (which we force in some cases)
+;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
+;;;; But behavior on Windows may vary wildly between implementations,
+;;;; either relying on your having installed a POSIX sh, or going through
+;;;; the CMD.EXE interpreter, for a totally different meaning, depending on
+;;;; what is easily expressible in said implementation.
+;;;;
 ;;;; We probably should move this functionality to its own system and deprecate
 ;;;; use of it from the asdf package. However, this would break unspecified
 ;;;; existing software, so until a clear alternative exists, we can't deprecate
 ;;;; it, and even after it's been deprecated, we will support it for a few
 ;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
+;;;;
+;;;; As a suggested replacement which is portable to all ASDF-supported
+;;;; implementations and operating systems except Genera, I recommend
+;;;; xcvb-driver's xcvb-driver:run-program/process-output-stream and its
+;;;; derivatives such as xcvb-driver:run-program/for-side-effects.
 
 (defun* run-shell-command (control-string &rest args)
   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
 synchronously execute the result using a Bourne-compatible shell, with
 output to *VERBOSE-OUT*.  Returns the shell's exit code."
-  (let ((command (apply #'format nil control-string args)))
+  (let ((command (apply 'format nil control-string args)))
     (asdf-message "; $ ~A~%" command)
 
     #+abcl
@@ -2353,71 +2910,125 @@ output to *VERBOSE-OUT*.  Returns the shell's exit code."
     ;; will this fail if command has embedded quotes - it seems to work
     (multiple-value-bind (stdout stderr exit-code)
         (excl.osi:command-output
-         (format nil "~a -c \"~a\""
-                 #+mswindows "sh" #-mswindows "/bin/sh" command)
+         #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
+         #+mswindows command ; BEWARE!
          :input nil :whole nil
          #+mswindows :show-window #+mswindows :hide)
-      (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
-      (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
+      (asdf-message "~{~&~a~%~}~%" stderr)
+      (asdf-message "~{~&~a~%~}~%" stdout)
       exit-code)
 
-    #+clisp                     ;XXX not exactly *verbose-out*, I know
-    (ext:run-shell-command  command :output :terminal :wait t)
+    #+clisp
+    ;; CLISP returns NIL for exit status zero.
+    (if *verbose-out*
+        (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
+                                    command))
+               (outstream (ext:run-shell-command new-command :output :stream :wait t)))
+            (multiple-value-bind (retval out-lines)
+                (unwind-protect
+                     (parse-clisp-shell-output outstream)
+                  (ignore-errors (close outstream)))
+              (asdf-message "~{~&~a~%~}~%" out-lines)
+              retval))
+        ;; there will be no output, just grab up the exit status
+        (or (ext:run-shell-command command :output nil :wait t) 0))
 
     #+clozure
     (nth-value 1
                (ccl:external-process-status
-                (ccl:run-program "/bin/sh" (list "-c" command)
-                                 :input nil :output *verbose-out*
-                                 :wait t)))
+                (ccl:run-program
+                 (cond
+                   ((os-unix-p) "/bin/sh")
+                   ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
+                   (t (error "Unsupported OS")))
+                 (if (os-unix-p) (list "-c" command) '())
+                 :input nil :output *verbose-out* :wait t)))
+
+    #+(or cmu scl)
+    (ext:process-exit-code
+     (ext:run-program
+      "/bin/sh"
+      (list "-c" command)
+      :input nil :output *verbose-out*))
+
+    #+cormanlisp
+    (win32:system command)
 
     #+ecl ;; courtesy of Juan Jose Garcia Ripoll
-    (si:system command)
+    (ext:system command)
 
     #+gcl
     (lisp:system command)
 
     #+lispworks
-    (system:call-system-showing-output
-     command
-     :shell-type "/bin/sh"
-     :show-cmd nil
-     :prefix ""
-     :output-stream *verbose-out*)
+    (apply 'system:call-system-showing-output command
+           :show-cmd nil :prefix "" :output-stream *verbose-out*
+           (when (os-unix-p) '(:shell-type "/bin/sh")))
+
+    #+mcl
+    (ccl::with-cstrs ((%command command)) (_system %command))
 
     #+sbcl
     (sb-ext:process-exit-code
-     (apply #'sb-ext:run-program
+     (apply 'sb-ext:run-program
             #+win32 "sh" #-win32 "/bin/sh"
             (list  "-c" command)
             :input nil :output *verbose-out*
             #+win32 '(:search t) #-win32 nil))
 
-    #+(or cmu scl)
-    (ext:process-exit-code
-     (ext:run-program
-      "/bin/sh"
-      (list  "-c" command)
-      :input nil :output *verbose-out*))
+    #+xcl
+    (ext:run-shell-command command)
 
-    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl)
+    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
     (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
 
+#+clisp
+(defun* parse-clisp-shell-output (stream)
+  "Helper function for running shell commands under clisp.  Parses a specially-
+crafted output string to recover the exit status of the shell command and a
+list of lines of output."
+  (loop :with status-prefix = "ASDF-EXIT-STATUS "
+    :with prefix-length = (length status-prefix)
+    :with exit-status = -1 :with lines = ()
+    :for line = (read-line stream nil nil)
+    :while line :do (push line lines) :finally
+    (let* ((last (car lines))
+           (status (and last (>= (length last) prefix-length)
+                        (string-equal last status-prefix :end1 prefix-length)
+                        (parse-integer last :start prefix-length :junk-allowed t))))
+      (when status
+        (setf exit-status status)
+        (pop lines) (when (equal "" (car lines)) (pop lines)))
+      (return (values exit-status (reverse lines))))))
+
 ;;;; ---------------------------------------------------------------------------
 ;;;; system-relative-pathname
 
+(defun* system-definition-pathname (x)
+  ;; As of 2.014.8, we mean to make this function obsolete,
+  ;; but that won't happen until all clients have been updated.
+  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
+  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
+It used to expose ASDF internals with subtle differences with respect to
+user expectations, that have been refactored away since.
+We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
+for a mostly compatible replacement that we're supporting,
+or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
+if that's whay you mean." ;;)
+  (system-source-file x))
+
+(defmethod system-source-file ((system system))
+  (%system-source-file system))
 (defmethod system-source-file ((system-name string))
-  (system-source-file (find-system system-name)))
+  (%system-source-file (find-system system-name)))
 (defmethod system-source-file ((system-name symbol))
-  (system-source-file (find-system system-name)))
+  (%system-source-file (find-system system-name)))
 
 (defun* system-source-directory (system-designator)
   "Return a pathname object corresponding to the
 directory in which the system specification (.asd file) is
 located."
-     (make-pathname :name nil
-                 :type nil
-                 :defaults (system-source-file system-designator)))
+  (pathname-directory-pathname (system-source-file system-designator)))
 
 (defun* relativize-directory (directory)
   (cond
@@ -2435,198 +3046,259 @@ located."
      :defaults p)))
 
 (defun* system-relative-pathname (system name &key type)
-  (merge-pathnames*
-   (merge-component-name-type name :type type)
-   (system-source-directory system)))
+  (subpathname (system-source-directory system) name :type type))
 
 
 ;;; ---------------------------------------------------------------------------
 ;;; implementation-identifier
 ;;;
 ;;; produce a string to identify current implementation.
-;;; Initially stolen from SLIME's SWANK, hacked since.
-
-(defparameter *implementation-features*
-  '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp
-    :corman :cormanlisp :armedbear :gcl :ecl :scl))
-
-(defparameter *os-features*
-  '((:windows :mswindows :win32 :mingw32)
-    (:solaris :sunos)
-    :linux ;; for GCL at least, must appear before :bsd.
-    :macosx :darwin :apple
-    :freebsd :netbsd :openbsd :bsd
-    :unix))
-
-(defparameter *architecture-features*
-  '((:x86-64 :amd64 :x86_64 :x8664-target)
-    (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4)
-    :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc
-    :java-1.4 :java-1.5 :java-1.6 :java-1.7))
-
-
-(defun* lisp-version-string ()
-  (let ((s (lisp-implementation-version)))
-    (declare (ignorable s))
-    #+allegro (format nil
-                      "~A~A~A~A"
-                      excl::*common-lisp-version-number*
-                      ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
-                      (if (eq excl:*current-case-mode*
-                              :case-sensitive-lower) "M" "A")
-                      ;; Note if not using International ACL
-                      ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
-                      (excl:ics-target-case
-                       (:-ics "8")
-                       (:+ics ""))
-                      (if (member :64bit *features*) "-64bit" ""))
-    #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
-    #+clisp (subseq s 0 (position #\space s))
-    #+clozure (format nil "~d.~d-fasl~d"
-                      ccl::*openmcl-major-version*
-                      ccl::*openmcl-minor-version*
-                      (logand ccl::fasl-version #xFF))
-    #+cmu (substitute #\- #\/ s)
-    #+digitool (subseq s 8)
-    #+ecl (format nil "~A~@[-~A~]" s
-                  (let ((vcs-id (ext:lisp-implementation-vcs-id)))
-                    (when (>= (length vcs-id) 8)
-                      (subseq vcs-id 0 8))))
-    #+gcl (subseq s (1+ (position #\space s)))
-    #+lispworks (format nil "~A~@[~A~]" s
-                        (when (member :lispworks-64bit *features*) "-64bit"))
-    ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
-    #+(or cormanlisp mcl sbcl scl) s
-    #-(or allegro armedbear clisp clozure cmu cormanlisp digitool
-          ecl gcl lispworks mcl sbcl scl) s))
+;;; Initially stolen from SLIME's SWANK, rewritten since.
+;;; We're back to runtime checking, for the sake of e.g. ABCL.
 
 (defun* first-feature (features)
-  (labels
-      ((fp (thing)
-         (etypecase thing
-           (symbol
-            (let ((feature (find thing *features*)))
-              (when feature (return-from fp feature))))
-           ;; allows features to be lists of which the first
-           ;; member is the "main name", the rest being aliases
-           (cons
-            (dolist (subf thing)
-              (when (find subf *features*) (return-from fp (first thing))))))
-         nil))
-    (loop :for f :in features
-      :when (fp f) :return :it)))
-
-(defun* implementation-type ()
-  (first-feature *implementation-features*))
+  (dolist (x features)
+    (multiple-value-bind (val feature)
+        (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
+      (when (featurep feature) (return val)))))
+
+(defun implementation-type ()
+  (first-feature
+   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
+     :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl)))
+
+(defun operating-system ()
+  (first-feature
+   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
+     (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
+     (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
+     (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
+     :genera)))
+
+(defun architecture ()
+  (first-feature
+   '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
+     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
+     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
+     :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
+     :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
+     ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
+     ;; we may have to segregate the code still by architecture.
+     (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
+
+#+clozure
+(defun* ccl-fasl-version ()
+  ;; the fasl version is target-dependent from CCL 1.8 on.
+  (or (and (fboundp 'ccl::target-fasl-version)
+           (funcall 'ccl::target-fasl-version))
+      (and (boundp 'ccl::fasl-version)
+           (symbol-value 'ccl::fasl-version))
+      (error "Can't determine fasl version.")))
+
+(defun lisp-version-string ()
+  (let ((s (lisp-implementation-version)))
+    (car ; as opposed to OR, this idiom prevents some unreachable code warning
+     (list
+      #+allegro
+      (format nil "~A~A~@[~A~]"
+              excl::*common-lisp-version-number*
+              ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
+              (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
+              ;; Note if not using International ACL
+              ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
+              (excl:ics-target-case (:-ics "8")))
+      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
+      #+clisp
+      (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
+      #+clozure
+      (format nil "~d.~d-f~d" ; shorten for windows
+              ccl::*openmcl-major-version*
+              ccl::*openmcl-minor-version*
+              (logand (ccl-fasl-version) #xFF))
+      #+cmu (substitute #\- #\/ s)
+      #+scl (format nil "~A~A" s
+                    ;; ANSI upper case vs lower case.
+                    (ecase ext:*case-mode* (:upper "") (:lower "l")))
+      #+ecl (format nil "~A~@[-~A~]" s
+                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
+                      (subseq vcs-id 0 (min (length vcs-id) 8))))
+      #+gcl (subseq s (1+ (position #\space s)))
+      #+genera
+      (multiple-value-bind (major minor) (sct:get-system-version "System")
+        (format nil "~D.~D" major minor))
+      #+mcl (subseq s 8) ; strip the leading "Version "
+      s))))
 
 (defun* implementation-identifier ()
-  (labels
-      ((maybe-warn (value fstring &rest args)
-         (cond (value)
-               (t (apply #'warn fstring args)
-                  "unknown"))))
-    (let ((lisp (maybe-warn (implementation-type)
-                            "No implementation feature found in ~a."
-                            *implementation-features*))
-          (os   (maybe-warn (first-feature *os-features*)
-                            "No os feature found in ~a." *os-features*))
-          (arch (maybe-warn (first-feature *architecture-features*)
-                            "No architecture feature found in ~a."
-                            *architecture-features*))
-          (version (maybe-warn (lisp-version-string)
-                               "Don't know how to get Lisp implementation version.")))
-      (substitute-if
-       #\_ (lambda (x) (find x " /:\\(){}[]$#`'\""))
-       (format nil "~(~@{~a~^-~}~)" lisp version os arch)))))
-
+  (substitute-if
+   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
+   (format nil "~(~a~@{~@[-~a~]~}~)"
+           (or (implementation-type) (lisp-implementation-type))
+           (or (lisp-version-string) (lisp-implementation-version))
+           (or (operating-system) (software-type))
+           (or (architecture) (machine-type)))))
 
 
 ;;; ---------------------------------------------------------------------------
 ;;; Generic support for configuration files
 
-(defparameter *inter-directory-separator*
-  #+(or unix cygwin) #\:
-  #-(or unix cygwin) #\;)
+(defun inter-directory-separator ()
+  (if (os-unix-p) #\: #\;))
 
 (defun* user-homedir ()
-  (truename (user-homedir-pathname)))
-
-(defun* try-directory-subpath (x sub &key type)
-  (let* ((p (and x (ensure-directory-pathname x)))
-         (tp (and p (probe-file* p)))
-         (sp (and tp (merge-pathnames* (merge-component-name-type sub :type type) p)))
-         (ts (and sp (probe-file* sp))))
-    (and ts (values sp ts))))
+  (truenamize
+   (pathname-directory-pathname
+    #+mcl (current-user-homedir-pathname)
+    #-mcl (user-homedir-pathname))))
+
+(defun* ensure-absolute-pathname* (x fmt &rest args)
+  (and (plusp (length x))
+       (or (absolute-pathname-p x)
+           (cerror "ignore relative pathname"
+                   "Invalid relative pathname ~A~@[ ~?~]" x fmt args))
+       x))
+(defun* split-absolute-pathnames (x fmt &rest args)
+  (loop :for dir :in (split-string
+                      x :separator (string (inter-directory-separator)))
+    :do (apply 'ensure-absolute-pathname* dir fmt args)
+    :collect dir))
+(defun getenv-absolute-pathname (x &aux (s (getenv x)))
+  (ensure-absolute-pathname* s "from (getenv ~S)" x))
+(defun getenv-absolute-pathnames (x &aux (s (getenv x)))
+  (split-absolute-pathnames s "from (getenv ~S) = ~S" x s))
+
 (defun* user-configuration-directories ()
-  (remove-if
-   #'null
-   (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
-     `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
-       ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
-           :for dir :in (split-string dirs :separator ":")
-           :collect (try dir "common-lisp/"))
-       #+(and (or win32 windows mswindows mingw32) (not cygwin))
-        ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
-            ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
-           ,(try (getenv "APPDATA") "common-lisp/config/"))
-       ,(try (user-homedir) ".config/common-lisp/")))))
+  (let ((dirs
+         `(,@(when (os-unix-p)
+               (cons
+                (subpathname* (getenv-absolute-pathname "XDG_CONFIG_HOME") "common-lisp/")
+                (loop :for dir :in (getenv-absolute-pathnames "XDG_CONFIG_DIRS")
+                  :collect (subpathname* dir "common-lisp/"))))
+           ,@(when (os-windows-p)
+               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
+                                    (getenv-absolute-pathname "LOCALAPPDATA"))
+                               "common-lisp/config/")
+                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
+                                    (getenv-absolute-pathname "APPDATA"))
+                                "common-lisp/config/")))
+           ,(subpathname (user-homedir) ".config/common-lisp/"))))
+    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
+                       :from-end t :test 'equal)))
+
 (defun* system-configuration-directories ()
-  (remove-if
-   #'null
-   (append
-    #+(and (or win32 windows mswindows mingw32) (not cygwin))
-    (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
-      `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
-           ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
-        ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
-    (list #p"/etc/common-lisp/"))))
-(defun* in-first-directory (dirs x)
-  (loop :for dir :in dirs
-    :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
-(defun* in-user-configuration-directory (x)
-  (in-first-directory (user-configuration-directories) x))
-(defun* in-system-configuration-directory (x)
-  (in-first-directory (system-configuration-directories) x))
+  (cond
+    ((os-unix-p) '(#p"/etc/common-lisp/"))
+    ((os-windows-p)
+     (aif
+      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
+      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
+                        (getenv-absolute-pathname "ALLUSERSAPPDATA")
+                        (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/"))
+                    "common-lisp/config/")
+      (list it)))))
+
+(defun* in-first-directory (dirs x &key (direction :input))
+  (loop :with fun = (ecase direction
+                      ((nil :input :probe) 'probe-file*)
+                      ((:output :io) 'identity))
+    :for dir :in dirs
+    :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
+
+(defun* in-user-configuration-directory (x &key (direction :input))
+  (in-first-directory (user-configuration-directories) x :direction direction))
+(defun* in-system-configuration-directory (x &key (direction :input))
+  (in-first-directory (system-configuration-directories) x :direction direction))
 
 (defun* configuration-inheritance-directive-p (x)
   (let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
     (or (member x kw)
         (and (length=n-p x 1) (member (car x) kw)))))
 
+(defun* report-invalid-form (reporter &rest args)
+  (etypecase reporter
+    (null
+     (apply 'error 'invalid-configuration args))
+    (function
+     (apply reporter args))
+    ((or symbol string)
+     (apply 'error reporter args))
+    (cons
+     (apply 'apply (append reporter args)))))
+
+(defvar *ignored-configuration-form* nil)
+
 (defun* validate-configuration-form (form tag directive-validator
-                                    &optional (description tag))
+                                    &key location invalid-form-reporter)
   (unless (and (consp form) (eq (car form) tag))
-    (error "Error: Form doesn't specify ~A ~S~%" description form))
-  (loop :with inherit = 0
-    :for directive :in (cdr form) :do
-    (if (configuration-inheritance-directive-p directive)
-        (incf inherit)
-        (funcall directive-validator directive))
+    (setf *ignored-configuration-form* t)
+    (report-invalid-form invalid-form-reporter :form form :location location)
+    (return-from validate-configuration-form nil))
+  (loop :with inherit = 0 :with ignore-invalid-p = nil :with x = (list tag)
+    :for directive :in (cdr form)
+    :when (cond
+            ((configuration-inheritance-directive-p directive)
+             (incf inherit) t)
+            ((eq directive :ignore-invalid-entries)
+             (setf ignore-invalid-p t) t)
+            ((funcall directive-validator directive)
+             t)
+            (ignore-invalid-p
+             nil)
+            (t
+             (setf *ignored-configuration-form* t)
+             (report-invalid-form invalid-form-reporter :form directive :location location)
+             nil))
+    :do (push directive x)
     :finally
     (unless (= inherit 1)
-      (error "One and only one of ~S or ~S is required"
-             :inherit-configuration :ignore-inherited-configuration)))
-  form)
+      (report-invalid-form invalid-form-reporter
+             :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>")
+                              :inherit-configuration :ignore-inherited-configuration)))
+    (return (nreverse x))))
 
-(defun* validate-configuration-file (file validator description)
+(defun* validate-configuration-file (file validator &key description)
   (let ((forms (read-file-forms file)))
     (unless (length=n-p forms 1)
-      (error "One and only one form allowed for ~A. Got: ~S~%" description forms))
-    (funcall validator (car forms))))
+      (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%")
+             description forms))
+    (funcall validator (car forms) :location file)))
 
 (defun* hidden-file-p (pathname)
   (equal (first-char (pathname-name pathname)) #\.))
 
-(defun* validate-configuration-directory (directory tag validator)
+(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
+  (apply 'directory pathname-spec
+         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
+                             #+clozure '(:follow-links nil)
+                             #+clisp '(:circle t :if-does-not-exist :ignore)
+                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
+                             #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl)
+                                      '(:resolve-symlinks nil))))))
+
+(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
+  "Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
+be applied to the results to yield a configuration form.  Current
+values of TAG include :source-registry and :output-translations."
   (let ((files (sort (ignore-errors
                        (remove-if
                         'hidden-file-p
-                        (directory (make-pathname :name :wild :type "conf" :defaults directory)
-                                   #+sbcl :resolve-symlinks #+sbcl nil)))
+                        (directory* (make-pathname :name :wild :type "conf" :defaults directory))))
                      #'string< :key #'namestring)))
     `(,tag
       ,@(loop :for file :in files :append
-          (mapcar validator (read-file-forms file)))
+          (loop :with ignore-invalid-p = nil
+            :for form :in (read-file-forms file)
+            :when (eq form :ignore-invalid-entries)
+              :do (setf ignore-invalid-p t)
+            :else
+              :when (funcall validator form)
+                :collect form
+              :else
+                :when ignore-invalid-p
+                  :do (setf *ignored-configuration-form* t)
+                :else
+                  :do (report-invalid-form invalid-form-reporter :form form :location file)))
       :inherit-configuration)))
 
 
@@ -2646,14 +3318,14 @@ and the order is by decreasing length of namestring of the source pathname.")
 (defvar *user-cache*
   (flet ((try (x &rest sub) (and x `(,x , at sub))))
     (or
-     (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
-     #+(and (or win32 windows mswindows mingw32) (not cygwin))
-     (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
+     (try (getenv-absolute-pathname "XDG_CACHE_HOME") "common-lisp" :implementation)
+     (when (os-windows-p)
+       (try (or #+lispworks (sys:get-folder-path :local-appdata)
+                (getenv-absolute-pathname "LOCALAPPDATA")
+                #+lispworks (sys:get-folder-path :appdata)
+                (getenv-absolute-pathname "APPDATA"))
+            "common-lisp" "cache" :implementation))
      '(:home ".cache" "common-lisp" :implementation))))
-(defvar *system-cache*
-  ;; No good default, plus there's a security problem
-  ;; with other users messing with such directories.
-  *user-cache*)
 
 (defun* output-translations ()
   (car *output-translations*))
@@ -2662,11 +3334,12 @@ and the order is by decreasing length of namestring of the source pathname.")
   (setf *output-translations*
         (list
          (stable-sort (copy-list new-value) #'>
-                      :key (lambda (x)
-                             (etypecase (car x)
-                               ((eql t) -1)
-                               (pathname
-                                (length (pathname-directory (car x)))))))))
+                      :key #'(lambda (x)
+                               (etypecase (car x)
+                                 ((eql t) -1)
+                                 (pathname
+                                  (let ((directory (pathname-directory (car x))))
+                                    (if (listp directory) (length directory) 0))))))))
   new-value)
 
 (defun* output-translations-initialized-p ()
@@ -2679,131 +3352,157 @@ with a different configuration, so the configuration would be re-read then."
   (setf *output-translations* '())
   (values))
 
-(defparameter *wild-asd*
-  (make-pathname :directory '(:relative :wild-inferiors)
-                 :name :wild :type "asd" :version :newest))
-
-(declaim (ftype (function (t &optional boolean) (values (or null pathname) &optional))
+(declaim (ftype (function (t &key (:directory boolean) (:wilden boolean))
+                          (values (or null pathname) &optional))
                 resolve-location))
 
-(defun* resolve-relative-location-component (super x &optional wildenp)
-  (let* ((r (etypecase x
-              (pathname x)
-              (string x)
-              (cons
-               (let ((car (resolve-relative-location-component super (car x) nil)))
-                 (if (null (cdr x))
-                     car
-                     (let ((cdr (resolve-relative-location-component
-                                 (merge-pathnames* car super) (cdr x) wildenp)))
-                       (merge-pathnames* cdr car)))))
-              ((eql :default-directory)
-               (relativize-pathname-directory (default-directory)))
-              ((eql :implementation) (implementation-identifier))
-              ((eql :implementation-type) (string-downcase (implementation-type)))
-              #-(and (or win32 windows mswindows mingw32) (not cygwin))
-              ((eql :uid) (princ-to-string (get-uid)))))
-         (d (if (pathnamep x) r (ensure-directory-pathname r)))
-         (s (if (and wildenp (not (pathnamep x)))
-                (wilden d)
-                d)))
-    (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
-      (error "pathname ~S is not relative to ~S" s super))
-    (merge-pathnames* s super)))
-
-(defun* resolve-absolute-location-component (x wildenp)
+(defun* resolve-relative-location-component (x &key directory wilden)
+  (let ((r (etypecase x
+             (pathname x)
+             (string (coerce-pathname x :type (when directory :directory)))
+             (cons
+              (if (null (cdr x))
+                  (resolve-relative-location-component
+                   (car x) :directory directory :wilden wilden)
+                  (let* ((car (resolve-relative-location-component
+                               (car x) :directory t :wilden nil)))
+                    (merge-pathnames*
+                     (resolve-relative-location-component
+                      (cdr x) :directory directory :wilden wilden)
+                     car))))
+             ((eql :default-directory)
+              (relativize-pathname-directory (default-directory)))
+             ((eql :*/) *wild-directory*)
+             ((eql :**/) *wild-inferiors*)
+             ((eql :*.*.*) *wild-file*)
+             ((eql :implementation)
+              (coerce-pathname (implementation-identifier) :type :directory))
+             ((eql :implementation-type)
+              (coerce-pathname (string-downcase (implementation-type)) :type :directory)))))
+    (when (absolute-pathname-p r)
+      (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
+    (if (or (pathnamep x) (not wilden)) r (wilden r))))
+
+(defvar *here-directory* nil
+  "This special variable is bound to the currect directory during calls to
+PROCESS-SOURCE-REGISTRY in order that we be able to interpret the :here
+directive.")
+
+(defun* resolve-absolute-location-component (x &key directory wilden)
   (let* ((r
           (etypecase x
             (pathname x)
-            (string (ensure-directory-pathname x))
+            (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
+                      #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
+                      (if directory (ensure-directory-pathname p) p)))
             (cons
-             (let ((car (resolve-absolute-location-component (car x) nil)))
+             (return-from resolve-absolute-location-component
                (if (null (cdr x))
-                   car
-                   (let ((cdr (resolve-relative-location-component
-                               car (cdr x) wildenp)))
-                     (merge-pathnames* cdr car)))))
+                   (resolve-absolute-location-component
+                    (car x) :directory directory :wilden wilden)
+                   (merge-pathnames*
+                    (resolve-relative-location-component
+                     (cdr x) :directory directory :wilden wilden)
+                    (resolve-absolute-location-component
+                     (car x) :directory t :wilden nil)))))
             ((eql :root)
              ;; special magic! we encode such paths as relative pathnames,
              ;; but it means "relative to the root of the source pathname's host and device".
              (return-from resolve-absolute-location-component
-               (make-pathname :directory '(:relative))))
+               (let ((p (make-pathname :directory '(:relative))))
+                 (if wilden (wilden p) p))))
             ((eql :home) (user-homedir))
-            ((eql :user-cache) (resolve-location *user-cache* nil))
-            ((eql :system-cache) (resolve-location *system-cache* nil))
+            ((eql :here)
+             (resolve-location (or *here-directory*
+                                   ;; give semantics in the case of use interactively
+                                   :default-directory)
+                          :directory t :wilden nil))
+            ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
+            ((eql :system-cache)
+             (error "Using the :system-cache is deprecated. ~%~
+Please remove it from your ASDF configuration"))
             ((eql :default-directory) (default-directory))))
-         (s (if (and wildenp (not (pathnamep x)))
+         (s (if (and wilden (not (pathnamep x)))
                 (wilden r)
                 r)))
     (unless (absolute-pathname-p s)
-      (error "Not an absolute pathname ~S" s))
+      (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
     s))
 
-(defun* resolve-location (x &optional wildenp)
+(defun* resolve-location (x &key directory wilden)
   (if (atom x)
-      (resolve-absolute-location-component x wildenp)
-      (loop :with path = (resolve-absolute-location-component (car x) nil)
+      (resolve-absolute-location-component x :directory directory :wilden wilden)
+      (loop :with path = (resolve-absolute-location-component
+                          (car x) :directory (and (or directory (cdr x)) t)
+                          :wilden (and wilden (null (cdr x))))
         :for (component . morep) :on (cdr x)
-        :do (setf path (resolve-relative-location-component
-                        path component (and wildenp (not morep))))
+        :for dir = (and (or morep directory) t)
+        :for wild = (and wilden (not morep))
+        :do (setf path (merge-pathnames*
+                        (resolve-relative-location-component
+                         component :directory dir :wilden wild)
+                        path))
         :finally (return path))))
 
 (defun* location-designator-p (x)
-  (flet ((componentp (c) (typep c '(or string pathname keyword))))
-    (or (typep x 'boolean) (componentp x) (and (consp x) (every #'componentp x)))))
+  (flet ((absolute-component-p (c)
+           (typep c '(or string pathname
+                      (member :root :home :here :user-cache :system-cache :default-directory))))
+         (relative-component-p (c)
+           (typep c '(or string pathname
+                      (member :default-directory :*/ :**/ :*.*.*
+                        :implementation :implementation-type)))))
+    (or (typep x 'boolean)
+        (absolute-component-p x)
+        (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
 
 (defun* location-function-p (x)
   (and
-   (consp x)
    (length=n-p x 2)
-   (or (and (equal (first x) :function)
-            (typep (second x) 'symbol))
-       (and (equal (first x) 'lambda)
-            (cddr x)
-            (length=n-p (second x) 2)))))
+   (eq (car x) :function)
+   (or (symbolp (cadr x))
+       (and (consp (cadr x))
+            (eq (caadr x) 'lambda)
+            (length=n-p (cadadr x) 2)))))
 
 (defun* validate-output-translations-directive (directive)
-  (unless
-      (or (member directive '(:inherit-configuration
-                              :ignore-inherited-configuration
-                              :enable-user-cache :disable-cache nil))
-          (and (consp directive)
-               (or (and (length=n-p directive 2)
-                        (or (and (eq (first directive) :include)
-                                 (typep (second directive) '(or string pathname null)))
-                            (and (location-designator-p (first directive))
-                                 (or (location-designator-p (second directive))
-                                     (location-function-p (second directive))))))
-                   (and (length=n-p directive 1)
-                        (location-designator-p (first directive))))))
-    (error "Invalid directive ~S~%" directive))
-  directive)
-
-(defun* validate-output-translations-form (form)
+  (or (member directive '(:enable-user-cache :disable-cache nil))
+      (and (consp directive)
+           (or (and (length=n-p directive 2)
+                    (or (and (eq (first directive) :include)
+                             (typep (second directive) '(or string pathname null)))
+                        (and (location-designator-p (first directive))
+                             (or (location-designator-p (second directive))
+                                 (location-function-p (second directive))))))
+               (and (length=n-p directive 1)
+                    (location-designator-p (first directive)))))))
+
+(defun* validate-output-translations-form (form &key location)
   (validate-configuration-form
    form
    :output-translations
    'validate-output-translations-directive
-   "output translations"))
+   :location location :invalid-form-reporter 'invalid-output-translation))
 
 (defun* validate-output-translations-file (file)
   (validate-configuration-file
-   file 'validate-output-translations-form "output translations"))
+   file 'validate-output-translations-form :description "output translations"))
 
 (defun* validate-output-translations-directory (directory)
   (validate-configuration-directory
-   directory :output-translations 'validate-output-translations-directive))
+   directory :output-translations 'validate-output-translations-directive
+   :invalid-form-reporter 'invalid-output-translation))
 
-(defun* parse-output-translations-string (string)
+(defun* parse-output-translations-string (string &key location)
   (cond
     ((or (null string) (equal string ""))
      '(:output-translations :inherit-configuration))
     ((not (stringp string))
-     (error "environment string isn't: ~S" string))
+     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     ((eql (char string 0) #\")
-     (parse-output-translations-string (read-from-string string)))
+     (parse-output-translations-string (read-from-string string) :location location))
     ((eql (char string 0) #\()
-     (validate-output-translations-form (read-from-string string)))
+     (validate-output-translations-form (read-from-string string) :location location))
     (t
      (loop
       :with inherit = nil
@@ -2811,7 +3510,8 @@ with a different configuration, so the configuration would be re-read then."
       :with start = 0
       :with end = (length string)
       :with source = nil
-      :for i = (or (position *inter-directory-separator* string :start start) end) :do
+      :with separator = (inter-directory-separator)
+      :for i = (or (position separator string :start start) end) :do
       (let ((s (subseq string start i)))
         (cond
           (source
@@ -2819,7 +3519,8 @@ with a different configuration, so the configuration would be re-read then."
            (setf source nil))
           ((equal "" s)
            (when inherit
-             (error "only one inherited configuration allowed: ~S" string))
+             (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+                    string))
            (setf inherit t)
            (push :inherit-configuration directives))
           (t
@@ -2827,7 +3528,8 @@ with a different configuration, so the configuration would be re-read then."
         (setf start (1+ i))
         (when (> start end)
           (when source
-            (error "Uneven number of components in source to destination mapping ~S" string))
+            (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
+                   string))
           (unless inherit
             (push :ignore-inherited-configuration directives))
           (return `(:output-translations ,@(nreverse directives)))))))))
@@ -2843,28 +3545,30 @@ with a different configuration, so the configuration would be re-read then."
   `(:output-translations
     ;; Some implementations have precompiled ASDF systems,
     ;; so we must disable translations for implementation paths.
-    #+sbcl ,(let ((h (getenv "SBCL_HOME"))) (when (plusp (length h)) `(,h ())))
-    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
-    #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
+    #+sbcl ,(let ((h (getenv "SBCL_HOME")))
+                 (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
+    ;; The below two are not needed: no precompiled ASDF system there
+    ;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
+    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
     ;; These are for convenience, and can be overridden by the user:
     #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
     #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
-    ;; If we want to enable the user cache by default, here would be the place:
+    ;; We enable the user cache by default, and here is the place we do:
     :enable-user-cache))
 
-(defparameter *output-translations-file* #p"asdf-output-translations.conf")
-(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")
-
-(defun* user-output-translations-pathname ()
-  (in-user-configuration-directory *output-translations-file* ))
-(defun* system-output-translations-pathname ()
-  (in-system-configuration-directory *output-translations-file*))
-(defun* user-output-translations-directory-pathname ()
-  (in-user-configuration-directory *output-translations-directory*))
-(defun* system-output-translations-directory-pathname ()
-  (in-system-configuration-directory *output-translations-directory*))
+(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
+(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
+
+(defun* user-output-translations-pathname (&key (direction :input))
+  (in-user-configuration-directory *output-translations-file* :direction direction))
+(defun* system-output-translations-pathname (&key (direction :input))
+  (in-system-configuration-directory *output-translations-file* :direction direction))
+(defun* user-output-translations-directory-pathname (&key (direction :input))
+  (in-user-configuration-directory *output-translations-directory* :direction direction))
+(defun* system-output-translations-directory-pathname (&key (direction :input))
+  (in-system-configuration-directory *output-translations-directory* :direction direction))
 (defun* environment-output-translations ()
   (getenv "ASDF_OUTPUT_TRANSLATIONS"))
 
@@ -2883,7 +3587,7 @@ with a different configuration, so the configuration would be re-read then."
     ((directory-pathname-p pathname)
      (process-output-translations (validate-output-translations-directory pathname)
                                   :inherit inherit :collect collect))
-    ((probe-file pathname)
+    ((probe-file* pathname)
      (process-output-translations (validate-output-translations-file pathname)
                                   :inherit inherit :collect collect))
     (t
@@ -2911,7 +3615,7 @@ with a different configuration, so the configuration would be re-read then."
          (process-output-translations-directive '(t t) :collect collect))
         ((:inherit-configuration)
          (inherit-output-translations inherit :collect collect))
-        ((:ignore-inherited-configuration nil)
+        ((:ignore-inherited-configuration :ignore-invalid-entries nil)
          nil))
       (let ((src (first directive))
             (dst (second directive)))
@@ -2920,7 +3624,7 @@ with a different configuration, so the configuration would be re-read then."
               (process-output-translations (pathname dst) :inherit nil :collect collect))
             (when src
               (let ((trusrc (or (eql src t)
-                                (let ((loc (resolve-location src t)))
+                                (let ((loc (resolve-location src :directory t :wilden t)))
                                   (if (absolute-pathname-p loc) (truenamize loc) loc)))))
                 (cond
                   ((location-function-p dst)
@@ -2932,11 +3636,10 @@ with a different configuration, so the configuration would be re-read then."
                   ((eq dst t)
                    (funcall collect (list trusrc t)))
                   (t
-                   (let* ((trudst (make-pathname
-                                   :defaults (if dst (resolve-location dst t) trusrc)))
-                          (wilddst (make-pathname
-                                    :name :wild :type :wild :version :wild
-                                    :defaults trudst)))
+                   (let* ((trudst (if dst
+                                      (resolve-location dst :directory t :wilden t)
+                                      trusrc))
+                          (wilddst (merge-pathnames* *wild-file* trudst)))
                      (funcall collect (list wilddst t))
                      (funcall collect (list trusrc trudst)))))))))))
 
@@ -2948,10 +3651,13 @@ with a different configuration, so the configuration would be re-read then."
       `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
    :test 'equal :from-end t))
 
-(defun* initialize-output-translations (&optional parameter)
+(defvar *output-translations-parameter* nil)
+
+(defun* initialize-output-translations (&optional (parameter *output-translations-parameter*))
   "read the configuration, initialize the internal configuration variable,
 return the configuration"
-  (setf (output-translations) (compute-output-translations parameter)))
+  (setf *output-translations-parameter* parameter
+        (output-translations) (compute-output-translations parameter)))
 
 (defun* disable-output-translations ()
   "Initialize output translations in a way that maps every file to itself,
@@ -2976,7 +3682,7 @@ effectively disabling the output translation facility."
     ((eq destination t)
      path)
     ((not (pathnamep destination))
-     (error "invalid destination"))
+     (error "Invalid destination"))
     ((not (absolute-pathname-p destination))
      (translate-pathname path absolute-source (merge-pathnames* destination root)))
     (root
@@ -2985,6 +3691,7 @@ effectively disabling the output translation facility."
      (translate-pathname path absolute-source destination))))
 
 (defun* apply-output-translations (path)
+  #+cormanlisp (truenamize path) #-cormanlisp
   (etypecase path
     (logical-pathname
      path)
@@ -3006,7 +3713,7 @@ effectively disabling the output translation facility."
 
 (defmethod output-files :around (operation component)
   "Translate output files, unless asked not to"
-  (declare (ignorable operation component))
+  operation component ;; hush genera, not convinced by declare ignorable(!)
   (values
    (multiple-value-bind (files fixedp) (call-next-method)
      (if fixedp
@@ -3015,23 +3722,26 @@ effectively disabling the output translation facility."
    t))
 
 (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
-  (or output-file
+  (if (absolute-pathname-p output-file)
+      ;; what cfp should be doing, w/ mp* instead of mp
+      (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
+             (defaults (make-pathname
+                        :type type :defaults (merge-pathnames* input-file))))
+        (merge-pathnames* output-file defaults))
       (apply-output-translations
-       (apply 'compile-file-pathname
-              (truenamize (lispize-pathname input-file))
-              keys))))
+       (apply 'compile-file-pathname input-file keys))))
 
 (defun* tmpize-pathname (x)
   (make-pathname
-   :name (format nil "ASDF-TMP-~A" (pathname-name x))
+   :name (strcat "ASDF-TMP-" (pathname-name x))
    :defaults x))
 
 (defun* delete-file-if-exists (x)
-  (when (and x (probe-file x))
+  (when (and x (probe-file* x))
     (delete-file x)))
 
-(defun* compile-file* (input-file &rest keys &key &allow-other-keys)
-  (let* ((output-file (apply 'compile-file-pathname* input-file keys))
+(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
+  (let* ((output-file (apply 'compile-file-pathname* input-file :output-file output-file keys))
          (tmp-file (tmpize-pathname output-file))
          (status :error))
     (multiple-value-bind (output-truename warnings-p failure-p)
@@ -3071,198 +3781,227 @@ effectively disabling the output translation facility."
 ;;;; -----------------------------------------------------------------
 ;;;; Compatibility mode for ASDF-Binary-Locations
 
+(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
+  (declare (ignorable operation-class system args))
+  (when (find-symbol* '#:output-files-for-system-and-operation :asdf)
+    (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
+ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
+which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
+and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
+In case you insist on preserving your previous A-B-L configuration, but
+do not know how to achieve the same effect with A-O-T, you may use function
+ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
+call that function where you would otherwise have loaded and configured A-B-L.")))
+
 (defun* enable-asdf-binary-locations-compatibility
     (&key
      (centralize-lisp-binaries nil)
      (default-toplevel-directory
-         ;; Use ".cache/common-lisp" instead ???
-         (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
-                           (user-homedir)))
+         (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
      (include-per-user-information nil)
-     (map-all-source-files nil)
+     (map-all-source-files (or #+(or ecl clisp) t nil))
      (source-to-target-mappings nil))
+  #+(or ecl clisp)
+  (when (null map-all-source-files)
+    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
   (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
-         (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors)))
-         (mapped-files (make-pathname
-                        :name :wild :version :wild
-                        :type (if map-all-source-files :wild fasl-type)))
+         (mapped-files (if map-all-source-files *wild-file*
+                           (make-pathname :type fasl-type :defaults *wild-file*)))
          (destination-directory
           (if centralize-lisp-binaries
               `(,default-toplevel-directory
                 ,@(when include-per-user-information
                         (cdr (pathname-directory (user-homedir))))
-                :implementation ,wild-inferiors)
-              `(:root ,wild-inferiors :implementation))))
+                :implementation ,*wild-inferiors*)
+              `(:root ,*wild-inferiors* :implementation))))
     (initialize-output-translations
      `(:output-translations
        , at source-to-target-mappings
-       ((:root ,wild-inferiors ,mapped-files)
+       ((:root ,*wild-inferiors* ,mapped-files)
         (, at destination-directory ,mapped-files))
        (t t)
        :ignore-inherited-configuration))))
 
 ;;;; -----------------------------------------------------------------
-;;;; Windows shortcut support.  Based on:
-;;;;
-;;;; Jesse Hager: The Windows Shortcut File Format.
-;;;; http://www.wotsit.org/list.asp?fc=13
-
-#+(and (or win32 windows mswindows mingw32) (not cygwin) (not clisp))
-(progn
-(defparameter *link-initial-dword* 76)
-(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
-
-(defun* read-null-terminated-string (s)
-  (with-output-to-string (out)
-    (loop :for code = (read-byte s)
-      :until (zerop code)
-      :do (write-char (code-char code) out))))
-
-(defun* read-little-endian (s &optional (bytes 4))
-  (loop
-    :for i :from 0 :below bytes
-    :sum (ash (read-byte s) (* 8 i))))
-
-(defun* parse-file-location-info (s)
-  (let ((start (file-position s))
-        (total-length (read-little-endian s))
-        (end-of-header (read-little-endian s))
-        (fli-flags (read-little-endian s))
-        (local-volume-offset (read-little-endian s))
-        (local-offset (read-little-endian s))
-        (network-volume-offset (read-little-endian s))
-        (remaining-offset (read-little-endian s)))
-    (declare (ignore total-length end-of-header local-volume-offset))
-    (unless (zerop fli-flags)
-      (cond
-        ((logbitp 0 fli-flags)
-          (file-position s (+ start local-offset)))
-        ((logbitp 1 fli-flags)
-          (file-position s (+ start
-                              network-volume-offset
-                              #x14))))
-      (concatenate 'string
-        (read-null-terminated-string s)
-        (progn
-          (file-position s (+ start remaining-offset))
-          (read-null-terminated-string s))))))
-
-(defun* parse-windows-shortcut (pathname)
-  (with-open-file (s pathname :element-type '(unsigned-byte 8))
-    (handler-case
-        (when (and (= (read-little-endian s) *link-initial-dword*)
-                   (let ((header (make-array (length *link-guid*))))
-                     (read-sequence header s)
-                     (equalp header *link-guid*)))
-          (let ((flags (read-little-endian s)))
-            (file-position s 76)        ;skip rest of header
-            (when (logbitp 0 flags)
-              ;; skip shell item id list
-              (let ((length (read-little-endian s 2)))
-                (file-position s (+ length (file-position s)))))
-            (cond
-              ((logbitp 1 flags)
-                (parse-file-location-info s))
-              (t
-                (when (logbitp 2 flags)
-                  ;; skip description string
-                  (let ((length (read-little-endian s 2)))
-                    (file-position s (+ length (file-position s)))))
-                (when (logbitp 3 flags)
-                  ;; finally, our pathname
-                  (let* ((length (read-little-endian s 2))
-                         (buffer (make-array length)))
-                    (read-sequence buffer s)
-                    (map 'string #'code-char buffer)))))))
-      (end-of-file ()
-        nil)))))
-
-;;;; -----------------------------------------------------------------
 ;;;; Source Registry Configuration, by Francois-Rene Rideau
 ;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
 
 ;; Using ack 1.2 exclusions
 (defvar *default-source-registry-exclusions*
-  '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
+  '(".bzr" ".cdv"
+    ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
     ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
     "_sgbak" "autom4te.cache" "cover_db" "_build"
-    "debian")) ;; debian often build stuff under the debian directory... BAD.
+    "debian")) ;; debian often builds stuff under the debian directory... BAD.
 
 (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
 
-(defvar *source-registry* ()
-  "Either NIL (for uninitialized), or a list of one element,
-said element itself being a list of directory pathnames where to look for .asd files")
-
-(defun* source-registry ()
-  (car *source-registry*))
-
-(defun* (setf source-registry) (new-value)
-  (setf *source-registry* (list new-value))
-  new-value)
+(defvar *source-registry* nil
+  "Either NIL (for uninitialized), or an equal hash-table, mapping
+system names to pathnames of .asd files")
 
 (defun* source-registry-initialized-p ()
-  (and *source-registry* t))
+  (typep *source-registry* 'hash-table))
 
 (defun* clear-source-registry ()
   "Undoes any initialization of the source registry.
 You might want to call that before you dump an image that would be resumed
 with a different configuration, so the configuration would be re-read then."
-  (setf *source-registry* '())
+  (setf *source-registry* nil)
   (values))
 
+(defparameter *wild-asd*
+  (make-pathname :directory nil :name *wild* :type "asd" :version :newest))
+
+(defun* filter-logical-directory-results (directory entries merger)
+  (if (typep directory 'logical-pathname)
+      ;; Try hard to not resolve logical-pathname into physical pathnames;
+      ;; otherwise logical-pathname users/lovers will be disappointed.
+      ;; If directory* could use some implementation-dependent magic,
+      ;; we will have logical pathnames already; otherwise,
+      ;; we only keep pathnames for which specifying the name and
+      ;; translating the LPN commute.
+      (loop :for f :in entries
+        :for p = (or (and (typep f 'logical-pathname) f)
+                     (let* ((u (ignore-errors (funcall merger f))))
+                       ;; The first u avoids a cumbersome (truename u) error
+                       (and u (equal (ignore-errors (truename u)) f) u)))
+        :when p :collect p)
+      entries))
+
+(defun* directory-files (directory &optional (pattern *wild-file*))
+  (when (wild-pathname-p directory)
+    (error "Invalid wild in ~S" directory))
+  (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
+    (error "Invalid file pattern ~S" pattern))
+  (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
+    (filter-logical-directory-results
+     directory entries
+     #'(lambda (f)
+         (make-pathname :defaults directory
+                        :name (pathname-name f) :type (ununspecific (pathname-type f))
+                        :version (ununspecific (pathname-version f)))))))
+
+(defun* directory-asd-files (directory)
+  (directory-files directory *wild-asd*))
+
+(defun* subdirectories (directory)
+  (let* ((directory (ensure-directory-pathname directory))
+         #-(or abcl cormanlisp genera xcl)
+         (wild (merge-pathnames*
+                #-(or abcl allegro cmu lispworks sbcl scl xcl)
+                *wild-directory*
+                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
+                directory))
+         (dirs
+          #-(or abcl cormanlisp genera xcl)
+          (ignore-errors
+            (directory* wild . #.(or #+clozure '(:directories t :files nil)
+                                     #+mcl '(:directories t))))
+          #+(or abcl xcl) (system:list-directory directory)
+          #+cormanlisp (cl::directory-subdirs directory)
+          #+genera (fs:directory-list directory))
+         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
+         (dirs (loop :for x :in dirs
+                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
+                          #+allegro (excl:probe-directory x)
+                          #+(or cmu sbcl scl) (directory-pathname-p x)
+                          #+genera (getf (cdr x) :directory)
+                          #+lispworks (lw:file-directory-p x)
+                 :when d :collect #+(or abcl allegro xcl) d
+                                  #+genera (ensure-directory-pathname (first x))
+                                  #+(or cmu lispworks sbcl scl) x)))
+    (filter-logical-directory-results
+     directory dirs
+     (let ((prefix (normalize-pathname-directory-component
+                    (pathname-directory directory))))
+       #'(lambda (d)
+           (let ((dir (normalize-pathname-directory-component
+                       (pathname-directory d))))
+             (and (consp dir) (consp (cdr dir))
+                  (make-pathname
+                   :defaults directory :name nil :type nil :version nil
+                   :directory (append prefix (last dir))))))))))
+
+(defun* collect-asds-in-directory (directory collect)
+  (map () collect (directory-asd-files directory)))
+
+(defun* collect-sub*directories (directory collectp recursep collector)
+  (when (funcall collectp directory)
+    (funcall collector directory))
+  (dolist (subdir (subdirectories directory))
+    (when (funcall recursep subdir)
+      (collect-sub*directories subdir collectp recursep collector))))
+
+(defun* collect-sub*directories-asd-files
+    (directory &key
+     (exclude *default-source-registry-exclusions*)
+     collect)
+  (collect-sub*directories
+   directory
+   (constantly t)
+   #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal)))
+   #'(lambda (dir) (collect-asds-in-directory dir collect))))
+
 (defun* validate-source-registry-directive (directive)
-  (unless
-      (or (member directive '(:default-registry (:default-registry)) :test 'equal)
-          (destructuring-bind (kw &rest rest) directive
-            (case kw
-              ((:include :directory :tree)
-               (and (length=n-p rest 1)
-                    (typep (car rest) '(or pathname string null))))
-              ((:exclude :also-exclude)
-               (every #'stringp rest))
-              (null rest))))
-    (error "Invalid directive ~S~%" directive))
-  directive)
-
-(defun* validate-source-registry-form (form)
+  (or (member directive '(:default-registry))
+      (and (consp directive)
+           (let ((rest (rest directive)))
+             (case (first directive)
+               ((:include :directory :tree)
+                (and (length=n-p rest 1)
+                     (location-designator-p (first rest))))
+               ((:exclude :also-exclude)
+                (every #'stringp rest))
+               ((:default-registry)
+                (null rest)))))))
+
+(defun* validate-source-registry-form (form &key location)
   (validate-configuration-form
-   form :source-registry 'validate-source-registry-directive "a source registry"))
+   form :source-registry 'validate-source-registry-directive
+   :location location :invalid-form-reporter 'invalid-source-registry))
 
 (defun* validate-source-registry-file (file)
   (validate-configuration-file
-   file 'validate-source-registry-form "a source registry"))
+   file 'validate-source-registry-form :description "a source registry"))
 
 (defun* validate-source-registry-directory (directory)
   (validate-configuration-directory
-   directory :source-registry 'validate-source-registry-directive))
+   directory :source-registry 'validate-source-registry-directive
+   :invalid-form-reporter 'invalid-source-registry))
 
-(defun* parse-source-registry-string (string)
+(defun* parse-source-registry-string (string &key location)
   (cond
     ((or (null string) (equal string ""))
      '(:source-registry :inherit-configuration))
     ((not (stringp string))
-     (error "environment string isn't: ~S" string))
+     (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
     ((find (char string 0) "\"(")
-     (validate-source-registry-form (read-from-string string)))
+     (validate-source-registry-form (read-from-string string) :location location))
     (t
      (loop
       :with inherit = nil
       :with directives = ()
       :with start = 0
       :with end = (length string)
-      :for pos = (position *inter-directory-separator* string :start start) :do
+      :with separator = (inter-directory-separator)
+      :for pos = (position separator string :start start) :do
       (let ((s (subseq string start (or pos end))))
-        (cond
-         ((equal "" s) ; empty element: inherit
-          (when inherit
-            (error "only one inherited configuration allowed: ~S" string))
-          (setf inherit t)
-          (push ':inherit-configuration directives))
-         ((ends-with s "//")
-          (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
-         (t
-          (push `(:directory ,s) directives)))
+        (flet ((check (dir)
+                 (unless (absolute-pathname-p dir)
+                   (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
+                 dir))
+          (cond
+            ((equal "" s) ; empty element: inherit
+             (when inherit
+               (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+                      string))
+             (setf inherit t)
+             (push ':inherit-configuration directives))
+            ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
+             (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
+            (t
+             (push `(:directory ,(check s)) directives))))
         (cond
           (pos
            (setf start (1+ pos)))
@@ -3273,23 +4012,9 @@ with a different configuration, so the configuration would be re-read then."
 
 (defun* register-asd-directory (directory &key recurse exclude collect)
   (if (not recurse)
-      (funcall collect directory)
-      (let* ((files
-              (handler-case
-                  (directory (merge-pathnames* *wild-asd* directory)
-                             #+sbcl #+sbcl :resolve-symlinks nil
-                             #+clisp #+clisp :circle t)
-                (error (c)
-                  (warn "Error while scanning system definitions under directory ~S:~%~A"
-                        directory c)
-                  nil)))
-             (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files)
-                                      :test #'equal :from-end t)))
-        (loop
-          :for dir :in dirs
-          :unless (loop :for x :in exclude
-                    :thereis (find x (pathname-directory dir) :test #'equal))
-          :do (funcall collect dir)))))
+      (collect-asds-in-directory directory collect)
+      (collect-sub*directories-asd-files
+       directory :exclude exclude :collect collect)))
 
 (defparameter *default-source-registries*
   '(environment-source-registry
@@ -3299,48 +4024,44 @@ with a different configuration, so the configuration would be re-read then."
     system-source-registry-directory
     default-source-registry))
 
-(defparameter *source-registry-file* #p"source-registry.conf")
-(defparameter *source-registry-directory* #p"source-registry.conf.d/")
+(defparameter *source-registry-file* (coerce-pathname "source-registry.conf"))
+(defparameter *source-registry-directory* (coerce-pathname "source-registry.conf.d/"))
 
 (defun* wrapping-source-registry ()
   `(:source-registry
-    #+sbcl (:tree ,(getenv "SBCL_HOME"))
+    #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
     :inherit-configuration
-    #+cmu (:tree #p"modules:")))
+    #+cmu (:tree #p"modules:")
+    #+scl (:tree #p"file://modules/")))
 (defun* default-source-registry ()
-  (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
-    `(:source-registry
-      #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
-      (:directory ,(truenamize (directory-namestring *default-pathname-defaults*)))
-      ,@(let*
-         #+(or unix cygwin)
-         ((datahome
-           (or (getenv "XDG_DATA_HOME")
-               (try (user-homedir) ".local/share/")))
-          (datadirs
-           (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
-          (dirs (cons datahome (split-string datadirs :separator ":"))))
-         #+(and (or win32 windows mswindows mingw32) (not cygwin))
-         ((datahome (getenv "APPDATA"))
-          (datadir
-           #+lispworks (sys:get-folder-path :local-appdata)
-           #-lispworks (try (getenv "ALLUSERSPROFILE")
-                            "Application Data"))
-          (dirs (list datahome datadir)))
-         #-(or unix win32 windows mswindows mingw32 cygwin)
-         ((dirs ()))
-         (loop :for dir :in dirs
-           :collect `(:directory ,(try dir "common-lisp/systems/"))
-           :collect `(:tree ,(try dir "common-lisp/source/"))))
-      :inherit-configuration)))
-(defun* user-source-registry ()
-  (in-user-configuration-directory *source-registry-file*))
-(defun* system-source-registry ()
-  (in-system-configuration-directory *source-registry-file*))
-(defun* user-source-registry-directory ()
-  (in-user-configuration-directory *source-registry-directory*))
-(defun* system-source-registry-directory ()
-  (in-system-configuration-directory *source-registry-directory*))
+  `(:source-registry
+    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
+    (:directory ,(default-directory))
+      ,@(loop :for dir :in
+          `(,@(when (os-unix-p)
+                `(,(or (getenv-absolute-pathname "XDG_DATA_HOME")
+                       (subpathname (user-homedir) ".local/share/"))
+                  ,@(or (getenv-absolute-pathnames "XDG_DATA_DIRS")
+                        '("/usr/local/share" "/usr/share"))))
+            ,@(when (os-windows-p)
+                `(,(or #+lispworks (sys:get-folder-path :local-appdata)
+                       (getenv-absolute-pathname "LOCALAPPDATA"))
+                  ,(or #+lispworks (sys:get-folder-path :appdata)
+                       (getenv-absolute-pathname "APPDATA"))
+                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
+                       (getenv-absolute-pathname "ALLUSERSAPPDATA")
+                       (subpathname* (getenv-absolute-pathname "ALLUSERSPROFILE") "Application Data/")))))
+          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+      :inherit-configuration))
+(defun* user-source-registry (&key (direction :input))
+  (in-user-configuration-directory *source-registry-file* :direction direction))
+(defun* system-source-registry (&key (direction :input))
+  (in-system-configuration-directory *source-registry-file* :direction direction))
+(defun* user-source-registry-directory (&key (direction :input))
+  (in-user-configuration-directory *source-registry-directory* :direction direction))
+(defun* system-source-registry-directory (&key (direction :input))
+  (in-system-configuration-directory *source-registry-directory* :direction direction))
 (defun* environment-source-registry ()
   (getenv "CL_SOURCE_REGISTRY"))
 
@@ -3355,11 +4076,13 @@ with a different configuration, so the configuration would be re-read then."
 (defmethod process-source-registry ((pathname pathname) &key inherit register)
   (cond
     ((directory-pathname-p pathname)
-     (process-source-registry (validate-source-registry-directory pathname)
-                              :inherit inherit :register register))
-    ((probe-file pathname)
-     (process-source-registry (validate-source-registry-file pathname)
-                              :inherit inherit :register register))
+     (let ((*here-directory* (truenamize pathname)))
+       (process-source-registry (validate-source-registry-directory pathname)
+                                :inherit inherit :register register)))
+    ((probe-file* pathname)
+     (let ((*here-directory* (pathname-directory-pathname pathname)))
+       (process-source-registry (validate-source-registry-file pathname)
+                                :inherit inherit :register register)))
     (t
      (inherit-source-registry inherit :register register))))
 (defmethod process-source-registry ((string string) &key inherit register)
@@ -3382,15 +4105,16 @@ with a different configuration, so the configuration would be re-read then."
     (ecase kw
       ((:include)
        (destructuring-bind (pathname) rest
-         (process-source-registry (pathname pathname) :inherit nil :register register)))
+         (process-source-registry (resolve-location pathname) :inherit nil :register register)))
       ((:directory)
        (destructuring-bind (pathname) rest
          (when pathname
-           (funcall register (ensure-directory-pathname pathname)))))
+           (funcall register (resolve-location pathname :directory t)))))
       ((:tree)
        (destructuring-bind (pathname) rest
          (when pathname
-           (funcall register (ensure-directory-pathname pathname) :recurse t :exclude *source-registry-exclusions*))))
+           (funcall register (resolve-location pathname :directory t)
+                    :recurse t :exclude *source-registry-exclusions*))))
       ((:exclude)
        (setf *source-registry-exclusions* rest))
       ((:also-exclude)
@@ -3406,26 +4130,52 @@ with a different configuration, so the configuration would be re-read then."
 (defun* flatten-source-registry (&optional parameter)
   (remove-duplicates
    (while-collecting (collect)
-     (inherit-source-registry
-      `(wrapping-source-registry
-        ,parameter
-        ,@*default-source-registries*)
-      :register (lambda (directory &key recurse exclude)
-                  (collect (list directory :recurse recurse :exclude exclude)))))
+     (let ((*default-pathname-defaults* (default-directory)))
+       (inherit-source-registry
+        `(wrapping-source-registry
+          ,parameter
+          ,@*default-source-registries*)
+        :register #'(lambda (directory &key recurse exclude)
+                      (collect (list directory :recurse recurse :exclude exclude))))))
    :test 'equal :from-end t))
 
-;; Will read the configuration and initialize all internal variables,
-;; and return the new configuration.
-(defun* compute-source-registry (&optional parameter)
-  (while-collecting (collect)
-    (dolist (entry (flatten-source-registry parameter))
-      (destructuring-bind (directory &key recurse exclude) entry
+;; Will read the configuration and initialize all internal variables.
+(defun* compute-source-registry (&optional parameter (registry *source-registry*))
+  (dolist (entry (flatten-source-registry parameter))
+    (destructuring-bind (directory &key recurse exclude) entry
+      (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
         (register-asd-directory
-         directory
-         :recurse recurse :exclude exclude :collect #'collect)))))
+         directory :recurse recurse :exclude exclude :collect
+         #'(lambda (asd)
+             (let* ((name (pathname-name asd))
+                    (name (if (typep asd 'logical-pathname)
+                              ;; logical pathnames are upper-case,
+                              ;; at least in the CLHS and on SBCL,
+                              ;; yet (coerce-name :foo) is lower-case.
+                              ;; won't work well with (load-system "Foo")
+                              ;; instead of (load-system 'foo)
+                              (string-downcase name)
+                              name)))
+               (cond
+                 ((gethash name registry) ; already shadowed by something else
+                  nil)
+                 ((gethash name h) ; conflict at current level
+                  (when *asdf-verbose*
+                    (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
+                                found several entries for ~A - picking ~S over ~S~:>")
+                          directory recurse name (gethash name h) asd)))
+                 (t
+                  (setf (gethash name registry) asd)
+                  (setf (gethash name h) asd))))))
+        h)))
+  (values))
 
-(defun* initialize-source-registry (&optional parameter)
-  (setf (source-registry) (compute-source-registry parameter)))
+(defvar *source-registry-parameter* nil)
+
+(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
+  (setf *source-registry-parameter* parameter)
+  (setf *source-registry* (make-hash-table :test 'equal))
+  (compute-source-registry parameter))
 
 ;; Checks an initial variable to see whether the state is initialized
 ;; or cleared. In the former case, return current configuration; in
@@ -3436,46 +4186,86 @@ with a different configuration, so the configuration would be re-read then."
 ;; you may override the configuration explicitly by calling
 ;; initialize-source-registry directly with your parameter.
 (defun* ensure-source-registry (&optional parameter)
-  (if (source-registry-initialized-p)
-      (source-registry)
-      (initialize-source-registry parameter)))
+  (unless (source-registry-initialized-p)
+    (initialize-source-registry parameter))
+  (values))
 
 (defun* sysdef-source-registry-search (system)
   (ensure-source-registry)
-  (loop :with name = (coerce-name system)
-    :for defaults :in (source-registry)
-    :for file = (probe-asd name defaults)
-    :when file :return file))
+  (values (gethash (coerce-name system) *source-registry*)))
 
 (defun* clear-configuration ()
   (clear-source-registry)
   (clear-output-translations))
 
+
+;;; ECL support for COMPILE-OP / LOAD-OP
+;;;
+;;; In ECL, these operations produce both FASL files and the
+;;; object files that they are built from. Having both of them allows
+;;; us to later on reuse the object files for bundles, libraries,
+;;; standalone executables, etc.
+;;;
+;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
+;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
+;;;
+#+ecl
+(progn
+  (setf *compile-op-compile-file-function* 'ecl-compile-file)
+
+  (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
+    (if (use-ecl-byte-compiler-p)
+        (apply 'compile-file* input-file keys)
+        (multiple-value-bind (object-file flags1 flags2)
+            (apply 'compile-file* input-file :system-p t keys)
+          (values (and object-file
+                       (c::build-fasl (compile-file-pathname object-file :type :fasl)
+                                      :lisp-files (list object-file))
+                       object-file)
+                  flags1
+                  flags2))))
+
+  (defmethod output-files ((operation compile-op) (c cl-source-file))
+    (declare (ignorable operation))
+    (let* ((p (lispize-pathname (component-pathname c)))
+           (f (compile-file-pathname p :type :fasl)))
+      (if (use-ecl-byte-compiler-p)
+          (list f)
+          (list (compile-file-pathname p :type :object) f))))
+
+  (defmethod perform ((o load-op) (c cl-source-file))
+    (map () #'load
+         (loop :for i :in (input-files o c)
+           :unless (string= (pathname-type i) "fas")
+               :collect (compile-file-pathname (lispize-pathname i))))))
+
 ;;;; -----------------------------------------------------------------
-;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL
+;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
 ;;;;
+(defvar *require-asdf-operator* 'load-op)
+
 (defun* module-provide-asdf (name)
   (handler-bind
       ((style-warning #'muffle-warning)
+       #-genera
        (missing-component (constantly nil))
-       (error (lambda (e)
-                (format *error-output* "ASDF could not load ~(~A~) because ~A.~%"
-                        name e))))
-    (let* ((*verbose-out* (make-broadcast-stream))
-           (system (find-system (string-downcase name) nil)))
+       (error #'(lambda (e)
+                  (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
+                          name e))))
+    (let ((*verbose-out* (make-broadcast-stream))
+          (system (find-system (string-downcase name) nil)))
       (when system
-        (load-system system)
+        (operate *require-asdf-operator* system :verbose nil)
         t))))
 
 #+(or abcl clisp clozure cmu ecl sbcl)
-(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom))))
+(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
   (when x
     (eval `(pushnew 'module-provide-asdf
             #+abcl sys::*module-provider-functions*
             #+clisp ,x
             #+clozure ccl:*module-provider-functions*
-            #+cmu ext:*module-provider-functions*
-            #+ecl si:*module-provider-functions*
+            #+(or cmu ecl) ext:*module-provider-functions*
             #+sbcl sb-ext:*module-provider-functions*))))
 
 
@@ -3484,17 +4274,11 @@ with a different configuration, so the configuration would be re-read then."
 ;;;; Things to do in case we're upgrading from a previous version of ASDF.
 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
 ;;;;
-;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  #+ecl ;; Support upgrade from before ECL went to 1.369
-  (when (fboundp 'compile-op-system-p)
-    (defmethod compile-op-system-p ((op compile-op))
-      (getf :system-p (compile-op-flags op)))
-    (defmethod initialize-instance :after ((op compile-op)
-                                           &rest initargs
-                                           &key system-p &allow-other-keys)
-      (declare (ignorable initargs))
-      (when system-p (appendf (compile-op-flags op) (list :system-p system-p))))))
+
+;;; If a previous version of ASDF failed to read some configuration, try again.
+(when *ignored-configuration-form*
+  (clear-configuration)
+  (setf *ignored-configuration-form* nil))
 
 ;;;; -----------------------------------------------------------------
 ;;;; Done!
diff --git a/contrib/toolbar.lisp b/contrib/toolbar.lisp
index 22b9464..c2d6280 100644
--- a/contrib/toolbar.lisp
+++ b/contrib/toolbar.lisp
@@ -225,7 +225,7 @@
       (get-decoded-time)
     (declare (ignore s))
     (toolbar-draw-text toolbar (second module) (/ *toolbar-default-thickness* 2)
-                       (format nil "~A:~A" h m))))
+                       (format nil "~2,'0D:~2,'0D" h m))))
 
 
 (define-toolbar-module (label)
diff --git a/load.lisp b/load.lisp
index 7955af5..9985ac9 100644
--- a/load.lisp
+++ b/load.lisp
@@ -53,6 +53,8 @@
 
 (push *base-dir* asdf:*central-registry*)
 
+;;(setf asdf:*verbose-out* t)
+
 ;;;; Uncomment the line above if you want to follow the
 ;;;; handle event mecanism.
 ;;(pushnew :event-debug *features*)

-----------------------------------------------------------------------

Summary of changes:
 contrib/asdf.lisp    | 3362 +++++++++++++++++++++++++++++++-------------------
 contrib/toolbar.lisp |    2 +-
 load.lisp            |    2 +
 3 files changed, 2076 insertions(+), 1290 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Sun Jun  3 20:58:55 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Sun, 03 Jun 2012 13:58:55 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch master updated. R-1106-58-g1e5611e
Message-ID: <E1SbHt1-0002CQ-O5@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, master has been updated
       via  1e5611e4818034b5dc32938ea5a4675e96d2d20f (commit)
       via  45192056686a6053098c861562b757f944db5fd0 (commit)
       via  0ff435ca00f6ab1f2e434087dfa38048a1527808 (commit)
       via  6f96f0da9f45ee751c3fd7e4d4ad5c687d3eeb22 (commit)
      from  0b64c55b92c7212fcc2e25b9efd37dc75f608975 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
-----------------------------------------------------------------------

Summary of changes:
 ChangeLog                 |   13 +
 contrib/asdf.lisp         | 3362 ++++++++++++++++++++++++++++-----------------
 contrib/toolbar.lisp      |  144 ++-
 contrib/volume-mode.lisp  |   17 +-
 load.lisp                 |    2 +
 src/clfswm-placement.lisp |  114 +-
 src/clfswm.lisp           |    4 +
 7 files changed, 2268 insertions(+), 1388 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Wed Jun  6 21:05:32 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Wed, 06 Jun 2012 14:05:32 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-59-gc389dc8
Message-ID: <E1ScNQ4-00086T-5g@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  c389dc88d4f97b76b873d6ceeff625a79cc4a343 (commit)
      from  1e5611e4818034b5dc32938ea5a4675e96d2d20f (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit c389dc88d4f97b76b873d6ceeff625a79cc4a343
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Wed Jun 6 23:05:26 2012 +0200

    src/xlib-util.lisp (handle-event): Add an additional hook event system to handle events in contrib code.

diff --git a/ChangeLog b/ChangeLog
index af5e2df..f9a2014 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-06-06  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* src/xlib-util.lisp (handle-event): Add an additional hook event
+	system to handle events in contrib code.
+
 2012-06-03  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* src/clfswm-placement.lisp: Add an optional border size in all
diff --git a/contrib/toolbar.lisp b/contrib/toolbar.lisp
index c2d6280..7f78336 100644
--- a/contrib/toolbar.lisp
+++ b/contrib/toolbar.lisp
@@ -108,22 +108,34 @@
       (:vert (vert-text)))))
 
 
+
+(defun refresh-toolbar (toolbar)
+  (add-timer (toolbar-refresh-delay toolbar)
+             (lambda ()
+               (refresh-toolbar toolbar))
+             :refresh-toolbar)
+  (clear-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar))
+  (dolist (module (toolbar-modules toolbar))
+    (let ((fun (toolbar-symbol-fun (first module))))
+      (when (fboundp fun)
+        (funcall fun toolbar module))))
+  (copy-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar)))
+
+
+(create-event-hook :exposure)
+
+(defun define-toolbar-hooks (toolbar)
+  (define-event-hook :exposure (window)
+    (when (and (xlib:window-p window) (xlib:window-equal (toolbar-window toolbar) window))
+      (refresh-toolbar toolbar))))
+
+
+
+
 (let ((windows-list nil))
   (defun is-toolbar-window-p (win)
     (and (xlib:window-p win) (member win windows-list :test 'xlib:window-equal)))
 
-  (defun refresh-toolbar (toolbar)
-    (add-timer (toolbar-refresh-delay toolbar)
-               (lambda ()
-                 (refresh-toolbar toolbar))
-               :refresh-toolbar)
-    (clear-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar))
-    (dolist (module (toolbar-modules toolbar))
-      (let ((fun (toolbar-symbol-fun (first module))))
-        (when (fboundp fun)
-          (funcall fun toolbar module))))
-    (copy-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar)))
-
   (defun close-toolbar (toolbar)
     (erase-timer :refresh-toolbar-window)
     (setf *never-managed-window-list*
@@ -175,7 +187,8 @@
               (map-window (toolbar-window toolbar))
               (raise-window (toolbar-window toolbar))
               (refresh-toolbar toolbar)
-              (xlib:display-finish-output *display*))))))))
+              (xlib:display-finish-output *display*)
+              (define-toolbar-hooks toolbar))))))))
 
 (defun open-all-toolbars ()
   "Open all toolbars"
diff --git a/src/clfswm.lisp b/src/clfswm.lisp
index 51a44ed..241cec1 100644
--- a/src/clfswm.lisp
+++ b/src/clfswm.lisp
@@ -292,6 +292,7 @@
 	(xlib:free-pixmap *pixmap-buffer*)
         (destroy-all-frames-window)
 	(call-hook *close-hook*)
+        (clear-event-hooks)
 	(xlib:close-display *display*)
 	#+:event-debug
 	(format t "~2&Unhandled events: ~A~%" *unhandled-events*))))
diff --git a/src/tools.lisp b/src/tools.lisp
index 63678d0..40af0b9 100644
--- a/src/tools.lisp
+++ b/src/tools.lisp
@@ -228,7 +228,9 @@ Return the result of the last hook"
 		 (typecase hook
 		   (cons (dolist (h hook)
 			   (rec h)))
-		   (t (setf result (apply hook args)))))))
+                   (function (setf result (apply hook args)))
+		   (symbol (when (fboundp hook)
+                             (setf result (apply hook args))))))))
       (rec hook)
       result)))
 
@@ -236,14 +238,14 @@ Return the result of the last hook"
 (defmacro add-new-hook (hook &rest value)
   "Add a hook. Duplicate it if needed"
   `(setf ,hook (append (typecase ,hook
-			 (list ,hook)
-			 (t (list ,hook)))
-		       (list , at value))))
+                         (list ,hook)
+                         (t (list ,hook)))
+                       (list , at value))))
 
 (defmacro add-hook (hook &rest value)
   "Add a hook only if not duplicated"
   (let ((i (gensym)))
-    `(dolist (,i (list , at value) ,hook)
+    `(dolist (,i (list , at value))
        (unless (member ,i (typecase ,hook
                             (list ,hook)
                             (t (list ,hook))))
diff --git a/src/xlib-util.lisp b/src/xlib-util.lisp
index 7e42730..6c4fcff 100644
--- a/src/xlib-util.lisp
+++ b/src/xlib-util.lisp
@@ -170,36 +170,63 @@ Expand in handle-event-fun-main-mode-key-press"
      , at body))
 
 
+(defun event-hook-name (event-keyword)
+  (create-symbol '*event- event-keyword '-hook*))
 
-;;; Workaround for pixmap error taken from STUMPWM - thanks:
-;; XXX: In both the clisp and sbcl clx libraries, sometimes what
-;; should be a window will be a pixmap instead. In this case, we
-;; need to manually translate it to a window to avoid breakage
-;; in stumpwm. So far the only slot that seems to be affected is
-;; the :window slot for configure-request and reparent-notify
-;; events. It appears as though the hash table of XIDs and clx
-;; structures gets out of sync with X or perhaps X assigns a
-;; duplicate ID for a pixmap and a window.
-(defun make-xlib-window (xobject)
-  "For some reason the clx xid cache screws up returns pixmaps when
-they should be windows. So use this function to make a window out of them."
-  #+clisp (make-instance 'xlib:window :id (slot-value xobject 'xlib::id) :display *display*)
-  #+(or sbcl ecl openmcl) (xlib::make-window :id (slot-value xobject 'xlib::id) :display *display*)
-  #-(or sbcl clisp ecl openmcl)
-  (error 'not-implemented))
+(let ((event-hook-list nil))
+  (defmacro create-event-hook (event-keyword)
+    (let ((symb (event-hook-name event-keyword)))
+      (pushnew symb event-hook-list)
+      `(defvar ,symb nil)))
+
+  (defmacro add-event-hook (name &rest value)
+    (let ((symb (event-hook-name name)))
+      `(add-hook ,symb , at value)))
+
+  (defun clear-event-hooks ()
+    (dolist (symb event-hook-list)
+      (makunbound symb))))
+
+
+(defmacro define-event-hook (event-keyword args &body body)
+  `(add-event-hook ,event-keyword
+                   (lambda (&rest event-slots &key #+:event-debug event-key , at args &allow-other-keys)
+                     (declare (ignorable event-slots))
+                     #+:event-debug (print (list ,event-keyword event-key))
+                     , at body)))
 
 
 (defun handle-event (&rest event-slots &key event-key &allow-other-keys)
-  (with-xlib-protect ()
-    (let ((win (getf event-slots :window)))
-      (when (and win (not (xlib:window-p win)))
-        (dbg "Pixmap Workaround! Should be a window: " win)
-        (setf (getf event-slots :window) (make-xlib-window win))))
-    (if (fboundp event-key)
-	(apply event-key event-slots)
-	#+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal))
-    (xlib:display-finish-output *display*))
-  t)
+  (labels ((make-xlib-window (xobject)
+             "For some reason the clx xid cache screws up returns pixmaps when
+they should be windows. So use this function to make a window out of them."
+             ;; Workaround for pixmap error taken from STUMPWM - thanks:
+             ;; XXX: In both the clisp and sbcl clx libraries, sometimes what
+             ;; should be a window will be a pixmap instead. In this case, we
+             ;; need to manually translate it to a window to avoid breakage
+             ;; in stumpwm. So far the only slot that seems to be affected is
+             ;; the :window slot for configure-request and reparent-notify
+             ;; events. It appears as though the hash table of XIDs and clx
+             ;; structures gets out of sync with X or perhaps X assigns a
+             ;; duplicate ID for a pixmap and a window.
+             #+clisp (make-instance 'xlib:window :id (slot-value xobject 'xlib::id) :display *display*)
+             #+(or sbcl ecl openmcl) (xlib::make-window :id (slot-value xobject 'xlib::id) :display *display*)
+             #-(or sbcl clisp ecl openmcl)
+             (error 'not-implemented)))
+    (with-xlib-protect ()
+      (catch 'exit-handle-event
+        (let ((win (getf event-slots :window)))
+          (when (and win (not (xlib:window-p win)))
+            (dbg "Pixmap Workaround! Should be a window: " win)
+            (setf (getf event-slots :window) (make-xlib-window win))))
+        (let ((hook-symbol (event-hook-name event-key)))
+          (when (boundp hook-symbol)
+            (call-hook (symbol-value hook-symbol) event-slots)))
+        (if (fboundp event-key)
+            (apply event-key event-slots)
+            #+:event-debug (pushnew (list *current-event-mode* event-key) *unhandled-events* :test #'equal)))
+      (xlib:display-finish-output *display*))
+    t))
 
 
 

-----------------------------------------------------------------------

Summary of changes:
 ChangeLog            |    5 +++
 contrib/toolbar.lisp |   39 ++++++++++++++++--------
 src/clfswm.lisp      |    1 +
 src/tools.lisp       |   12 ++++---
 src/xlib-util.lisp   |   79 +++++++++++++++++++++++++++++++++----------------
 5 files changed, 92 insertions(+), 44 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Thu Jun  7 20:50:58 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Thu, 07 Jun 2012 13:50:58 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-60-g7057baa
Message-ID: <E1ScjfW-0002fX-SC@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  7057baaaf3e5dc4372b8385534b540a12edbadcd (commit)
      from  c389dc88d4f97b76b873d6ceeff625a79cc4a343 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 7057baaaf3e5dc4372b8385534b540a12edbadcd
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Thu Jun 7 22:50:51 2012 +0200

    contrib/toolbar.lisp (define-toolbar-hooks): Add auto-hide clickable toolbar.

diff --git a/ChangeLog b/ChangeLog
index f9a2014..acaf844 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-06-07  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* contrib/toolbar.lisp (define-toolbar-hooks): Add auto-hide
+	clickable toolbar.
+
 2012-06-06  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* src/xlib-util.lisp (handle-event): Add an additional hook event
diff --git a/contrib/toolbar.lisp b/contrib/toolbar.lisp
index 7f78336..9df8750 100644
--- a/contrib/toolbar.lisp
+++ b/contrib/toolbar.lisp
@@ -57,6 +57,8 @@
   'Toolbar "Toolbar default refresh delay")
 (defconfig *toolbar-default-autohide* nil
   'Toolbar "Toolbar default autohide value")
+(defconfig *toolbar-sensibility* 3
+  'Toolbar "Toolbar sensibility in pixels")
 
 (defconfig *toolbar-window-placement* 'top-left-placement
   'Placement "Toolbar window placement")
@@ -121,14 +123,59 @@
         (funcall fun toolbar module))))
   (copy-pixmap-buffer (toolbar-window toolbar) (toolbar-gc toolbar)))
 
-
-(create-event-hook :exposure)
-
-(defun define-toolbar-hooks (toolbar)
+(defun toolbar-in-sensibility-zone-p (toolbar root-x root-y)
+  (let* ((tb-win (toolbar-window toolbar))
+         (win-x (xlib:drawable-x tb-win))
+         (win-y (xlib:drawable-y tb-win))
+         (width (xlib:drawable-width tb-win))
+         (height (xlib:drawable-height tb-win))
+         (tb-dir (toolbar-direction toolbar) )
+         (placement-name (symbol-name (toolbar-placement toolbar))))
+    (or (and (equal tb-dir :horiz) (search "TOP" placement-name)
+             (<= root-y win-y (+ root-y *toolbar-sensibility*))
+             (<= win-x root-x (+ win-x width)) (toolbar-autohide toolbar))
+        (and (equal tb-dir :horiz) (search "BOTTOM" placement-name)
+             (<= (+ win-y height) root-y (+ win-y height *toolbar-sensibility*))
+             (<= win-x root-x (+ win-x width)) (toolbar-autohide toolbar))
+        (and (equal tb-dir :vert) (search "LEFT" placement-name)
+             (<= root-x win-x (+ root-x *toolbar-sensibility*))
+             (<= win-y root-y (+ win-y height)) (toolbar-autohide toolbar))
+        (and (equal tb-dir :vert) (search "RIGHT" placement-name)
+             (<= (+ win-x width) root-x (+ win-x win-x *toolbar-sensibility*))
+             (<= win-y root-y (+ win-y height)) (toolbar-autohide toolbar)))))
+
+(use-event-hook :exposure)
+(use-event-hook :button-press)
+
+
+(defun toolbar-add-exposure-hook (toolbar)
   (define-event-hook :exposure (window)
     (when (and (xlib:window-p window) (xlib:window-equal (toolbar-window toolbar) window))
       (refresh-toolbar toolbar))))
 
+(defun toolbar-add-hide-button-press-hook (toolbar)
+  (let ((hide t))
+    (define-event-hook :button-press (code root-x root-y)
+      (when (= code 1)
+        (let* ((tb-win (toolbar-window toolbar)))
+          (when (toolbar-in-sensibility-zone-p toolbar root-x root-y)
+            (if hide
+                (progn
+                  (map-window tb-win)
+                  (raise-window tb-win)
+                  (refresh-toolbar toolbar))
+                (hide-window tb-win))
+            (setf hide (not hide))
+            (wait-mouse-button-release)
+            (stop-button-event)
+            (throw 'exit-handle-event nil)))))))
+
+(defun define-toolbar-hooks (toolbar)
+  (toolbar-add-exposure-hook toolbar)
+  (case (toolbar-autohide toolbar)
+    (:click (toolbar-add-hide-button-press-hook toolbar))))
+
+
 
 
 
@@ -184,9 +231,10 @@
               (push (toolbar-window toolbar) windows-list)
               (setf (window-transparency (toolbar-window toolbar)) *toolbar-window-transparency*)
               (push (list #'is-toolbar-window-p nil) *never-managed-window-list*)
-              (map-window (toolbar-window toolbar))
-              (raise-window (toolbar-window toolbar))
-              (refresh-toolbar toolbar)
+              (unless (toolbar-autohide toolbar)
+                (map-window (toolbar-window toolbar))
+                (raise-window (toolbar-window toolbar))
+                (refresh-toolbar toolbar))
               (xlib:display-finish-output *display*)
               (define-toolbar-hooks toolbar))))))))
 
@@ -232,6 +280,10 @@
 
 
 
+
+;;;
+;;; Modules definitions
+;;;
 (define-toolbar-module (clock)
   "The clock module"
   (multiple-value-bind (s m h)
diff --git a/src/xlib-util.lisp b/src/xlib-util.lisp
index 6c4fcff..b77ad4c 100644
--- a/src/xlib-util.lisp
+++ b/src/xlib-util.lisp
@@ -174,7 +174,7 @@ Expand in handle-event-fun-main-mode-key-press"
   (create-symbol '*event- event-keyword '-hook*))
 
 (let ((event-hook-list nil))
-  (defmacro create-event-hook (event-keyword)
+  (defmacro use-event-hook (event-keyword)
     (let ((symb (event-hook-name event-keyword)))
       (pushnew symb event-hook-list)
       `(defvar ,symb nil)))

-----------------------------------------------------------------------

Summary of changes:
 ChangeLog            |    5 ++++
 contrib/toolbar.lisp |   66 ++++++++++++++++++++++++++++++++++++++++++++-----
 src/xlib-util.lisp   |    2 +-
 3 files changed, 65 insertions(+), 8 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Thu Jun  7 21:49:06 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Thu, 07 Jun 2012 14:49:06 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-61-g76075c2
Message-ID: <E1SckZm-00051S-VD@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  76075c217d62ae600da3460ef62687966d6e3fbc (commit)
      from  7057baaaf3e5dc4372b8385534b540a12edbadcd (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 76075c217d62ae600da3460ef62687966d6e3fbc
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Thu Jun 7 23:49:01 2012 +0200

    (define-toolbar-hooks): Add auto-hide toolbar (show/hide on mouse motion event).

diff --git a/ChangeLog b/ChangeLog
index acaf844..e0ffc64 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,8 @@
 
 	* contrib/toolbar.lisp (define-toolbar-hooks): Add auto-hide
 	clickable toolbar.
+	(define-toolbar-hooks): Add auto-hide toolbar (show/hide on mouse
+	motion event).
 
 2012-06-06  Philippe Brochard  <pbrochard at common-lisp.net>
 
diff --git a/contrib/toolbar.lisp b/contrib/toolbar.lisp
index 9df8750..1e6552e 100644
--- a/contrib/toolbar.lisp
+++ b/contrib/toolbar.lisp
@@ -146,6 +146,8 @@
 
 (use-event-hook :exposure)
 (use-event-hook :button-press)
+(use-event-hook :motion-notify)
+(use-event-hook :leave-notify)
 
 
 (defun toolbar-add-exposure-hook (toolbar)
@@ -170,10 +172,27 @@
             (stop-button-event)
             (throw 'exit-handle-event nil)))))))
 
+(defun toolbar-add-hide-motion-hook (toolbar)
+  (define-event-hook :motion-notify (root-x root-y)
+    (unless (compress-motion-notify)
+      (when (toolbar-in-sensibility-zone-p toolbar root-x root-y)
+        (map-window (toolbar-window toolbar))
+        (raise-window (toolbar-window toolbar))
+        (refresh-toolbar toolbar)
+        (throw 'exit-handle-event nil)))))
+
+(defun toolbar-add-hide-leave-hook (toolbar)
+  (define-event-hook :leave-notify (window)
+    (when (xlib:window-equal (toolbar-window toolbar) window)
+      (hide-window window)
+      (throw 'exit-handle-event nil))))
+
 (defun define-toolbar-hooks (toolbar)
   (toolbar-add-exposure-hook toolbar)
   (case (toolbar-autohide toolbar)
-    (:click (toolbar-add-hide-button-press-hook toolbar))))
+    (:click (toolbar-add-hide-button-press-hook toolbar))
+    (:motion (toolbar-add-hide-motion-hook toolbar)
+             (toolbar-add-hide-leave-hook toolbar))))
 
 
 
@@ -222,7 +241,7 @@
                                                                  :border (when (plusp (toolbar-border-size toolbar))
                                                                            (get-color *toolbar-window-border*))
                                                                  :colormap (xlib:screen-default-colormap *screen*)
-                                                                 :event-mask '(:exposure :key-press))
+                                                                 :event-mask '(:exposure :key-press :leave-window))
                     (toolbar-gc toolbar) (xlib:create-gcontext :drawable (toolbar-window toolbar)
                                                                :foreground (get-color *toolbar-window-foreground*)
                                                                :background (get-color *toolbar-window-background*)
@@ -231,10 +250,11 @@
               (push (toolbar-window toolbar) windows-list)
               (setf (window-transparency (toolbar-window toolbar)) *toolbar-window-transparency*)
               (push (list #'is-toolbar-window-p nil) *never-managed-window-list*)
-              (unless (toolbar-autohide toolbar)
-                (map-window (toolbar-window toolbar))
-                (raise-window (toolbar-window toolbar))
-                (refresh-toolbar toolbar))
+              (map-window (toolbar-window toolbar))
+              (raise-window (toolbar-window toolbar))
+              (refresh-toolbar toolbar);)
+              (when (toolbar-autohide toolbar)
+                (hide-window (toolbar-window toolbar)))
               (xlib:display-finish-output *display*)
               (define-toolbar-hooks toolbar))))))))
 
@@ -250,7 +270,8 @@
     (close-toolbar toolbar)))
 
 
-(defun add-toolbar (root-x root-y direction size placement &rest modules)
+(defun add-toolbar (root-x root-y direction size placement modules
+                    &key (autohide *toolbar-default-autohide*))
   "Add a new toolbar.
      root-x, root-y: root coordinates
      direction: one of :horiz or :vert
@@ -259,7 +280,7 @@
                       :direction direction :size size
                       :thickness *toolbar-default-thickness*
                       :placement placement
-                      :autohide *toolbar-default-autohide*
+                      :autohide autohide
                       :refresh-delay *toolbar-default-refresh-delay*
                       :border-size *toolbar-default-border-size*
                       :modules modules)))
diff --git a/src/clfswm-internal.lisp b/src/clfswm-internal.lisp
index 2606087..a3017d6 100644
--- a/src/clfswm-internal.lisp
+++ b/src/clfswm-internal.lisp
@@ -1488,7 +1488,8 @@ managed."
 	      (wm-state (window-state win)))
 	  (unless (or (eql (xlib:window-override-redirect win) :on)
 		      (eql win *no-focus-window*)
-                      (is-notify-window-p win))
+                      (is-notify-window-p win)
+                      (never-managed-window-p win))
 	    (when (or (eql map-state :viewable)
 		      (eql wm-state +iconic-state+))
 	      (format t "Processing ~S: type=~A ~S~%" (xlib:wm-name win) (window-type win) win)
diff --git a/src/xlib-util.lisp b/src/xlib-util.lisp
index b77ad4c..a1731ad 100644
--- a/src/xlib-util.lisp
+++ b/src/xlib-util.lisp
@@ -36,6 +36,7 @@
 				:colormap-change
 				:focus-change
 				:enter-window
+                                :leave-window
 				:exposure)
   "The events to listen for on managed windows.")
 

-----------------------------------------------------------------------

Summary of changes:
 ChangeLog                |    2 ++
 contrib/toolbar.lisp     |   37 +++++++++++++++++++++++++++++--------
 src/clfswm-internal.lisp |    3 ++-
 src/xlib-util.lisp       |    1 +
 4 files changed, 34 insertions(+), 9 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Fri Jun  8 20:23:13 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Fri, 08 Jun 2012 13:23:13 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-62-gf9c2f34
Message-ID: <E1Sd5iC-0000pD-Sq@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  f9c2f34e12e8ff76170edc0732514dcc61362938 (commit)
      from  76075c217d62ae600da3460ef62687966d6e3fbc (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit f9c2f34e12e8ff76170edc0732514dcc61362938
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Fri Jun 8 22:23:06 2012 +0200

    src/tools.lisp (process-timers): Call get-internal-real-time only once for all times.

diff --git a/ChangeLog b/ChangeLog
index e0ffc64..d58317a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-06-08  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* src/tools.lisp (process-timers): Call get-internal-real-time
+	only once for all times.
+
 2012-06-07  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* contrib/toolbar.lisp (define-toolbar-hooks): Add auto-hide
diff --git a/src/package.lisp b/src/package.lisp
index b06f767..3979c96 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -76,7 +76,7 @@ It is particulary useful with CLISP/MIT-CLX.")
 (defparameter *background-image* nil)
 (defparameter *background-gc* nil)
 
-(defconfig *loop-timeout* 0.1 nil
+(defconfig *loop-timeout* 1 nil
            "Maximum time (in seconds) to wait before calling *loop-hook*")
 
 (defparameter *pixmap-buffer* nil)
diff --git a/src/tools.lisp b/src/tools.lisp
index 40af0b9..e958fb9 100644
--- a/src/tools.lisp
+++ b/src/tools.lisp
@@ -278,8 +278,8 @@ Return the result of the last hook"
   "Start the function fun at delay seconds."
   (push (list id
 	      (let ((time (+ (get-internal-real-time) (s->realtime delay))))
-		(lambda ()
-		  (when (>= (get-internal-real-time) time)
+		(lambda (current-time)
+		  (when (>= current-time time)
 		    (funcall fun)
 		    t))))
 	*timer-list*)
@@ -299,34 +299,31 @@ Return the result of the last hook"
 
 (defun process-timers ()
   "Call each timers in *timer-list* if needed"
-  (dolist (timer *timer-list*)
-    (when (funcall (second timer))
-      (setf *timer-list* (remove timer *timer-list* :test #'equal)))))
+  (let ((current-time (get-internal-real-time)))
+    (dolist (timer *timer-list*)
+      (when (funcall (second timer) current-time)
+        (setf *timer-list* (remove timer *timer-list* :test #'equal))))))
 
 (defun erase-timer (id)
   "Erase the timer identified by its id"
-  (dolist (timer *timer-list*)
-    (when (equal id (first timer))
-      (setf *timer-list* (remove timer *timer-list* :test #'equal)))))
+  (setf *timer-list* (remove id *timer-list* :test (lambda (x y)
+                                                     (equal x (first y))))))
 
 (defun timer-test-loop ()
-  (loop
-     (princ ".") (force-output)
-     (process-timers)
-     (sleep 0.5)))
-
-;;(defun plop ()
-;;  (princ 'plop)
-;;  (erase-timer :toto))
-;;
-;;(defun toto ()
-;;  (princ 'toto)
-;;  (add-timer 5 #'toto :toto))
-;;
-;;(add-timer 5 #'toto :toto)
-;;(add-timer 30 #'plop)
-;;
-;;(timer-test-loop)
+  (let ((count 0))
+    (labels ((plop ()
+               (format t "Plop-~A" count)
+               (erase-timer :toto))
+             (toto ()
+               (format t "Toto-~A" count)
+               (add-timer 3 #'toto :toto)))
+      (add-timer 3 #'toto :toto)
+      (add-timer 13 #'plop)
+      (loop
+         (princ ".") (force-output)
+         (process-timers)
+         (sleep 0.5)
+         (incf count)))))
 
 
 

-----------------------------------------------------------------------

Summary of changes:
 ChangeLog        |    5 +++++
 src/package.lisp |    2 +-
 src/tools.lisp   |   47 ++++++++++++++++++++++-------------------------
 3 files changed, 28 insertions(+), 26 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Tue Jun 12 20:13:18 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Tue, 12 Jun 2012 13:13:18 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-63-g92c06b8
Message-ID: <E1SeXSn-0008Va-Nm@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  92c06b8c12a4e3cf3adfd9868ad16974a0fe604c (commit)
      from  f9c2f34e12e8ff76170edc0732514dcc61362938 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 92c06b8c12a4e3cf3adfd9868ad16974a0fe604c
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Tue Jun 12 22:13:10 2012 +0200

    contrib/toolbar.lisp: beginning of clickable modules

diff --git a/contrib/toolbar.lisp b/contrib/toolbar.lisp
index 1e6552e..17e2ad7 100644
--- a/contrib/toolbar.lisp
+++ b/contrib/toolbar.lisp
@@ -33,7 +33,7 @@
 (format t "Loading Toolbar code... ")
 
 (defstruct toolbar root-x root-y root direction size thickness placement refresh-delay
-           autohide modules font window gc border-size)
+           autohide modules clickable font window gc border-size)
 
 (defparameter *toolbar-list* nil)
 (defparameter *toolbar-module-list* nil)
@@ -57,7 +57,7 @@
   'Toolbar "Toolbar default refresh delay")
 (defconfig *toolbar-default-autohide* nil
   'Toolbar "Toolbar default autohide value")
-(defconfig *toolbar-sensibility* 3
+(defconfig *toolbar-sensibility* 10
   'Toolbar "Toolbar sensibility in pixels")
 
 (defconfig *toolbar-window-placement* 'top-left-placement
@@ -135,13 +135,13 @@
              (<= root-y win-y (+ root-y *toolbar-sensibility*))
              (<= win-x root-x (+ win-x width)) (toolbar-autohide toolbar))
         (and (equal tb-dir :horiz) (search "BOTTOM" placement-name)
-             (<= (+ win-y height) root-y (+ win-y height *toolbar-sensibility*))
+             (<= (+ win-y height (- *toolbar-sensibility*)) root-y (+ win-y height))
              (<= win-x root-x (+ win-x width)) (toolbar-autohide toolbar))
         (and (equal tb-dir :vert) (search "LEFT" placement-name)
              (<= root-x win-x (+ root-x *toolbar-sensibility*))
              (<= win-y root-y (+ win-y height)) (toolbar-autohide toolbar))
         (and (equal tb-dir :vert) (search "RIGHT" placement-name)
-             (<= (+ win-x width) root-x (+ win-x win-x *toolbar-sensibility*))
+             (<= (+ win-x width (- *toolbar-sensibility*)) root-x (+ win-x width))
              (<= win-y root-y (+ win-y height)) (toolbar-autohide toolbar)))))
 
 (use-event-hook :exposure)
@@ -182,18 +182,28 @@
         (throw 'exit-handle-event nil)))))
 
 (defun toolbar-add-hide-leave-hook (toolbar)
-  (define-event-hook :leave-notify (window)
-    (when (xlib:window-equal (toolbar-window toolbar) window)
+  (define-event-hook :leave-notify (window root-x root-y)
+    (when (and (xlib:window-equal (toolbar-window toolbar) window)
+               (not (in-window (toolbar-window toolbar) root-x root-y)))
       (hide-window window)
       (throw 'exit-handle-event nil))))
 
 (defun define-toolbar-hooks (toolbar)
   (toolbar-add-exposure-hook toolbar)
+  (when (toolbar-clickable toolbar)
+    (define-event-hook :button-press (code root-x root-y)
+      (dbg code root-x root-y)))
   (case (toolbar-autohide toolbar)
     (:click (toolbar-add-hide-button-press-hook toolbar))
     (:motion (toolbar-add-hide-motion-hook toolbar)
              (toolbar-add-hide-leave-hook toolbar))))
 
+(defun set-clickable-toolbar (toolbar)
+  (dolist (module *toolbar-module-list*)
+    (when (and (member (first module) (toolbar-modules toolbar)
+                       :test (lambda (x y) (equal x (first y))))
+               (second module))
+      (setf (toolbar-clickable toolbar) t))))
 
 
 
@@ -252,10 +262,11 @@
               (push (list #'is-toolbar-window-p nil) *never-managed-window-list*)
               (map-window (toolbar-window toolbar))
               (raise-window (toolbar-window toolbar))
-              (refresh-toolbar toolbar);)
+              (refresh-toolbar toolbar)
               (when (toolbar-autohide toolbar)
                 (hide-window (toolbar-window toolbar)))
               (xlib:display-finish-output *display*)
+              (set-clickable-toolbar toolbar)
               (define-toolbar-hooks toolbar))))))))
 
 (defun open-all-toolbars ()
@@ -292,10 +303,10 @@
 (add-hook *close-hook* 'close-all-toolbars)
 
 
-(defmacro define-toolbar-module ((name) &body body)
+(defmacro define-toolbar-module ((name &optional clickable) &body body)
   (let ((symbol-fun (toolbar-symbol-fun name)))
     `(progn
-       (pushnew ',name *toolbar-module-list*)
+       (pushnew (list ',name ,clickable) *toolbar-module-list*)
        (defun ,symbol-fun (toolbar module)
          , at body))))
 
@@ -320,4 +331,13 @@
                      "Label"))
 
 
+(define-toolbar-module (clickable-clock t)
+  "The clock module (clickable)"
+  (multiple-value-bind (s m h)
+      (get-decoded-time)
+    (declare (ignore s))
+    (toolbar-draw-text toolbar (second module) (/ *toolbar-default-thickness* 2)
+                       (format nil "Click:~2,'0D:~2,'0D" h m))))
+
+
 (format t "done~%")
diff --git a/src/clfswm-placement.lisp b/src/clfswm-placement.lisp
index d7e3d01..242bc91 100644
--- a/src/clfswm-placement.lisp
+++ b/src/clfswm-placement.lisp
@@ -35,9 +35,11 @@
 	 (values 0 0 width height)))
     (t (values 0 0 width height))))
 
-(defmacro with-placement ((placement x y &optional (width 0) (height 0) (border-size *border-size*)) &body body)
+(defmacro with-placement ((placement x y &optional (width 0) (height 0) border-size) &body body)
   `(multiple-value-bind (,x ,y width height)
-       (get-placement-values ,placement ,width ,height ,border-size)
+       ,(if border-size
+            `(get-placement-values ,placement ,width ,height ,border-size)
+            `(get-placement-values ,placement ,width ,height))
      (declare (ignorable width height))
      , at body))
 
@@ -70,7 +72,7 @@
 
 (defun top-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (values (- (xlib:screen-width *screen*) width (* border-size 2))
-	  0
+          0
           width height))
 
 
@@ -89,23 +91,23 @@
 
 (defun middle-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (values (- (xlib:screen-width *screen*) width (* border-size 2))
-	  (truncate (/ (- (xlib:screen-height *screen*) height) 2))
+          (truncate (/ (- (xlib:screen-height *screen*) height) 2))
           width height))
 
 
 (defun bottom-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (values 0
-	  (- (xlib:screen-height *screen*) height (* border-size 2))
+          (- (xlib:screen-height *screen*) height (* border-size 2))
           width height))
 
 (defun bottom-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
-	  (- (xlib:screen-height *screen*) height (* border-size 2))
+          (- (xlib:screen-height *screen*) height (* border-size 2))
           width height))
 
 (defun bottom-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (values (- (xlib:screen-width *screen*) width (* border-size 2))
-	  (- (xlib:screen-height *screen*) height (* border-size 2))
+          (- (xlib:screen-height *screen*) height (* border-size 2))
           width height))
 
 
@@ -239,8 +241,8 @@
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x border-size 1)
-              (+ y border-size 1)
+      (values (+ x border-size)
+              (+ y border-size)
               width height))))
 
 (defun top-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
@@ -248,15 +250,15 @@
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
       (values (+ x (truncate (/ (- w width) 2)))
-              (+ y border-size 1)
+              (+ y border-size)
               width height))))
 
 (defun top-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x (- w width border-size 1))
-              (+ y border-size 1)
+      (values (+ x (- w width border-size))
+              (+ y border-size)
               width height))))
 
 
@@ -265,7 +267,7 @@
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x border-size 1)
+      (values (+ x border-size)
               (+ y (truncate (/ (- h height) 2)))
               width height))))
 
@@ -274,15 +276,15 @@
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-    (values (+ x (truncate (/ (- w width) 2)))
-	    (+ y (truncate (/ (- h height) 2)))
-            width height))))
+      (values (+ x (truncate (/ (- w width) 2)))
+              (+ y (truncate (/ (- h height) 2)))
+              width height))))
 
 (defun middle-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x (- w width border-size 1))
+      (values (+ x (- w width border-size))
               (+ y (truncate (/ (- h height) 2)))
               width height))))
 
@@ -291,8 +293,8 @@
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x border-size 1)
-              (+ y (- h height border-size 1))
+      (values (+ x border-size)
+              (+ y (- h height border-size))
               width height))))
 
 (defun bottom-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
@@ -300,14 +302,14 @@
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
       (values (+ x (truncate (/ (- w width) 2)))
-              (+ y (- h height border-size 1))
+              (+ y (- h height border-size))
               width height))))
 
 (defun bottom-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
   (with-current-root-coord (x y w h)
     (let ((width (min (- w 4) width))
           (height (min (- h 4) height)))
-      (values (+ x (- w width border-size 1))
-              (+ y (- h height border-size 1))
+      (values (+ x (- w width border-size))
+              (+ y (- h height border-size))
               width height))))
 

-----------------------------------------------------------------------

Summary of changes:
 contrib/toolbar.lisp      |   38 ++++++++++++++++++++++++++++--------
 src/clfswm-placement.lisp |   46 +++++++++++++++++++++++---------------------
 2 files changed, 53 insertions(+), 31 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Mon Jun 18 19:55:12 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Mon, 18 Jun 2012 12:55:12 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-64-ge9afcbc
Message-ID: <E1Sgi2a-0004QA-Dg@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  e9afcbc29bc68c2939eaf4b852a86558f3d9c669 (commit)
      from  92c06b8c12a4e3cf3adfd9868ad16974a0fe604c (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit e9afcbc29bc68c2939eaf4b852a86558f3d9c669
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Mon Jun 18 21:55:06 2012 +0200

    src/clfswm-placement.lisp: Each child can have its own border size. New binding to change the child border size on the fly.

diff --git a/ChangeLog b/ChangeLog
index d58317a..c4231cd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-06-18  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* src/clfswm-placement.lisp: Each child can have its own border
+	size. New binding to change the child border size on the fly.
+
 2012-06-08  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* src/tools.lisp (process-timers): Call get-internal-real-time
diff --git a/src/clfswm-internal.lisp b/src/clfswm-internal.lisp
index a3017d6..af41d01 100644
--- a/src/clfswm-internal.lisp
+++ b/src/clfswm-internal.lisp
@@ -27,6 +27,32 @@
 
 
 
+(defgeneric child-border-size (child))
+
+(defmethod child-border-size ((child frame))
+  (x-drawable-border-width (frame-window child)))
+
+(defmethod child-border-size ((child xlib:window))
+  (x-drawable-border-width child))
+
+(defmethod child-border-size (child)
+  0)
+
+(defgeneric set-child-border-size (child value))
+
+(defmethod set-child-border-size ((child frame) value)
+  (setf (x-drawable-border-width (frame-window child)) value))
+
+(defmethod set-child-border-size ((child xlib:window) value)
+  (setf (x-drawable-border-width child) value))
+
+(defmethod set-child-border-size (child value)
+  (declare (ignore child value)))
+
+(defsetf child-border-size set-child-border-size)
+
+
+
 ;;; Conversion functions
 ;;; Float -> Pixel conversion
 (defun x-fl->px (x parent)
@@ -48,11 +74,11 @@
 ;;; Pixel -> Float conversion
 (defun x-px->fl (x parent)
   "Convert pixel X coordinate to float"
-  (/ (- x (frame-rx parent) *border-size*) (frame-rw parent)))
+  (/ (- x (frame-rx parent) (child-border-size parent)) (frame-rw parent)))
 
 (defun y-px->fl (y parent)
   "Convert pixel Y coordinate to float"
-  (/ (- y (frame-ry parent) *border-size*) (frame-rh parent)))
+  (/ (- y (frame-ry parent) (child-border-size parent)) (frame-rh parent)))
 
 (defun w-px->fl (w parent)
   "Convert pixel Width coordinate to float"
@@ -270,7 +296,6 @@
 
 
 
-
 (defgeneric child-x (child))
 (defmethod child-x ((child xlib:window))
   (x-drawable-x child))
@@ -604,8 +629,7 @@
 
   (defun unsure-at-least-one-root ()
     (unless root-list
-      (define-as-root *root-frame* (- *border-size*) (- *border-size*)
-                      (xlib:screen-width *screen*) (xlib:screen-height *screen*))))
+      (define-as-root *root-frame* 0 0 (xlib:screen-width *screen*) (xlib:screen-height *screen*))))
 
   (defun find-root-by-coordinates (x y)
     (dolist (root root-list)
@@ -754,7 +778,7 @@ XINERAMA version 1.1 opcode: 150
            do (when (search " head " line)
                 (destructuring-bind (w h x y)
                     (parse-xinerama-info line)
-                  (push (list (- x *border-size*) (- y *border-size*) w h) sizes))))
+                  (push (list x y w h) sizes))))
         (dbg sizes)
         (remove-duplicates sizes :test #'equal)))))
 
@@ -766,22 +790,22 @@ XINERAMA version 1.1 opcode: 150
         (height (xlib:screen-height *screen*)))
     ;;(add-placed-frame-tmp (first (frame-child *root-frame*)) 2)
     (if (<= (length sizes) 1)
-        (define-as-root *root-frame* (- *border-size*) (- *border-size*) width height)
-        (progn
-          (loop while (< (length (frame-child *root-frame*)) (length sizes))
-             do (let ((frame (create-frame)))
-                  ;;(add-placed-frame-tmp frame 2)))
-                  (add-frame frame *root-frame*)))
-          (loop for size in sizes
-             for frame in (frame-child *root-frame*)
-             do (destructuring-bind (x y w h) size
-                  (setf (frame-x frame) (float (/ x width))
-                        (frame-y frame) (float (/ y height))
-                        (frame-w frame) (float (/ w width))
-                        (frame-h frame) (float (/ h height)))
-                  (add-frame (create-frame) frame)
-                  (define-as-root frame x y w h)))
-          (setf (current-child) (first (frame-child (first (frame-child *root-frame*)))))))))
+        (define-as-root *root-frame* 0 0 width height))
+    (progn
+      (loop while (< (length (frame-child *root-frame*)) (length sizes))
+         do (let ((frame (create-frame)))
+              ;;(add-placed-frame-tmp frame 2)))
+              (add-frame frame *root-frame*)))
+      (loop for size in sizes
+         for frame in (frame-child *root-frame*)
+         do (destructuring-bind (x y w h) size
+              (setf (frame-x frame) (float (/ x width))
+                    (frame-y frame) (float (/ y height))
+                    (frame-w frame) (float (/ w width))
+                    (frame-h frame) (float (/ h height)))
+              (add-frame (create-frame) frame)
+              (define-as-root frame x y w h)))
+      (setf (current-child) (first (frame-child (first (frame-child *root-frame*))))))))
 
 
 
@@ -879,17 +903,16 @@ XINERAMA version 1.1 opcode: 150
   (declare (ignore child name)))
 
 
-
-
 (defun get-parent-layout (child parent)
   (aif (child-root-p child)
-       (values (root-x it) (root-y it) (root-w it) (root-h it))
+       (values (- (root-x it) (child-border-size child)) (- (root-y it) (child-border-size child))
+               (root-w it) (root-h it))
        (if (or (frame-p child) (managed-window-p child parent))
            (if (frame-p parent)
                (aif (frame-layout parent)
                     (funcall it child parent)
                     (no-layout child parent))
-               (values (- *border-size*) (- *border-size*)
+               (values (- (child-border-size child)) (- (child-border-size child))
                        (xlib:screen-width *screen*)
                        (xlib:screen-height *screen*)))
            (values (x-drawable-x child) (x-drawable-y child)
diff --git a/src/clfswm-layout.lisp b/src/clfswm-layout.lisp
index e8dafad..83953fc 100644
--- a/src/clfswm-layout.lisp
+++ b/src/clfswm-layout.lisp
@@ -156,14 +156,14 @@
 
 (defmethod no-layout ((child xlib:window) parent)
   (with-slots (rx ry rw rh) parent
-    (values (adj-border-xy rx child)
-	    (adj-border-xy ry child)
+    (values (adj-border-xy rx parent)
+	    (adj-border-xy ry parent)
 	    (adj-border-wh rw child)
 	    (adj-border-wh rh child))))
 
 (defmethod no-layout ((child frame) parent)
-  (values (adj-border-xy (x-fl->px (frame-x child) parent) child)
-	  (adj-border-xy (y-fl->px (frame-y child) parent) child)
+  (values (adj-border-xy (x-fl->px (frame-x child) parent) parent)
+	  (adj-border-xy (y-fl->px (frame-y child) parent) parent)
 	  (adj-border-wh (w-fl->px (frame-w child) parent) child)
           (adj-border-wh (h-fl->px (frame-h child) parent) child)))
 
@@ -191,8 +191,8 @@
 
 (defmethod maximize-layout (child parent)
   (with-slots (rx ry rw rh) parent
-    (values (adj-border-xy rx child)
-	    (adj-border-xy ry child)
+    (values (adj-border-xy rx parent)
+	    (adj-border-xy ry parent)
 	    (adj-border-wh rw child)
 	    (adj-border-wh rh child))))
 
@@ -269,8 +269,8 @@
       (if (zerop pos)
 	  (setf width (* dx (1+ dpos)))
 	  (incf pos dpos)))
-    (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (mod pos nx) dx))) child))
-	    (round (adj-border-xy (+ (frame-ry parent) (truncate (* (truncate (/ pos nx)) dy))) child))
+    (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (mod pos nx) dx))) parent))
+	    (round (adj-border-xy (+ (frame-ry parent) (truncate (* (truncate (/ pos nx)) dy))) parent))
 	    (round (adj-border-wh width child))
 	    (round (adj-border-wh dy child)))))
 
@@ -299,8 +299,8 @@
       (if (zerop pos)
 	  (setf height (* dy (1+ dpos)))
 	  (incf pos dpos)))
-    (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (truncate (/ pos ny)) dx))) child))
-	    (round (adj-border-xy (+ (frame-ry parent) (truncate (* (mod pos ny) dy))) child))
+    (values (round (adj-border-xy (+ (frame-rx parent) (truncate (* (truncate (/ pos ny)) dx))) parent))
+	    (round (adj-border-xy (+ (frame-ry parent) (truncate (* (mod pos ny) dy))) parent))
 	    (round (adj-border-wh dx child))
 	    (round (adj-border-wh height child)))))
 
@@ -333,9 +333,9 @@
           (setf width (* dx (1+ dpos)))
           (incf pos dpos)))
     (values (round (adj-border-xy (+ (frame-rx parent)
-                                     (truncate (* (mod pos nx) dx))) child))
+                                     (truncate (* (mod pos nx) dx))) parent))
             (round (adj-border-xy (+ (frame-ry parent)
-                                     (truncate (* (truncate (/ pos nx)) dy))) child))
+                                     (truncate (* (truncate (/ pos nx)) dy))) parent))
             (round (adj-border-wh width child))
             (round (adj-border-wh dy child)))))
 
@@ -355,8 +355,8 @@
 	 (pos (child-position child managed-children))
 	 (len (length managed-children))
 	 (dy (/ (frame-rh parent) len)))
-    (values (round (adj-border-xy (frame-rx parent) child))
-	    (round (adj-border-xy (+ (frame-ry parent) (*  pos dy)) child))
+    (values (round (adj-border-xy (frame-rx parent) parent))
+	    (round (adj-border-xy (+ (frame-ry parent) (*  pos dy)) parent))
 	    (round (adj-border-wh (frame-rw parent) child))
 	    (round (adj-border-wh dy child)))))
 
@@ -375,8 +375,8 @@
 	 (pos (child-position child managed-children))
 	 (len (length managed-children))
 	 (dx (/ (frame-rw parent) len)))
-    (values (round (adj-border-xy (+ (frame-rx parent) (*  pos dx)) child))
-	    (round (adj-border-xy (frame-ry parent) child))
+    (values (round (adj-border-xy (+ (frame-rx parent) (*  pos dx)) parent))
+	    (round (adj-border-xy (frame-ry parent) parent))
 	    (round (adj-border-wh dx child))
 	    (round (adj-border-wh (frame-rh parent) child)))))
 
@@ -410,10 +410,8 @@
            (child-width (floor (- rw col-space-total) cols))
            (child-height (floor (- rh row-space-total) rows))
            )
-      (values (round (adj-border-xy (+ rx col-space
-                                       (* (+ col-space child-width) col)) child))
-              (round (adj-border-xy (+ ry row-space
-                               (* (+ row-space child-height) row)) child))
+      (values (round (adj-border-xy (+ rx col-space (* (+ col-space child-width) col)) parent))
+              (round (adj-border-xy (+ ry row-space (* (+ row-space child-height) row)) parent))
               (round (adj-border-wh child-width child))
               (round (adj-border-wh child-height child))))))
 
@@ -447,12 +445,12 @@
 	   (size (or (frame-data-slot parent :tile-size) 0.8)))
       (if (> (length managed-children) 1)
 	  (if (= pos 0)
-	      (values (adj-border-xy rx child)
-		      (adj-border-xy ry child)
+	      (values (adj-border-xy rx parent)
+		      (adj-border-xy ry parent)
 		      (adj-border-wh (round (* rw size)) child)
 		      (adj-border-wh rh child))
-	      (values (adj-border-xy (round (+ rx (* rw size))) child)
-		      (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
+	      (values (adj-border-xy (round (+ rx (* rw size))) parent)
+		      (adj-border-xy (round (+ ry (* dy (1- pos)))) parent)
 		      (adj-border-wh (round (* rw (- 1 size))) child)
 		      (adj-border-wh (round dy) child)))
 	  (no-layout child parent)))))
@@ -477,12 +475,12 @@
 	   (size (or (frame-data-slot parent :tile-size) 0.8)))
       (if (> (length managed-children) 1)
 	  (if (= pos 0)
-	      (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) child)
-		      (adj-border-xy ry child)
+	      (values (adj-border-xy (round (+ rx (* rw (- 1 size)))) parent)
+		      (adj-border-xy ry parent)
 		      (adj-border-wh (round (* rw size)) child)
 		      (adj-border-wh rh child))
-	      (values (adj-border-xy rx child)
-		      (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
+	      (values (adj-border-xy rx parent)
+		      (adj-border-xy (round (+ ry (* dy (1- pos)))) parent)
 		      (adj-border-wh (round (* rw (- 1 size))) child)
 		      (adj-border-wh (round dy) child)))
 	  (no-layout child parent)))))
@@ -510,12 +508,12 @@
 	   (size (or (frame-data-slot parent :tile-size) 0.8)))
       (if (> (length managed-children) 1)
 	  (if (= pos 0)
-	      (values (adj-border-xy rx child)
-		      (adj-border-xy ry child)
+	      (values (adj-border-xy rx parent)
+		      (adj-border-xy ry parent)
 		      (adj-border-wh rw child)
 		      (adj-border-wh (round (* rh size)) child))
-	      (values (adj-border-xy (round (+ rx (* dx (1- pos)))) child)
-		      (adj-border-xy (round (+ ry (* rh size))) child)
+	      (values (adj-border-xy (round (+ rx (* dx (1- pos)))) parent)
+		      (adj-border-xy (round (+ ry (* rh size))) parent)
 		      (adj-border-wh (round dx) child)
 		      (adj-border-wh (round (* rh (- 1 size))) child)))
 	  (no-layout child parent)))))
@@ -541,12 +539,12 @@
 	   (size (or (frame-data-slot parent :tile-size) 0.8)))
       (if (> (length managed-children) 1)
 	  (if (= pos 0)
-	      (values (adj-border-xy rx child)
-		      (adj-border-xy (round (+ ry (* rh (- 1 size)))) child)
+	      (values (adj-border-xy rx parent)
+		      (adj-border-xy (round (+ ry (* rh (- 1 size)))) parent)
 		      (adj-border-wh rw child)
 		      (adj-border-wh (round (* rh size)) child))
-	      (values (adj-border-xy (round (+ rx (* dx (1- pos)))) child)
-		      (adj-border-xy ry child)
+	      (values (adj-border-xy (round (+ rx (* dx (1- pos)))) parent)
+		      (adj-border-xy ry parent)
 		      (adj-border-wh (round dx) child)
 		      (adj-border-wh (round (* rh (- 1 size))) child)))
 	  (no-layout child parent)))))
@@ -589,12 +587,12 @@
 	   (space (or (frame-data-slot parent :tile-left-space) 100)))
       (if (> (length managed-children) 1)
 	  (if (= pos 0)
-	      (values (adj-border-xy (+ rx space) child)
-		      (adj-border-xy ry child)
+	      (values (adj-border-xy (+ rx space) parent)
+		      (adj-border-xy ry parent)
 		      (adj-border-wh (- (round (* rw size)) space) child)
 		      (adj-border-wh rh child))
-	      (values (adj-border-xy (round (+ rx (* rw size))) child)
-		      (adj-border-xy (round (+ ry (* dy (1- pos)))) child)
+	      (values (adj-border-xy (round (+ rx (* rw size))) parent)
+		      (adj-border-xy (round (+ ry (* dy (1- pos)))) parent)
 		      (adj-border-wh (round (* rw (- 1 size))) child)
 		      (adj-border-wh (round dy) child)))
 	  (multiple-value-bind (rnx rny rnw rnh)
@@ -632,12 +630,12 @@
 	  (if (child-member child main-windows)
 	      (let* ((dy (/ rh len))
 		     (pos (child-position child main-windows)))
-		(values (adj-border-xy (round (+ rx (* rw (- 1 size)))) child)
-			(adj-border-xy (round (+ ry (* dy pos))) child)
+		(values (adj-border-xy (round (+ rx (* rw (- 1 size)))) parent)
+			(adj-border-xy (round (+ ry (* dy pos))) parent)
 			(adj-border-wh (round (* rw size)) child)
 			(adj-border-wh (round dy) child)))
-	      (values (adj-border-xy rx child)
-		      (adj-border-xy ry child)
+	      (values (adj-border-xy rx parent)
+		      (adj-border-xy ry parent)
 		      (adj-border-wh (round (* rw (- 1 size))) child)
 		      (adj-border-wh rh child)))))))
 
@@ -660,12 +658,12 @@
 	  (if (child-member child main-windows)
 	      (let* ((dy (/ rh len))
 		     (pos (child-position child main-windows)))
-		(values (adj-border-xy rx child)
-			(adj-border-xy (round (+ ry (* dy pos))) child)
+		(values (adj-border-xy rx parent)
+			(adj-border-xy (round (+ ry (* dy pos))) parent)
 			(adj-border-wh (round (* rw size)) child)
 			(adj-border-wh (round dy) child)))
-	      (values (adj-border-xy (round (+ rx (* rw size))) child)
-		      (adj-border-xy ry child)
+	      (values (adj-border-xy (round (+ rx (* rw size))) parent)
+		      (adj-border-xy ry parent)
 		      (adj-border-wh (round (* rw (- 1 size))) child)
 		      (adj-border-wh rh child)))))))
 
@@ -687,12 +685,12 @@
 	  (if (child-member child main-windows)
 	      (let* ((dx (/ rw len))
 		     (pos (child-position child main-windows)))
-		(values (adj-border-xy (round (+ rx (* dx pos))) child)
-			(adj-border-xy ry child)
+		(values (adj-border-xy (round (+ rx (* dx pos))) parent)
+			(adj-border-xy ry parent)
 			(adj-border-wh (round dx) child)
 			(adj-border-wh (round (* rh size)) child)))
-	      (values (adj-border-xy rx child)
-		      (adj-border-xy (round (+ ry (* rh size))) child)
+	      (values (adj-border-xy rx parent)
+		      (adj-border-xy (round (+ ry (* rh size))) parent)
 		      (adj-border-wh rw child)
 		      (adj-border-wh (round (* rh (- 1 size))) child)))))))
 
@@ -714,12 +712,12 @@
 	  (if (child-member child main-windows)
 	      (let* ((dx (/ rw len))
 		     (pos (child-position child main-windows)))
-		(values (adj-border-xy (round (+ rx (* dx pos))) child)
-			(adj-border-xy (round (+ ry (* rh (- 1 size)))) child)
+		(values (adj-border-xy (round (+ rx (* dx pos))) parent)
+			(adj-border-xy (round (+ ry (* rh (- 1 size)))) parent)
 			(adj-border-wh (round dx) child)
 			(adj-border-wh (round (* rh size)) child)))
-	      (values (adj-border-xy rx child)
-		      (adj-border-xy ry child)
+	      (values (adj-border-xy rx parent)
+		      (adj-border-xy ry parent)
 		      (adj-border-wh rw child)
 		      (adj-border-wh (round (* rh (- 1 size))) child)))))))
 
diff --git a/src/clfswm-pack.lisp b/src/clfswm-pack.lisp
index 00fffa6..f921e77 100644
--- a/src/clfswm-pack.lisp
+++ b/src/clfswm-pack.lisp
@@ -90,26 +90,26 @@
 ;;;,-----
 ;;;| Pack functions
 ;;;`-----
-(defun pack-frame-up (frame parent)
+(defun pack-frame-up (frame parent &optional sp-y-found)
   "Pack frame to up"
-  (let ((y-found (find-edge-up frame parent)))
+  (let ((y-found (or sp-y-found (find-edge-up frame parent))))
     (setf (frame-y frame) y-found)))
 
 
-(defun pack-frame-down (frame parent)
+(defun pack-frame-down (frame parent &optional sp-y-found)
   "Pack frame to down"
-  (let ((y-found (find-edge-down frame parent)))
+  (let ((y-found (or sp-y-found (find-edge-down frame parent))))
     (setf (frame-y frame) (- y-found (frame-h frame)))))
 
-(defun pack-frame-right (frame parent)
+(defun pack-frame-right (frame parent &optional sp-x-found)
   "Pack frame to right"
-  (let ((x-found (find-edge-right frame parent)))
+  (let ((x-found (or sp-x-found (find-edge-right frame parent))))
     (setf (frame-x frame) (- x-found (frame-w frame)))))
 
 
-(defun pack-frame-left (frame parent)
+(defun pack-frame-left (frame parent &optional sp-x-found)
   "Pack frame to left"
-  (let ((x-found (find-edge-left frame parent)))
+  (let ((x-found (or sp-x-found (find-edge-left frame parent))))
     (setf (frame-x frame) x-found)))
 
 
@@ -122,30 +122,30 @@
 ;;;,-----
 ;;;| Fill functions
 ;;;`-----
-(defun fill-frame-up (frame parent)
+(defun fill-frame-up (frame parent &optional sp-y-found)
   "Fill a frame up"
-  (let* ((y-found (find-edge-up frame parent))
+  (let* ((y-found (or sp-y-found (find-edge-up frame parent)))
 	 (dy (- (frame-y frame) y-found)))
     (setf (frame-y frame) y-found
 	  (frame-h frame) (+ (frame-h frame) dy))))
 
-(defun fill-frame-down (frame parent)
+(defun fill-frame-down (frame parent &optional sp-y-found)
   "Fill a frame down"
-  (let* ((y-found (find-edge-down frame parent))
+  (let* ((y-found (or sp-y-found (find-edge-down frame parent)))
 	 (dy (- y-found (frame-y2 frame))))
     (setf (frame-h frame) (+ (frame-h frame) dy))))
 
 
-(defun fill-frame-left (frame parent)
+(defun fill-frame-left (frame parent &optional sp-x-found)
   "Fill a frame left"
-  (let* ((x-found (find-edge-left frame parent))
+  (let* ((x-found (or sp-x-found (find-edge-left frame parent)))
 	 (dx (- (frame-x frame) x-found)))
     (setf (frame-x frame) x-found
 	  (frame-w frame) (+ (frame-w frame) dx))))
 
-(defun fill-frame-right (frame parent)
+(defun fill-frame-right (frame parent &optional sp-x-found)
   "Fill a frame rigth"
-  (let* ((x-found (find-edge-right frame parent))
+  (let* ((x-found (or sp-x-found (find-edge-right frame parent)))
 	 (dx (- x-found (frame-x2 frame))))
     (setf (frame-w frame) (+ (frame-w frame) dx))))
 
@@ -236,19 +236,29 @@
 ;;;;;,-----
 ;;;;;| Constrained move/resize frames
 ;;;;;`-----
-(labels ((readjust-all-frames-fl-size (parent)
+(labels ((redisplay (frame window)
+           (show-all-children)
+           (hide-all-children frame)
+           (setf (xlib:window-border window) (get-color *color-move-window*)))
+         (readjust-all-frames-fl-size (parent)
            (dolist (child (frame-child parent))
              (when (frame-p child)
                (setf (frame-x child) (x-px->fl (x-drawable-x (frame-window child)) parent)
                      (frame-y child) (y-px->fl (x-drawable-y (frame-window child)) parent)
-                     (frame-w child) (w-px->fl (anti-adj-border-wh (x-drawable-width (frame-window child)) parent) parent)
-                     (frame-h child) (h-px->fl (anti-adj-border-wh (x-drawable-height (frame-window child)) parent) parent))))))
+                     (frame-w child) (w-px->fl (anti-adj-border-wh (x-drawable-width (frame-window child)) child) parent)
+                     (frame-h child) (h-px->fl (anti-adj-border-wh (x-drawable-height (frame-window child)) child)
+                                               parent))))))
   (defun move-frame-constrained (frame parent orig-x orig-y)
-    (when (and frame parent (not (child-root-p frame)))
+    (when (and (frame-p frame) parent (not (child-root-p frame)))
       (hide-all-children frame)
       (with-slots (window) frame
-        (let ((lx orig-x)
-              (ly orig-y))
+        (let ((snap-size (/ *snap-size* 100.0))
+              (lx orig-x)
+              (ly orig-y)
+              (l-frame-x-r nil)
+              (l-frame-x-l nil)
+              (l-frame-y-u nil)
+              (l-frame-y-d nil))
           (readjust-all-frames-fl-size parent)
           (move-window window orig-x orig-y
                        (lambda ()
@@ -258,29 +268,41 @@
                                  (frame-y frame) (y-px->fl (x-drawable-y window) parent))
                            (multiple-value-bind (x y) (xlib:query-pointer *root*)
                              (when (> x lx)
-                               (let ((x-found (x-fl->px (find-edge-right frame parent) parent)))
-                                 (when (< (abs (- x-found (window-x2 window))) *snap-size*)
-                                   (setf (x-drawable-x window) (- x-found (adj-border-xy (x-drawable-width window) window))
-                                         (frame-x frame) (x-px->fl (x-drawable-x window) parent)
-                                         move-x nil))))
+                               (setf l-frame-x-l nil)
+                               (let ((x-found (find-edge-right frame parent)))
+                                 (when (< (abs (- x-found (frame-x2 frame))) snap-size)
+                                   (pack-frame-right frame parent x-found)
+                                   (when (not (equal (frame-x frame) l-frame-x-r))
+                                     (redisplay frame window)
+                                     (setf l-frame-x-r (frame-x frame)))
+                                   (setf move-x nil))))
                              (when (< x lx)
-                               (let ((x-found (x-fl->px (find-edge-left frame parent) parent)))
-                                 (when (< (abs (- x-found (x-drawable-x window))) *snap-size*)
-                                   (setf (x-drawable-x window) (adj-border-xy x-found window)
-                                         (frame-x frame) (x-px->fl (x-drawable-x window) parent)
-                                         move-x nil))))
+                               (setf l-frame-x-r nil)
+                               (let ((x-found (find-edge-left frame parent)))
+                                 (when (< (abs (- x-found (frame-x frame))) snap-size)
+                                   (pack-frame-left frame parent x-found)
+                                   (when (not (equal (frame-x frame) l-frame-x-l))
+                                     (redisplay frame window)
+                                     (setf l-frame-x-l (frame-x frame)))
+                                   (setf move-x nil))))
                              (when (> y ly)
-                               (let ((y-found (y-fl->px (find-edge-down frame parent) parent)))
-                                 (when (< (abs (- y-found (window-y2 window))) *snap-size*)
-                                   (setf (x-drawable-y window) (- y-found (adj-border-xy (x-drawable-height window) window))
-                                         (frame-y frame) (y-px->fl (x-drawable-y window) parent)
-                                         move-y nil))))
+                               (setf l-frame-y-u nil)
+                               (let ((y-found (find-edge-down frame parent)))
+                                 (when (< (abs (- y-found (frame-y2 frame))) snap-size)
+                                   (pack-frame-down frame parent y-found)
+                                   (when (not (equal (frame-y frame) l-frame-y-d))
+                                     (redisplay frame window)
+                                     (setf l-frame-y-d (frame-y frame)))
+                                   (setf move-y nil))))
                              (when (< y ly)
-                               (let ((y-found (y-fl->px (find-edge-up frame parent) parent)))
-                                 (when (< (abs (- y-found (x-drawable-y window))) *snap-size*)
-                                   (setf (x-drawable-y window) (adj-border-xy y-found window)
-                                         (frame-y frame) (y-px->fl (x-drawable-y window) parent)
-                                         move-y nil))))
+                               (setf l-frame-y-d nil)
+                               (let ((y-found (find-edge-up frame parent)))
+                                 (when (< (abs (- y-found (frame-y frame))) snap-size)
+                                   (pack-frame-up frame parent y-found)
+                                   (when (not (equal (frame-y frame) l-frame-y-u))
+                                     (redisplay frame window)
+                                     (setf l-frame-y-u (frame-y frame)))
+                                   (setf move-y nil))))
                              (display-frame-info frame)
                              (when move-x (setf lx x))
                              (when move-y (setf ly y))
@@ -292,31 +314,43 @@
     (when (and frame parent (not (child-root-p frame)))
       (hide-all-children frame)
       (with-slots (window) frame
-        (let ((lx orig-x)
-              (ly orig-y))
+        (let ((snap-size (/ *snap-size* 100.0))
+              (lx orig-x)
+              (ly orig-y)
+              (l-frame-w nil)
+              (l-frame-h nil))
           (readjust-all-frames-fl-size parent)
           (resize-window window orig-x orig-y
                          (lambda ()
                            (let ((resize-w t)
                                  (resize-h t))
+                             (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) frame)
+                                                             parent)
+                                   (frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) frame)
+                                                             parent))
                              (multiple-value-bind (x y) (xlib:query-pointer *root*)
-                               (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) parent) parent)
-                                     (frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) parent) parent))
                                (when (> x lx)
-                                 (let ((x-found (x-fl->px (find-edge-right frame parent) parent)))
-                                   (when (< (abs (- x-found (window-x2 window))) *snap-size*)
-                                     (setf (x-drawable-width window) (+ (x-drawable-width window)
-                                                                           (- x-found (adj-border-xy (window-x2 window) parent)))
-                                           (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) parent) parent)
-                                           resize-w nil))))
+                                 (let ((x-found (find-edge-right frame parent)))
+                                   (when (< (abs (- x-found (frame-x2 frame))) snap-size)
+                                     (fill-frame-right frame parent x-found)
+                                     (when (not (equal (frame-w frame) l-frame-w))
+                                       (redisplay frame window)
+                                       (setf l-frame-w (frame-w frame)))
+                                     (setf resize-w nil))))
+                               (when (< x lx)
+                                 (setf l-frame-w nil))
                                (when (> y ly)
-                                 (let ((y-found (y-fl->px (find-edge-down frame parent) parent)))
-                                   (when (< (abs (- y-found (window-y2 window))) *snap-size*)
-                                     (setf (x-drawable-height window) (+ (x-drawable-height window)
-                                                                            (- y-found (adj-border-xy (window-y2 window) parent)))
-                                           (frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) parent) parent)
-                                           resize-h nil))))
-                               (display-frame-info frame)
+                                 (let ((y-found (find-edge-down frame parent)))
+                                   (when (< (abs (- y-found (frame-y2 frame))) snap-size)
+                                     (fill-frame-down frame parent y-found)
+                                     (when (or (null l-frame-h)
+                                               (and (numberp l-frame-h)
+                                                    (/= (frame-h frame) l-frame-h)))
+                                       (redisplay frame window)
+                                       (setf l-frame-h (frame-h frame)))
+                                     (setf resize-h nil))))
+                               (when (< y ly)
+                                 (setf l-frame-h nil))
                                (when resize-w (setf lx x))
                                (when resize-h (setf ly y))
                                (values resize-w resize-h)))))))
diff --git a/src/clfswm-placement.lisp b/src/clfswm-placement.lisp
index 242bc91..4e8d4e9 100644
--- a/src/clfswm-placement.lisp
+++ b/src/clfswm-placement.lisp
@@ -60,161 +60,123 @@
 ;;;
 ;;; Absolute placement
 ;;;
+(defun root-screen-coord (border-size)
+  (values (- (xlib:screen-width *screen*) (* 2 border-size))
+          (- (xlib:screen-height *screen*) (* 2 border-size))))
+
+(defmacro with-root-screen-coord ((border-size w h) &body body)
+  `(multiple-value-bind (,w ,h)
+       (root-screen-coord ,border-size)
+     (let ((width (min width ,w))
+           (height (min height ,h)))
+       , at body)))
+
+
 (defun top-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (values 0 0 width height))
+  (with-root-screen-coord (border-size w h)
+    (values 0 0 width height)))
 
 (defun top-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
-	  0
-          width height))
+  (with-root-screen-coord (border-size w h)
+    (values (truncate (/ (- w width) 2)) 0 width height)))
 
 (defun top-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (values (- (xlib:screen-width *screen*) width (* border-size 2))
-          0
-          width height))
+  (with-root-screen-coord (border-size w h)
+    (values (- w width) 0 width height)))
 
 
 
 (defun middle-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (values 0
-	  (truncate (/ (- (xlib:screen-height *screen*) height) 2))
-          width height))
+  (with-root-screen-coord (border-size w h)
+    (values 0 (truncate (/ (- h height) 2)) width height)))
 
 (defun middle-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
-	  (truncate (/ (- (xlib:screen-height *screen*) height) 2))
-          width height))
+  (with-root-screen-coord (border-size w h)
+    (values (truncate (/ (- w width) 2)) (truncate (/ (- h height) 2)) width height)))
 
 (defun middle-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (values (- (xlib:screen-width *screen*) width (* border-size 2))
-          (truncate (/ (- (xlib:screen-height *screen*) height) 2))
-          width height))
+  (with-root-screen-coord (border-size w h)
+    (values (- w width) (truncate (/ (- h height) 2)) width height)))
 
 
 (defun bottom-left-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (values 0
-          (- (xlib:screen-height *screen*) height (* border-size 2))
-          width height))
+  (with-root-screen-coord (border-size w h)
+    (values 0 (- h height) width height)))
 
 (defun bottom-middle-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (values (truncate (/ (- (xlib:screen-width *screen*) width) 2))
-          (- (xlib:screen-height *screen*) height (* border-size 2))
-          width height))
+  (with-root-screen-coord (border-size w h)
+    (values (truncate (/ (- w width) 2)) (- h height) width height)))
 
 (defun bottom-right-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (values (- (xlib:screen-width *screen*) width (* border-size 2))
-          (- (xlib:screen-height *screen*) height (* border-size 2))
-          width height))
+  (with-root-screen-coord (border-size w h)
+    (values (- w width) (- h height) width height)))
 
 
 ;;;
 ;;; Current child placement
 ;;;
-(defun current-child-coord ()
+(defun current-child-coord (border-size)
   (typecase (current-child)
     (xlib:window (values (x-drawable-x (current-child))
 			 (x-drawable-y (current-child))
-			 (x-drawable-width (current-child))
-			 (x-drawable-height (current-child))))
+			 (- (x-drawable-width (current-child)) (* 2 border-size))
+			 (- (x-drawable-height (current-child)) (* 2 border-size))))
     (frame (values (frame-rx (current-child))
 		   (frame-ry (current-child))
-		   (frame-rw (current-child))
-		   (frame-rh (current-child))))
+		   (- (frame-rw (current-child)) (* 2 border-size))
+		   (- (frame-rh (current-child)) (* 2 border-size))))
     (t (values 0 0 10 10))))
 
-(defmacro with-current-child-coord ((x y w h) &body body)
+(defmacro with-current-child-coord ((border-size x y w h) &body body)
   `(multiple-value-bind (,x ,y ,w ,h)
-       (current-child-coord)
-     , at body))
+       (current-child-coord ,border-size)
+     (let ((width (min w width))
+           (height (min h height)))
+       , at body)))
 
 
 (defun top-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (with-current-child-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x 2)
-              (+ y 2)
-              width height))))
+  (with-current-child-coord (border-size x y w h)
+    (values (+ x border-size) (+ y border-size) width height)))
 
 (defun top-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (with-current-child-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (truncate (/ (- w width) 2)))
-              (+ y 2)
-              width height))))
+  (with-current-child-coord (border-size x y w h)
+    (values (+ x (truncate (/ (- w width) 2)) border-size) (+ y border-size) width height)))
 
 (defun top-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (with-current-child-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (- w width 2))
-              (+ y 2)
-              width height))))
+  (with-current-child-coord (border-size x y w h)
+    (values (+ x (- w width) border-size) (+ y border-size) width height)))
 
 
 
 (defun middle-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (with-current-child-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x 2)
-              (+ y (truncate (/ (- h height) 2)))
-              width height))))
+  (with-current-child-coord (border-size x y w h)
+    (values (+ x border-size) (+ y (truncate (/ (- h height) 2)) border-size) width height)))
 
 (defun middle-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (with-current-child-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (truncate (/ (- w width) 2)))
-              (+ y (truncate (/ (- h height) 2)))
-              width height))))
+  (with-current-child-coord (border-size x y w h)
+    (values (+ x (truncate (/ (- w width) 2)) border-size)
+            (+ y (truncate (/ (- h height) 2)) border-size)
+            width height)))
 
 (defun middle-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (with-current-child-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (- w width 2))
-              (+ y (truncate (/ (- h height) 2)))
-              width height))))
+  (with-current-child-coord (border-size x y w h)
+    (values (+ x (- w width) border-size)
+            (+ y (truncate (/ (- h height) 2)) border-size)
+            width height)))
 
 
 (defun bottom-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (with-current-child-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x 2)
-              (+ y (- h height 2))
-              width height))))
+  (with-current-child-coord (border-size x y w h)
+    (values (+ x border-size) (+ y (- h height) border-size) width height)))
 
 (defun bottom-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (with-current-child-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (truncate (/ (- w width) 2)))
-              (+ y (- h height 2))
-              width height))))
+  (with-current-child-coord (border-size x y w h)
+    (values (+ x (truncate (/ (- w width) 2)) border-size) (+ y (- h height) border-size) width height)))
 
 (defun bottom-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (with-current-child-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (- w width 2))
-              (+ y (- h height 2))
-              width height))))
+  (with-current-child-coord (border-size x y w h)
+    (values (+ x (- w width) border-size) (+ y (- h height) border-size) width height)))
 
 
 ;;;
@@ -223,93 +185,63 @@
 (defparameter *get-current-root-fun* (lambda ()
                                        (find-root (current-child))))
 
-(defun current-root-coord ()
+(defun current-root-coord (border-size)
   (let ((root (funcall *get-current-root-fun*)))
     (values (root-x root) (root-y root)
-            (root-w root) (root-h root))))
-
+            (- (root-w root) (* 2 border-size))
+            (- (root-h root) (* 2 border-size)))))
 
 
-
-(defmacro with-current-root-coord ((x y w h) &body body)
+(defmacro with-current-root-coord ((border-size x y w h) &body body)
   `(multiple-value-bind (,x ,y ,w ,h)
-       (current-root-coord)
-     , at body))
+       (current-root-coord ,border-size)
+     (let ((width (min w width))
+           (height (min h height)))
+       , at body)))
 
 
 (defun top-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-root-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x border-size)
-              (+ y border-size)
-              width height))))
+  (with-current-root-coord (border-size x y w h)
+    (values x y width height)))
 
 (defun top-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-root-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (truncate (/ (- w width) 2)))
-              (+ y border-size)
-              width height))))
+  (with-current-root-coord (border-size x y w h)
+    (values (+ x (truncate (/ (- w width) 2))) y width height)))
 
 (defun top-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-root-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (- w width border-size))
-              (+ y border-size)
-              width height))))
+  (with-current-root-coord (border-size x y w h)
+    (values (+ x (- w width)) y width height)))
 
 
 
 (defun middle-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-root-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x border-size)
-              (+ y (truncate (/ (- h height) 2)))
-              width height))))
+  (with-current-root-coord (border-size x y w h)
+    (values x (+ y (truncate (/ (- h height) 2))) width height)))
 
 (defun middle-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (declare (ignore border-size))
-  (with-current-root-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (truncate (/ (- w width) 2)))
-              (+ y (truncate (/ (- h height) 2)))
-              width height))))
+  (with-current-root-coord (border-size x y w h)
+    (values (+ x (truncate (/ (- w width) 2))) (+ y (truncate (/ (- h height) 2))) width height)))
 
 (defun middle-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-root-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (- w width border-size))
-              (+ y (truncate (/ (- h height) 2)))
-              width height))))
+  (with-current-root-coord (border-size x y w h)
+    (values (+ x (- w width)) (+ y (truncate (/ (- h height) 2))) width height)))
 
 
 (defun bottom-left-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-root-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x border-size)
-              (+ y (- h height border-size))
-              width height))))
+  (with-current-root-coord (border-size x y w h)
+    (values x (+ y (- h height)) width height)))
 
 (defun bottom-middle-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-root-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (truncate (/ (- w width) 2)))
-              (+ y (- h height border-size))
-              width height))))
+  (with-current-root-coord (border-size x y w h)
+    (values (+ x (truncate  (/ (- w width) 2))) (+ y (- h height)) width height)))
 
 (defun bottom-right-root-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-root-coord (x y w h)
-    (let ((width (min (- w 4) width))
-          (height (min (- h 4) height)))
-      (values (+ x (- w width border-size))
-              (+ y (- h height border-size))
-              width height))))
+  (with-current-root-coord (border-size x y w h)
+    (values (+ x (- w width)) (+ y (- h height)) width height)))
+
+
+;;;;; Some tests
+;;(defun test-some-placement (placement)
+;;  (setf *second-mode-placement* placement
+;;        *query-mode-placement* placement))
 
diff --git a/src/clfswm-util.lisp b/src/clfswm-util.lisp
index 9bbd8e8..d31aa88 100644
--- a/src/clfswm-util.lisp
+++ b/src/clfswm-util.lisp
@@ -213,6 +213,21 @@
   (leave-second-mode))
 
 
+(defun ask-child-border-size (msg child)
+  (let ((size (query-number (format nil "New ~A border size: (last: ~A)"
+                                    msg
+                                    (child-border-size child))
+                            (child-border-size child))))
+    (when (numberp size)
+      (setf (child-border-size child) size))))
+
+
+(defun set-current-child-border-size ()
+  "Set the current child border size"
+  (ask-child-border-size "child" (current-child))
+  (leave-second-mode))
+
+
 (defun renumber-current-frame ()
   "Renumber the current frame"
   (when (frame-p (current-child))
@@ -711,8 +726,8 @@
     (hide-all-children frame)
     (with-slots (window) frame
       (resize-window window orig-x orig-y #'display-frame-info (list frame))
-      (setf (frame-w frame) (w-px->fl (x-drawable-width window) parent)
-	    (frame-h frame) (h-px->fl (x-drawable-height window) parent)))
+      (setf (frame-w frame) (w-px->fl (anti-adj-border-wh (x-drawable-width window) frame) parent)
+	    (frame-h frame) (h-px->fl (anti-adj-border-wh (x-drawable-height window) frame) parent)))
     (show-all-children)))
 
 
diff --git a/src/config.lisp b/src/config.lisp
index 1db5f51..f93c9e6 100644
--- a/src/config.lisp
+++ b/src/config.lisp
@@ -63,8 +63,8 @@ A list of (list match-function handle-function)")
 (defconfig *hide-unmanaged-window* t nil
            "Hide or not unmanaged windows when a child is deselected.")
 
-(defconfig *snap-size* 20 nil
-           "Snap size (in pixels) when move or resize frame is constrained")
+(defconfig *snap-size* 5 nil
+           "Snap size (in % of parent size) when move or resize frame is constrained")
 
 (defconfig *spatial-move-delay-before* 0.2 nil
            "Delay to display the current child before doing a spatial move")
diff --git a/src/menu-def.lisp b/src/menu-def.lisp
index 593038b..76bf799 100644
--- a/src/menu-def.lisp
+++ b/src/menu-def.lisp
@@ -79,6 +79,7 @@
 
 (add-menu-key 'child-menu "r" 'rename-current-child)
 (add-menu-key 'child-menu "t" 'set-current-child-transparency)
+(add-menu-key 'child-menu "b" 'set-current-child-border-size)
 (add-menu-key 'child-menu "e" 'ensure-unique-name)
 (add-menu-key 'child-menu "n" 'ensure-unique-number)
 (add-menu-key 'child-menu "Delete" 'delete-current-child)

-----------------------------------------------------------------------

Summary of changes:
 ChangeLog                 |    5 +
 src/clfswm-internal.lisp  |   75 +++++++++-----
 src/clfswm-layout.lisp    |  110 ++++++++++----------
 src/clfswm-pack.lisp      |  152 ++++++++++++++++-----------
 src/clfswm-placement.lisp |  256 +++++++++++++++++----------------------------
 src/clfswm-util.lisp      |   19 +++-
 src/config.lisp           |    4 +-
 src/menu-def.lisp         |    1 +
 8 files changed, 315 insertions(+), 307 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Mon Jun 18 19:57:39 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Mon, 18 Jun 2012 12:57:39 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch master updated. R-1106-64-ge9afcbc
Message-ID: <E1Sgi4x-0004ZS-Ni@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, master has been updated
       via  e9afcbc29bc68c2939eaf4b852a86558f3d9c669 (commit)
       via  92c06b8c12a4e3cf3adfd9868ad16974a0fe604c (commit)
       via  f9c2f34e12e8ff76170edc0732514dcc61362938 (commit)
       via  76075c217d62ae600da3460ef62687966d6e3fbc (commit)
       via  7057baaaf3e5dc4372b8385534b540a12edbadcd (commit)
       via  c389dc88d4f97b76b873d6ceeff625a79cc4a343 (commit)
      from  1e5611e4818034b5dc32938ea5a4675e96d2d20f (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
-----------------------------------------------------------------------

Summary of changes:
 ChangeLog                 |   22 ++++
 contrib/toolbar.lisp      |  144 +++++++++++++++++++++----
 src/clfswm-internal.lisp  |   78 +++++++++-----
 src/clfswm-layout.lisp    |  110 +++++++++----------
 src/clfswm-pack.lisp      |  152 ++++++++++++++++----------
 src/clfswm-placement.lisp |  262 +++++++++++++++++----------------------------
 src/clfswm-util.lisp      |   19 +++-
 src/clfswm.lisp           |    1 +
 src/config.lisp           |    4 +-
 src/menu-def.lisp         |    1 +
 src/package.lisp          |    2 +-
 src/tools.lisp            |   59 +++++-----
 src/xlib-util.lisp        |   80 +++++++++-----
 13 files changed, 548 insertions(+), 386 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Mon Jun 18 20:46:57 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Mon, 18 Jun 2012 13:46:57 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-65-g02e0f7b
Message-ID: <E1Sgiqf-0000gf-E4@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  02e0f7b49c2d606348acb8008f47c59c87109048 (commit)
      from  e9afcbc29bc68c2939eaf4b852a86558f3d9c669 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 02e0f7b49c2d606348acb8008f47c59c87109048
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Mon Jun 18 22:46:52 2012 +0200

    src/clfswm-placement.lisp: Take care of current child border size instead of placed window border size

diff --git a/src/clfswm-internal.lisp b/src/clfswm-internal.lisp
index af41d01..75b479a 100644
--- a/src/clfswm-internal.lisp
+++ b/src/clfswm-internal.lisp
@@ -36,6 +36,7 @@
   (x-drawable-border-width child))
 
 (defmethod child-border-size (child)
+  (declare (ignore child))
   0)
 
 (defgeneric set-child-border-size (child value))
diff --git a/src/clfswm-placement.lisp b/src/clfswm-placement.lisp
index 4e8d4e9..81d49bd 100644
--- a/src/clfswm-placement.lisp
+++ b/src/clfswm-placement.lisp
@@ -120,15 +120,18 @@
     (xlib:window (values (x-drawable-x (current-child))
 			 (x-drawable-y (current-child))
 			 (- (x-drawable-width (current-child)) (* 2 border-size))
-			 (- (x-drawable-height (current-child)) (* 2 border-size))))
+			 (- (x-drawable-height (current-child)) (* 2 border-size))
+                         (x-drawable-border-width (current-child))))
     (frame (values (frame-rx (current-child))
 		   (frame-ry (current-child))
 		   (- (frame-rw (current-child)) (* 2 border-size))
-		   (- (frame-rh (current-child)) (* 2 border-size))))
-    (t (values 0 0 10 10))))
+		   (- (frame-rh (current-child)) (* 2 border-size))
+                   (x-drawable-border-width (frame-window (current-child)))))
+    (t (values 0 0 10 10 1))))
 
-(defmacro with-current-child-coord ((border-size x y w h) &body body)
-  `(multiple-value-bind (,x ,y ,w ,h)
+(defmacro with-current-child-coord ((border-size x y w h bds) &body body)
+  "Bind x y w h bds to current child coordinates and border size"
+  `(multiple-value-bind (,x ,y ,w ,h ,bds)
        (current-child-coord ,border-size)
      (let ((width (min w width))
            (height (min h height)))
@@ -136,47 +139,45 @@
 
 
 (defun top-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-child-coord (border-size x y w h)
-    (values (+ x border-size) (+ y border-size) width height)))
+  (with-current-child-coord (border-size x y w h bds)
+    (values (+ x bds) (+ y bds) width height)))
 
 (defun top-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-child-coord (border-size x y w h)
-    (values (+ x (truncate (/ (- w width) 2)) border-size) (+ y border-size) width height)))
+  (with-current-child-coord (border-size x y w h bds)
+    (values (+ x (truncate (/ (- w width) 2)) bds) (+ y bds) width height)))
 
 (defun top-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-child-coord (border-size x y w h)
-    (values (+ x (- w width) border-size) (+ y border-size) width height)))
+  (with-current-child-coord (border-size x y w h bds)
+    (values (+ x (- w width) bds) (+ y bds) width height)))
 
 
 
 (defun middle-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-child-coord (border-size x y w h)
-    (values (+ x border-size) (+ y (truncate (/ (- h height) 2)) border-size) width height)))
+  (with-current-child-coord (border-size x y w h bds)
+    (values (+ x bds) (+ y (truncate (/ (- h height) 2)) bds) width height)))
 
 (defun middle-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-child-coord (border-size x y w h)
-    (values (+ x (truncate (/ (- w width) 2)) border-size)
-            (+ y (truncate (/ (- h height) 2)) border-size)
+  (with-current-child-coord (border-size x y w h bds)
+    (values (+ x (truncate (/ (- w width) 2)) bds) (+ y (truncate (/ (- h height) 2)) bds)
             width height)))
 
 (defun middle-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-child-coord (border-size x y w h)
-    (values (+ x (- w width) border-size)
-            (+ y (truncate (/ (- h height) 2)) border-size)
+  (with-current-child-coord (border-size x y w h bds)
+    (values (+ x (- w width) bds) (+ y (truncate (/ (- h height) 2)) bds)
             width height)))
 
 
 (defun bottom-left-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-child-coord (border-size x y w h)
-    (values (+ x border-size) (+ y (- h height) border-size) width height)))
+  (with-current-child-coord (border-size x y w h bds)
+    (values (+ x bds) (+ y (- h height) bds) width height)))
 
 (defun bottom-middle-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-child-coord (border-size x y w h)
-    (values (+ x (truncate (/ (- w width) 2)) border-size) (+ y (- h height) border-size) width height)))
+  (with-current-child-coord (border-size x y w h bds)
+    (values (+ x (truncate (/ (- w width) 2)) bds) (+ y (- h height) bds) width height)))
 
 (defun bottom-right-child-placement (&optional (width 0) (height 0) (border-size *border-size*))
-  (with-current-child-coord (border-size x y w h)
-    (values (+ x (- w width) border-size) (+ y (- h height) border-size) width height)))
+  (with-current-child-coord (border-size x y w h bds)
+    (values (+ x (- w width) bds) (+ y (- h height) bds) width height)))
 
 
 ;;;
@@ -240,8 +241,8 @@
     (values (+ x (- w width)) (+ y (- h height)) width height)))
 
 
-;;;;; Some tests
-;;(defun test-some-placement (placement)
-;;  (setf *second-mode-placement* placement
-;;        *query-mode-placement* placement))
+;;; Some tests
+(defun test-some-placement (placement)
+  (setf *second-mode-placement* placement
+        *query-mode-placement* placement))
 

-----------------------------------------------------------------------

Summary of changes:
 src/clfswm-internal.lisp  |    1 +
 src/clfswm-placement.lisp |   59 +++++++++++++++++++++++----------------------
 2 files changed, 31 insertions(+), 29 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Mon Jun 18 20:47:17 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Mon, 18 Jun 2012 13:47:17 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch master updated. R-1106-65-g02e0f7b
Message-ID: <E1Sgiqz-0000iM-Je@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, master has been updated
       via  02e0f7b49c2d606348acb8008f47c59c87109048 (commit)
      from  e9afcbc29bc68c2939eaf4b852a86558f3d9c669 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
-----------------------------------------------------------------------

Summary of changes:
 src/clfswm-internal.lisp  |    1 +
 src/clfswm-placement.lisp |   59 +++++++++++++++++++++++----------------------
 2 files changed, 31 insertions(+), 29 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Mon Jun 25 22:20:39 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Mon, 25 Jun 2012 15:20:39 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-66-ga236a20
Message-ID: <E1SjHeB-0005MP-EG@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  a236a208d7dc04c397e6165cc0fe734b66bd67d2 (commit)
      from  02e0f7b49c2d606348acb8008f47c59c87109048 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit a236a208d7dc04c397e6165cc0fe734b66bd67d2
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Tue Jun 26 00:20:33 2012 +0200

    src/clfswm-query.lisp: Add completion for shell commands.

diff --git a/ChangeLog b/ChangeLog
index c4231cd..c0af3cb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2012-06-26  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* src/clfswm-query.lisp: Add completion for shell commands.
+
 2012-06-18  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* src/clfswm-placement.lisp: Each child can have its own border
diff --git a/TODO b/TODO
index fc6a728..5bb16e4 100644
--- a/TODO
+++ b/TODO
@@ -16,7 +16,7 @@ FOR THE NEXT RELEASE
 
 - Add a toolbar in contrib/
 
-- Add completion in query input.
+- Add completion in query input (done for shell command / TODO for lisp symbols).
 
 - Add a tabbar layout : save some space on top/left... of the frame and display clickable
     children name.
diff --git a/src/clfswm-query.lisp b/src/clfswm-query.lisp
index 9e72529..357b1d6 100644
--- a/src/clfswm-query.lisp
+++ b/src/clfswm-query.lisp
@@ -39,7 +39,6 @@
 (defparameter *query-return* nil)
 
 
-
 (defun query-show-paren (orig-string pos dec)
   "Replace matching parentheses with brackets"
   (let ((string (copy-seq orig-string)))
@@ -95,20 +94,24 @@
 (add-hook *binding-hook* 'init-*query-keys*)
 
 
+
 (defun query-find-complet-list ()
-  (remove-if-not (lambda (x)
-		   (zerop (or (search *query-string* x :test #'string-equal) -1)))
-		 *query-complet-list*))
+  (let* ((pos (or (position #\space *query-string* :end *query-pos* :from-end t) 0))
+         (str (string-trim " " (subseq *query-string* pos *query-pos*))))
+    (when (>= (length str) *query-min-complet-char*)
+      (values (string-match str *query-complet-list*) pos))))
 
 
 (defun query-print-string ()
   (let ((dec (min 0 (- (- (x-drawable-width *query-window*) 10)
-		       (+ 10 (* *query-pos* (xlib:max-char-width *query-font*)))))))
+		       (+ 10 (* *query-pos* (xlib:max-char-width *query-font*))))))
+        (complet (query-find-complet-list)))
     (clear-pixmap-buffer *query-window* *query-gc*)
     (setf (xlib:gcontext-foreground *query-gc*) (get-color *query-message-color*))
     (xlib:draw-glyphs *pixmap-buffer* *query-gc* 5 (+ (xlib:max-char-ascent *query-font*) 5)
 		      (format nil "~A ~{~A~^, ~}" *query-message*
-			      (query-find-complet-list)))
+			      (if (< (length complet) *query-max-complet-length*)
+                                  complet nil)))
     (when (< *query-pos* 0)
       (setf *query-pos* 0))
     (when (> *query-pos* (length *query-string*))
@@ -251,12 +254,24 @@
 
 
 (defun query-mode-complet ()
-  (setf *query-string* (find-common-string *query-string* (query-find-complet-list)))
-  (let ((complet (query-find-complet-list)))
-    (when (= (length complet) 1)
-      (setf *query-string* (first complet))))
-  (query-end))
-
+  (multiple-value-bind (complet pos)
+      (query-find-complet-list)
+    (if (= (length complet) 1)
+        (setf *query-string* (concatenate 'string
+                                          (subseq *query-string* 0 pos)
+                                          (if (plusp pos) " " "")
+                                          (first complet) " "
+                                          (subseq *query-string* *query-pos*))
+              *query-pos* (+ pos (length (first complet)) (if (plusp pos) 2 1)))
+        (let ((common (find-common-string (string-trim " " (subseq *query-string* pos *query-pos*))
+                                          complet)))
+          (when (and complet common)
+            (setf *query-string* (concatenate 'string
+                                              (subseq *query-string* 0 pos)
+                                              (if (plusp pos) " " "")
+                                              common
+                                              (subseq *query-string* *query-pos*))
+                  *query-pos* (+ pos (length common) (if (plusp pos) 1 0))))))))
 
 
 (add-hook *binding-hook* 'set-default-query-keys)
@@ -271,7 +286,9 @@
   (define-query-key ("Delete") 'query-delete)
   (define-query-key ("Delete" :control) 'query-delete-word)
   (define-query-key ("Home") 'query-home)
+  (define-query-key ("a" :control) 'query-home)
   (define-query-key ("End") 'query-end)
+  (define-query-key ("e" :control) 'query-end)
   (define-query-key ("Left") 'query-left)
   (define-query-key ("Left" :control) 'query-left-word)
   (define-query-key ("Right") 'query-right)
diff --git a/src/clfswm-util.lisp b/src/clfswm-util.lisp
index d31aa88..ca1a21b 100644
--- a/src/clfswm-util.lisp
+++ b/src/clfswm-util.lisp
@@ -65,7 +65,7 @@
 
 
 (defun query-yes-or-no (formatter &rest args)
-  (let ((rep (query-string (apply #'format nil formatter args) "" '("yes" "no"))))
+  (let ((rep (query-string (apply #'format nil formatter args) "" '("Yes" "No"))))
     (or (string= rep "")
 	(char= (char rep 0) #\y)
 	(char= (char rep 0) #\Y))))
@@ -562,15 +562,19 @@
 
 
 
-(defun run-program-from-query-string ()
-  "Run a program from the query input"
-  (multiple-value-bind (program return)
-      (query-string "Run:")
-    (when (and (equal return :return) program (not (equal program "")))
-      (setf *second-mode-leave-function* (let ((cmd (concatenate 'string "cd $HOME && " program)))
-					   (lambda ()
-					     (do-shell cmd))))
-      (leave-second-mode))))
+
+(let ((commands nil))
+  (defun run-program-from-query-string ()
+    "Run a program from the query input"
+    (unless commands
+      (setf commands (remove-duplicates (cmd-in-path) :test #'string-equal)))
+    (multiple-value-bind (program return)
+        (query-string "Run:" "" commands)
+      (when (and (equal return :return) program (not (equal program "")))
+        (setf *second-mode-leave-function* (let ((cmd (concatenate 'string "cd $HOME && " program)))
+                                             (lambda ()
+                                               (do-shell cmd))))
+        (leave-second-mode)))))
 
 
 
diff --git a/src/config.lisp b/src/config.lisp
index f93c9e6..6769a8d 100644
--- a/src/config.lisp
+++ b/src/config.lisp
@@ -257,6 +257,10 @@ on the root window in the main mode with the mouse")
   'Query-string "Query string window border color")
 (defconfig *query-transparency* *default-transparency*
   'Query-string "Query string window background transparency")
+(defconfig *query-max-complet-length* 50
+  'Query-string "Query maximum length of completion list")
+(defconfig *query-min-complet-char* 2
+  'Query-string "Query minimum input length for completion")
 
 
 ;;; CONFIG - Info mode
diff --git a/src/tools.lisp b/src/tools.lisp
index e958fb9..927c688 100644
--- a/src/tools.lisp
+++ b/src/tools.lisp
@@ -62,6 +62,7 @@
 	   :ensure-function
 	   :empty-string-p
 	   :find-common-string
+           :cmd-in-path
 	   :setf/=
 	   :number->char
            :number->string
@@ -69,6 +70,7 @@
 	   :repeat-chars
 	   :nth-insert
 	   :split-string
+           :string-match
 	   :append-newline-space
 	   :expand-newline
 	   :ensure-list
@@ -440,6 +442,20 @@ Return the result of the last hook"
       string))
 
 
+(defun cmd-in-path (&optional (tmpfile "/tmp/clfswm-cmd.tmp"))
+  (labels ((delete-tmp ()
+             (when (probe-file tmpfile)
+               (delete-file tmpfile))))
+    (delete-tmp)
+    (dolist (dir (split-string (getenv "PATH") #\:))
+      (ushell (format nil "ls ~A/* >> ~A" dir tmpfile)))
+    (prog1
+        (with-open-file (stream tmpfile :direction :input)
+          (loop for line = (read-line stream nil nil)
+             while line
+             collect (subseq line (1+ (or (position #\/ line :from-end t) -1)))))
+      (delete-tmp))))
+
 
 ;;; Tools
 (defmacro setf/= (var val)
@@ -490,6 +506,14 @@ Return the result of the last hook"
      unless (string= sub "") collect sub
      while j))
 
+(defun string-match (match list)
+  "Return the string in list witch match the match string"
+  (let ((len (length match)))
+    (remove-duplicates (remove-if-not (lambda (x)
+                                        (string-equal match (subseq x 0 (min len (length x)))))
+                                      list)
+                       :test #'string-equal)))
+
 
 (defun append-newline-space (string)
   "Append spaces before Newline on each line"

-----------------------------------------------------------------------

Summary of changes:
 ChangeLog             |    4 ++++
 TODO                  |    2 +-
 src/clfswm-query.lisp |   41 +++++++++++++++++++++++++++++------------
 src/clfswm-util.lisp  |   24 ++++++++++++++----------
 src/config.lisp       |    4 ++++
 src/tools.lisp        |   24 ++++++++++++++++++++++++
 6 files changed, 76 insertions(+), 23 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Tue Jun 26 21:03:43 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Tue, 26 Jun 2012 14:03:43 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-67-gd220157
Message-ID: <E1SjcvH-0001pT-SK@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  d220157eba933213ce9f590858bad32599b30223 (commit)
      from  a236a208d7dc04c397e6165cc0fe734b66bd67d2 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit d220157eba933213ce9f590858bad32599b30223
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Tue Jun 26 23:03:33 2012 +0200

    src/clfswm-query.lisp: Support completion with chars other than spaces.

diff --git a/clfswm.asd b/clfswm.asd
index edeab21..ffcc6a2 100644
--- a/clfswm.asd
+++ b/clfswm.asd
@@ -64,7 +64,7 @@
 			 (:file "clfswm-util"
 				:depends-on ("clfswm" "keysyms" "clfswm-info" "clfswm-second-mode" "clfswm-query"
                                                       "clfswm-menu" "clfswm-autodoc" "clfswm-corner"
-                                                      "clfswm-placement"))
+                                                      "clfswm-placement" "tools"))
                          (:file "clfswm-configuration"
 				:depends-on ("package" "config" "clfswm-internal" "clfswm-util" "clfswm-query"
 						       "clfswm-menu"))
diff --git a/src/clfswm-query.lisp b/src/clfswm-query.lisp
index 357b1d6..87e1d2e 100644
--- a/src/clfswm-query.lisp
+++ b/src/clfswm-query.lisp
@@ -96,9 +96,12 @@
 
 
 (defun query-find-complet-list ()
-  (let* ((pos (or (position #\space *query-string* :end *query-pos* :from-end t) 0))
-         (str (string-trim " " (subseq *query-string* pos *query-pos*))))
-    (when (>= (length str) *query-min-complet-char*)
+  (let* ((pos (1+ (or (position-if-not #'extented-alphanumericp *query-string*
+                                       :end *query-pos* :from-end t)
+                      -1)))
+         (str (subseq *query-string* pos *query-pos*)))
+    (when (or (> (length str) (1- *query-min-complet-char*))
+              (< (length *query-complet-list*) *query-max-complet-length*))
       (values (string-match str *query-complet-list*) pos))))
 
 
@@ -256,22 +259,20 @@
 (defun query-mode-complet ()
   (multiple-value-bind (complet pos)
       (query-find-complet-list)
-    (if (= (length complet) 1)
-        (setf *query-string* (concatenate 'string
-                                          (subseq *query-string* 0 pos)
-                                          (if (plusp pos) " " "")
-                                          (first complet) " "
-                                          (subseq *query-string* *query-pos*))
-              *query-pos* (+ pos (length (first complet)) (if (plusp pos) 2 1)))
-        (let ((common (find-common-string (string-trim " " (subseq *query-string* pos *query-pos*))
-                                          complet)))
-          (when (and complet common)
-            (setf *query-string* (concatenate 'string
-                                              (subseq *query-string* 0 pos)
-                                              (if (plusp pos) " " "")
-                                              common
-                                              (subseq *query-string* *query-pos*))
-                  *query-pos* (+ pos (length common) (if (plusp pos) 1 0))))))))
+    (when complet
+      (if (= (length complet) 1)
+          (setf *query-string* (concatenate 'string
+                                            (subseq *query-string* 0 pos)
+                                            (first complet) " "
+                                            (subseq *query-string* *query-pos*))
+                *query-pos* (+ pos (length (first complet)) 1))
+          (let ((common (find-common-string (subseq *query-string* pos *query-pos*) complet)))
+            (when common
+              (setf *query-string* (concatenate 'string
+                                                (subseq *query-string* 0 pos)
+                                                common
+                                                (subseq *query-string* *query-pos*))
+                    *query-pos* (+ pos (length common)))))))))
 
 
 (add-hook *binding-hook* 'set-default-query-keys)
diff --git a/src/clfswm-util.lisp b/src/clfswm-util.lisp
index ca1a21b..0799231 100644
--- a/src/clfswm-util.lisp
+++ b/src/clfswm-util.lisp
@@ -563,11 +563,9 @@
 
 
 
-(let ((commands nil))
+(let ((commands (command-in-path)))
   (defun run-program-from-query-string ()
     "Run a program from the query input"
-    (unless commands
-      (setf commands (remove-duplicates (cmd-in-path) :test #'string-equal)))
     (multiple-value-bind (program return)
         (query-string "Run:" "" commands)
       (when (and (equal return :return) program (not (equal program "")))
diff --git a/src/config.lisp b/src/config.lisp
index 6769a8d..f031790 100644
--- a/src/config.lisp
+++ b/src/config.lisp
@@ -257,9 +257,9 @@ on the root window in the main mode with the mouse")
   'Query-string "Query string window border color")
 (defconfig *query-transparency* *default-transparency*
   'Query-string "Query string window background transparency")
-(defconfig *query-max-complet-length* 50
+(defconfig *query-max-complet-length* 100
   'Query-string "Query maximum length of completion list")
-(defconfig *query-min-complet-char* 2
+(defconfig *query-min-complet-char* 1
   'Query-string "Query minimum input length for completion")
 
 
diff --git a/src/menu-def.lisp b/src/menu-def.lisp
index 76bf799..e43da42 100644
--- a/src/menu-def.lisp
+++ b/src/menu-def.lisp
@@ -27,6 +27,9 @@
 
 (in-package :clfswm)
 
+(format t "Updating menus...")
+(force-output)
+
 (init-menu)
 
 ;;; Here is a small example of menu manipulation:
@@ -236,3 +239,5 @@
 (add-menu-key 'clfswm-menu "l" 'reload-clfswm)
 (add-menu-key 'clfswm-menu "x" 'exit-clfswm)
 
+(format t " Done.~%")
+(force-output)
diff --git a/src/tools.lisp b/src/tools.lisp
index 927c688..3759afd 100644
--- a/src/tools.lisp
+++ b/src/tools.lisp
@@ -62,7 +62,7 @@
 	   :ensure-function
 	   :empty-string-p
 	   :find-common-string
-           :cmd-in-path
+           :command-in-path
 	   :setf/=
 	   :number->char
            :number->string
@@ -71,6 +71,7 @@
 	   :nth-insert
 	   :split-string
            :string-match
+           :extented-alphanumericp
 	   :append-newline-space
 	   :expand-newline
 	   :ensure-list
@@ -442,19 +443,23 @@ Return the result of the last hook"
       string))
 
 
-(defun cmd-in-path (&optional (tmpfile "/tmp/clfswm-cmd.tmp"))
+(defun command-in-path (&optional (tmpfile "/tmp/clfswm-cmd.tmp"))
+  (format t "Updating command list...~%")
   (labels ((delete-tmp ()
              (when (probe-file tmpfile)
                (delete-file tmpfile))))
     (delete-tmp)
     (dolist (dir (split-string (getenv "PATH") #\:))
       (ushell (format nil "ls ~A/* >> ~A" dir tmpfile)))
-    (prog1
-        (with-open-file (stream tmpfile :direction :input)
-          (loop for line = (read-line stream nil nil)
-             while line
-             collect (subseq line (1+ (or (position #\/ line :from-end t) -1)))))
-      (delete-tmp))))
+    (let ((commands nil))
+      (with-open-file (stream tmpfile :direction :input)
+        (loop for line = (read-line stream nil nil)
+           while line
+           do (pushnew (subseq line (1+ (or (position #\/ line :from-end t) -1))) commands
+                       :test #'string=)))
+      (delete-tmp)
+      (format t "Done. Found ~A commands in shell PATH.~%" (length commands))
+      commands)))
 
 
 ;;; Tools
@@ -515,6 +520,14 @@ Return the result of the last hook"
                        :test #'string-equal)))
 
 
+(defun extented-alphanumericp (char)
+  (or (alphanumericp char)
+      (eq char #\-)
+      (eq char #\_)
+      (eq char #\.)
+      (eq char #\+)))
+
+
 (defun append-newline-space (string)
   "Append spaces before Newline on each line"
   (with-output-to-string (stream)

-----------------------------------------------------------------------

Summary of changes:
 clfswm.asd            |    2 +-
 src/clfswm-query.lisp |   39 ++++++++++++++++++++-------------------
 src/clfswm-util.lisp  |    4 +---
 src/config.lisp       |    4 ++--
 src/menu-def.lisp     |    5 +++++
 src/tools.lisp        |   29 +++++++++++++++++++++--------
 6 files changed, 50 insertions(+), 33 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager



From pbrochard at common-lisp.net  Wed Jun 27 20:58:56 2012
From: pbrochard at common-lisp.net (Philippe Brochard)
Date: Wed, 27 Jun 2012 13:58:56 -0700
Subject: [clfswm-cvs] [clfswm-git]CLFSWM - A(nother) Common Lisp FullScreen
	Window Manager branch test updated. R-1106-68-gb3cad6b
Message-ID: <E1SjzKC-0005Ae-Pv@common-lisp.net>

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CLFSWM - A(nother) Common Lisp FullScreen Window Manager".

The branch, test has been updated
       via  b3cad6b22ce3f9fb00baf8c3fdd2e815ac8e9742 (commit)
      from  d220157eba933213ce9f590858bad32599b30223 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit b3cad6b22ce3f9fb00baf8c3fdd2e815ac8e9742
Author: Philippe Brochard <pbrochard at common-lisp.net>
Date:   Wed Jun 27 22:58:50 2012 +0200

    src/clfswm-util.lisp (eval-from-query-string): Add completion for eval for query string.

diff --git a/ChangeLog b/ChangeLog
index c0af3cb..adee0cc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-06-27  Philippe Brochard  <pbrochard at common-lisp.net>
+
+	* src/clfswm-util.lisp (eval-from-query-string): Add completion
+	for eval for query string.
+
 2012-06-26  Philippe Brochard  <pbrochard at common-lisp.net>
 
 	* src/clfswm-query.lisp: Add completion for shell commands.
diff --git a/src/clfswm-util.lisp b/src/clfswm-util.lisp
index 0799231..9feb0b3 100644
--- a/src/clfswm-util.lisp
+++ b/src/clfswm-util.lisp
@@ -540,24 +540,34 @@
 
 
 
-(defun eval-from-query-string ()
-  "Eval a lisp form from the query input"
-  (let ((form (query-string (format nil "Eval Lisp - ~A" (package-name *package*))))
-	(result nil))
-    (when (and form (not (equal form "")))
-      (let ((printed-result
-	     (with-output-to-string (*standard-output*)
-	       (setf result (handler-case
-				(loop for i in (multiple-value-list
-						(eval (read-from-string form)))
-				   collect (format nil "~S" i))
-			      (error (condition)
-				(format nil "~A" condition)))))))
-	(info-mode (expand-newline (append (ensure-list (format nil "> ~A" form))
-					   (ensure-list printed-result)
-					   (ensure-list result)))
-		   :width (- (xlib:screen-width *screen*) 2))
-	(eval-from-query-string)))))
+(let ((all-symbols (collect-all-symbols)))
+  (defun eval-from-query-string ()
+    "Eval a lisp form from the query input"
+    (let ((form (query-string (format nil "Eval Lisp <~A> " (package-name *package*))
+                              "" all-symbols))
+            (result nil))
+        (when (and form (not (equal form "")))
+          (let ((printed-result
+                 (with-output-to-string (*standard-output*)
+                   (setf result (handler-case
+                                    (loop for i in (multiple-value-list
+                                                    (eval (read-from-string form)))
+                                       collect (format nil "~S" i))
+                                  (error (condition)
+                                    (format nil "~A" condition)))))))
+            (let ((ret (info-mode (expand-newline (append (ensure-list (format nil "> ~A" form))
+                                                          (ensure-list printed-result)
+                                                          (ensure-list result)))
+                                  :width (- (xlib:screen-width *screen*) 2))))
+              (when (or (search "defparameter" form :test #'string-equal)
+                        (search "defvar" form :test #'string-equal))
+                (let ((elem (split-string form)))
+                  (pushnew (string-downcase (if (string= (first elem) "(") (third elem) (second elem)))
+                           all-symbols :test #'string=)))
+              (when (search "in-package" form :test #'string-equal)
+                (setf all-symbols (collect-all-symbols)))
+              (when ret
+                (eval-from-query-string))))))))
 
 
 
diff --git a/src/config.lisp b/src/config.lisp
index f031790..e651c4b 100644
--- a/src/config.lisp
+++ b/src/config.lisp
@@ -259,7 +259,7 @@ on the root window in the main mode with the mouse")
   'Query-string "Query string window background transparency")
 (defconfig *query-max-complet-length* 100
   'Query-string "Query maximum length of completion list")
-(defconfig *query-min-complet-char* 1
+(defconfig *query-min-complet-char* 2
   'Query-string "Query minimum input length for completion")
 
 
diff --git a/src/tools.lisp b/src/tools.lisp
index 3759afd..d7e6346 100644
--- a/src/tools.lisp
+++ b/src/tools.lisp
@@ -56,6 +56,7 @@
 	   :dbgnl
 	   :dbgc
            :distance
+           :collect-all-symbols
 	   :with-all-internal-symbols
 	   :export-all-functions :export-all-variables
 	   :export-all-functions-and-variables
@@ -383,6 +384,19 @@ Return the result of the last hook"
 
 
 ;;; Symbols tools
+(defun collect-all-symbols (&optional package)
+  (format t "Collecting all symbols for completion...")
+  (let (all-symbols)
+    (do-symbols (symbol (or package *package*))
+      (pushnew (string-downcase (symbol-name symbol)) all-symbols :test #'string=))
+    (do-symbols (symbol :keyword)
+      (pushnew (concatenate 'string ":" (string-downcase (symbol-name symbol)))
+               all-symbols :test #'string=))
+    (format t " Done.~%")
+    all-symbols))
+
+
+
 (defmacro with-all-internal-symbols ((var package) &body body)
   "Bind symbol to all internal symbols in package"
   `(do-symbols (,var ,package)
@@ -525,7 +539,11 @@ Return the result of the last hook"
       (eq char #\-)
       (eq char #\_)
       (eq char #\.)
-      (eq char #\+)))
+      (eq char #\+)
+      (eq char #\=)
+      (eq char #\*)
+      (eq char #\:)
+      (eq char #\%)))
 
 
 (defun append-newline-space (string)

-----------------------------------------------------------------------

Summary of changes:
 ChangeLog            |    5 +++++
 src/clfswm-util.lisp |   46 ++++++++++++++++++++++++++++------------------
 src/config.lisp      |    2 +-
 src/tools.lisp       |   20 +++++++++++++++++++-
 4 files changed, 53 insertions(+), 20 deletions(-)


hooks/post-receive
-- 
CLFSWM - A(nother) Common Lisp FullScreen Window Manager