-(load "../asdf/asdf")
+(require :asdf)
-(setf asdf::*central-registry*
- '((merge-pathnames "systems/" (truename (sb-ext:posix-getenv "SBCL_HOME")))))
-(push :sb-building-contrib *features*)
-(asdf:operate 'asdf:load-op *system*)
+(in-package :asdf)
-(defvar *system-stub* (make-pathname :name *system* :type "lisp"))
+(defun keywordize (x)
+ (intern (string-upcase x) :keyword))
-(when (probe-file (compile-file-pathname *system-stub*))
- (error "fasl file exists"))
+(defun wrapping-source-registry ()
+ '(:source-registry (:tree #p"SYS:CONTRIB;") :ignore-inherited-configuration))
-(with-open-file (s *system-stub* :direction :output :if-exists :error)
- (print '(unless (member "ASDF" *modules* :test #'string=)
- (load (merge-pathnames "asdf/asdf.fasl" (truename (sb-ext:posix-getenv "SBCL_HOME")))))
- s)
- ;; This addition to *central-registry* allows us to find contribs
- ;; even if the user has frobbed the original contents.
- (print `(let ((asdf:*central-registry* (cons (merge-pathnames "systems/"
- (truename (sb-ext:posix-getenv "SBCL_HOME")))
- asdf:*central-registry*)))
- (asdf::module-provide-asdf ,*system*))
- s))
-(compile-file *system-stub*)
-(delete-file *system-stub*)
+(defun setup-asdf-contrib ()
+ ;;(setf *resolve-symlinks* nil)
+ (let* ((sbcl-pwd (getenv-pathname "SBCL_PWD" :ensure-directory t))
+ (src-contrib (subpathname sbcl-pwd "contrib/"))
+ (asdf-cache (subpathname sbcl-pwd "obj/asdf-cache/"))
+ (source-registry '(:source-registry :ignore-inherited-configuration))
+ (output-translations `(:output-translations (,(namestring src-contrib)
+ ,(namestring asdf-cache))
+ :ignore-inherited-configuration))
+ (src.pat (wilden src-contrib))
+ (src.dir.pat (merge-pathnames* *wild-inferiors* src-contrib))
+ (out.pat (wilden asdf-cache)))
+ (ensure-directories-exist asdf-cache)
+ (setf (logical-pathname-translations "SYS")
+ `(("CONTRIB;**;*.*.*" ,src.pat))) ;; this makes recursive tree search work.
+ (initialize-source-registry source-registry)
+ (initialize-output-translations output-translations)
+ (setf (logical-pathname-translations "SYS")
+ (labels ((typepat (type base)
+ `(,(format nil "CONTRIB;**;*.~:@(~A~).*" type)
+ ,(make-pathname :type (string-downcase type) :defaults base)))
+ (outpat (type) (typepat type out.pat))
+ (srcpat (type) (typepat type src.pat))
+ (outpats (&rest types) (mapcar #'outpat types))
+ (srcpats (&rest types) (mapcar #'srcpat types)))
+ `(,@(srcpats :lisp :asd)
+ ,@(outpats :fasl :sbcl-warnings :build-report
+ :out :exe :lisp-temp :o :c :test-report :html)
+ ("CONTRIB;**;" ,src.dir.pat)
+ #|("CONTRIB;**;*.*.*" ,src.pat)|#)))
+ (setf *central-registry* nil)))
+
+(defun build-asdf-contrib (system)
+ (push :sb-building-contrib *features*)
+ (setup-asdf-contrib)
+ (let* ((name (string-downcase system))
+ (sbcl-pwd (getenv-pathname "SBCL_PWD" :ensure-directory t))
+ (out-contrib (subpathname sbcl-pwd "obj/sbcl-home/contrib/"))
+ (cache-module (subpathname sbcl-pwd (format nil "obj/asdf-cache/~a/" name)))
+ (system (find-system name))
+ (system.fasl (output-file 'fasl-op system))
+ (module.fasl (subpathname out-contrib (strcat name ".fasl")))
+ (module-setup.lisp (subpathname cache-module "module-setup.lisp"))
+ (module-setup.fasl (subpathname cache-module "module-setup.fasl"))
+ (dependencies (mapcar 'keywordize (component-sideway-dependencies system)))
+ (input-fasls (list module-setup.fasl system.fasl)))
+ (ensure-directories-exist out-contrib)
+ (ensure-directories-exist cache-module)
+ (with-open-file (o module-setup.lisp
+ :direction :output :if-exists :rename-and-delete)
+ (format o "(provide :~A)~%~{(require ~(~S~))~%~}" name dependencies))
+ (compile-file module-setup.lisp :output-file module-setup.fasl)
+ (operate 'fasl-op system)
+ (concatenate-files input-fasls module.fasl)))
+
+(defun test-asdf-contrib (system)
+ (pushnew :sb-testing-contrib *features*)
+ (setup-asdf-contrib)
+ (asdf:test-system system))