Fix make-array transforms.

[sbcl.git] / contrib / asdf-stub.lisp

diff --git a/contrib/asdf-stub.lisp b/contrib/asdf-stub.lisp
index d084d72..e658e07 100644 (file)
--- a/contrib/asdf-stub.lisp
+++ b/contrib/asdf-stub.lisp
@@ -1,26 +1,70 @@
-(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))