contrib/asdf-stub.lisp

   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))