1(require :asdf)
2
3(in-package :asdf)
4
5(defun keywordize (x)
6  (intern (string-upcase x) :keyword))
7
8(defun wrapping-source-registry ()
9  '(:source-registry (:tree #p"SYS:CONTRIB;") :ignore-inherited-configuration))
10
11
12(defun setup-asdf-contrib ()
13  ;;(setf *resolve-symlinks* nil)
14  (let* ((sbcl-pwd (getenv-pathname "SBCL_PWD" :ensure-directory t))
15         (src-contrib (subpathname sbcl-pwd "contrib/"))
16         (asdf-cache (subpathname sbcl-pwd "obj/asdf-cache/"))
17         (source-registry '(:source-registry :ignore-inherited-configuration))
18         (output-translations `(:output-translations (,(namestring src-contrib)
19                                                      ,(namestring asdf-cache))
20                                :ignore-inherited-configuration))
21         (src.pat (wilden src-contrib))
22         (src.dir.pat (merge-pathnames* *wild-inferiors* src-contrib))
23         (out.pat (wilden asdf-cache)))
24    (ensure-directories-exist asdf-cache)
25    (setf (logical-pathname-translations "SYS")
26          `(("CONTRIB;**;*.*.*" ,src.pat))) ;; this makes recursive tree search work.
27    (initialize-source-registry source-registry)
28    (initialize-output-translations output-translations)
29    (setf (logical-pathname-translations "SYS")
30          (labels ((typepat (type base)
31                     `(,(format nil "CONTRIB;**;*.~:@(~A~).*" type)
32                       ,(make-pathname :type (string-downcase type) :defaults base)))
33                   (outpat (type) (typepat type out.pat))
34                   (srcpat (type) (typepat type src.pat))
35                   (outpats (&rest types) (mapcar #'outpat types))
36                   (srcpats (&rest types) (mapcar #'srcpat types)))
37            `(,@(srcpats :lisp :asd)
38              ,@(outpats :fasl :sbcl-warnings :build-report
39                         :out :exe :lisp-temp :o :c :test-report :html)
40              ("CONTRIB;**;" ,src.dir.pat)
41              #|("CONTRIB;**;*.*.*" ,src.pat)|#)))
42    (setf *central-registry* nil)))
43
44(defun build-asdf-contrib (system)
45  (push :sb-building-contrib *features*)
46  (setup-asdf-contrib)
47  (let* ((name (string-downcase system))
48         (sbcl-pwd (getenv-pathname "SBCL_PWD" :ensure-directory t))
49         (out-contrib (subpathname sbcl-pwd "obj/sbcl-home/contrib/"))
50         (cache-module (subpathname sbcl-pwd (format nil "obj/asdf-cache/~a/" name)))
51         (system (find-system name))
52         (system.fasl (output-file 'compile-bundle-op system))
53         (module.fasl (subpathname out-contrib (strcat name ".fasl")))
54         (module-setup.lisp (subpathname cache-module "module-setup.lisp"))
55           (module-setup.fasl (subpathname cache-module "module-setup.fasl"))
56         (dependencies (mapcar 'keywordize (component-sideway-dependencies system)))
57           (input-fasls (list module-setup.fasl system.fasl)))
58    (ensure-directories-exist out-contrib)
59    (ensure-directories-exist cache-module)
60    (with-open-file (o module-setup.lisp
61                       :direction :output :if-exists :rename-and-delete)
62      (format o "(provide :~A)~%~{(require ~(~S~))~%~}" name dependencies))
63    (compile-file module-setup.lisp :output-file module-setup.fasl)
64    (operate 'compile-bundle-op system)
65    (concatenate-files input-fasls module.fasl)))
66
67(defun test-asdf-contrib (system)
68  (pushnew :sb-testing-contrib *features*)
69  (setup-asdf-contrib)
70  (asdf:test-system system))
71