-
Notifications
You must be signed in to change notification settings - Fork 0
/
asdf-stub.lisp
72 lines (65 loc) · 3.4 KB
/
asdf-stub.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
(setq *compile-print* nil)
sb-ext::(declaim (muffle-conditions compiler-note))
(require :asdf)
(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*)
(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 'compile-bundle-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 'compile-bundle-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))