From 0ba00ac9b41860908505a40130432980b6b0df34 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tunes@google.com>
Date: Fri, 21 Mar 2014 16:20:44 -0400
Subject: [PATCH] Add ~/common-lisp/ as a default tree in the registry.

---
 source-registry.lisp | 29 +++++++++++++++++++++--------
 upgrade.lisp         | 17 ++++++++---------
 2 files changed, 29 insertions(+), 17 deletions(-)

diff --git a/source-registry.lisp b/source-registry.lisp
index ee83e48d..d85285fd 100644
--- a/source-registry.lisp
+++ b/source-registry.lisp
@@ -16,7 +16,8 @@
    #:collect-asds-in-directory #:collect-sub*directories-asd-files
    #:validate-source-registry-directive #:validate-source-registry-form
    #:validate-source-registry-file #:validate-source-registry-directory
-   #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
+   #:parse-source-registry-string #:wrapping-source-registry
+   #:default-user-source-registry #:default-system-source-registry
    #:user-source-registry #:system-source-registry
    #:user-source-registry-directory #:system-source-registry-directory
    #:environment-source-registry #:process-source-registry
@@ -145,9 +146,11 @@ system names to pathnames of .asd files")
     '(environment-source-registry
       user-source-registry
       user-source-registry-directory
+      default-user-source-registry
       system-source-registry
       system-source-registry-directory
-      default-source-registry))
+      default-system-source-registry)
+    "List of default source registries" "3.1.0.102")
 
   (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
   (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
@@ -159,17 +162,27 @@ system names to pathnames of .asd files")
       #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
       #+cmu (:tree #p"modules:")
       #+scl (:tree #p"file://modules/")))
-  (defun default-source-registry ()
+  (defun default-user-source-registry ()
     `(:source-registry
-      #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
+      (:tree (:home "common-lisp/"))
+      #+sbcl (:directory (:home ".sbcl/systems/"))
       ,@(loop :for dir :in
               `(,@(when (os-unix-p)
                     `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
-                           (subpathname (user-homedir-pathname) ".local/share/"))
-                      ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
-                            '("/usr/local/share" "/usr/share"))))
+                           (subpathname (user-homedir-pathname) ".local/share/"))))
                 ,@(when (os-windows-p)
-                    (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
+                    (mapcar 'get-folder-path '(:local-appdata :appdata))))
+              :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+              :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+      :inherit-configuration))
+  (defun default-system-source-registry ()
+    `(:source-registry
+      ,@(loop :for dir :in
+              `(,@(when (os-unix-p)
+                    (or (getenv-absolute-directories "XDG_DATA_DIRS")
+                        '("/usr/local/share" "/usr/share")))
+                ,@(when (os-windows-p)
+                    (list (get-folder-path :common-appdata))))
               :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
               :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
       :inherit-configuration))
diff --git a/upgrade.lisp b/upgrade.lisp
index 23212d21..c08d1fc1 100644
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -34,15 +34,6 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
   (defvar *asdf-version* nil)
   ;; We need to clear systems from versions yet older than the below:
   (defparameter *oldest-forward-compatible-asdf-version* "2.33") ;; 2.32.13 renames a slot in component.
-  (defmacro defparameter* (var value &optional docstring)
-    (let* ((name (string-trim "*" var))
-           (valfun (intern (format nil "%~A-~A-~A" :compute name :value)))
-           (clearfun (intern (format nil "%~A-~A" :clear name))))
-      `(progn
-         (defun ,valfun () ,value)
-         (defvar ,var (,valfun) ,@(ensure-list docstring))
-         (defun ,clearfun () (setf ,var (,valfun)))
-         (register-hook-function '*post-upgrade-cleanup-hook* ',clearfun))))
   (defvar *verbose-out* nil)
   (defun asdf-message (format-string &rest format-args)
     (when *verbose-out* (apply 'format *verbose-out* format-string format-args)))
@@ -51,6 +42,14 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
   (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*))
     (and *previous-asdf-versions*
          (version< (first *previous-asdf-versions*) oldest-compatible-version)))
+  (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*))
+    (let* ((name (string-trim "*" var))
+           (valfun (intern (format nil "%~A-~A-~A" :compute name :value))))
+      `(progn
+         (defun ,valfun () ,value)
+         (defvar ,var (,valfun) ,@(ensure-list docstring))
+         (when (upgrading-p ,version)
+           (setf ,var (,valfun))))))
   (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*)
                                (upgrading-p `(upgrading-p ,version)) when) &body body)
     "A wrapper macro for code that should only be run when upgrading a
-- 
GitLab