contrib/asdf-stub.lisp

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