X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf-stub.lisp;h=e658e07822ced38212b051762ae06dd791b2b412;hb=54da325f13fb41669869aea688ae195426c0e231;hp=1baef5f29a888df688ce5b22caf888bbc50f1d87;hpb=b06500a7381d0d5a789034ab00e3f708e62805b1;p=sbcl.git

diff --git a/contrib/asdf-stub.lisp b/contrib/asdf-stub.lisp
index 1baef5f..e658e07 100644
--- a/contrib/asdf-stub.lisp
+++ b/contrib/asdf-stub.lisp
@@ -1,18 +1,70 @@
-(load "SYS:CONTRIB;ASDF;ASDF.FASL")
+(require :asdf)
 
-(let ((asdf:*central-registry* nil))
+(in-package :asdf)
+
+(defun keywordize (x)
+  (intern (string-upcase x) :keyword))
+
+(defun wrapping-source-registry ()
+  '(:source-registry (:tree #p"SYS:CONTRIB;") :ignore-inherited-configuration))
+
+
+(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*)
-  (asdf:operate 'asdf:load-op *system*)
-  (let ((stub (make-pathname :name *system* :type "lisp")))
-    (when (probe-file (compile-file-pathname stub))
-      (error "fasl file exists"))
-    (with-open-file (s stub :direction :output :if-exists :error)
-      (print '(unless (member "ASDF" *modules* :test #'string=)
-               (require :asdf))
-             s)
-      ;; we find our contribs without reference to *central-registry*.
-      (print `(let ((asdf:*central-registry* nil))
-               (asdf::module-provide-asdf ,*system*))
-             s))
-    (compile-file stub)
-    (delete-file stub)))
+  (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))