Commit 4160b92f authored by Antoine Martin's avatar Antoine Martin
Browse files

Add support for other systems

parent c831d1e0
......@@ -57,6 +57,22 @@
:error-output :output
:ignore-error-status t))
(defun log-sbcl (system &key file pre-file environment-pairs evals)
(let* ((l (multiple-value-list (run-sbcl :file file
:pre-file pre-file
:environment-pairs environment-pairs
:evals evals)))
(output (first l))
(status (nth 2 l)))
(when (not (eql status 0))
(with-open-file (file
(from-quickref-dir
(format nil "logs/declt-map/~A.log" system))
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format file "~A~%" output)))))
(defgeneric base-directory (object)
(:method ((release ql-dist:release))
(ql-dist:base-directory release))
......@@ -77,23 +93,13 @@
(ql-dist:ensure-installed object)
(let ((*default-pathname-defaults*
(base-directory object)))
(let* ((l (multiple-value-list
(run-sbcl :file file
:pre-file pre-file
:environment-pairs
(list "*qrmapper-object-name*"
name)
:evals evals)))
(status (nth 2 l))
(output (first l)))
(when (not (eql status 0))
(with-open-file (file
(from-quickref-dir
(format nil "logs/declt-map/~A.log" name))
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format file "~A~%" output)))))))))))
(log-sbcl name
:file file
:pre-file pre-file
:environment-pairs
(list "*qrmapper-object-name*"
name)
:evals evals))))))))
(defun map-releases (file &key (dist-name "quicklisp") (filter 'identity)
pre-file)
......@@ -124,28 +130,16 @@
(ql-dist:ensure-installed object)
(let ((*default-pathname-defaults*
(base-directory object)))
(let* ((l (multiple-value-list
(run-sbcl :file file
:pre-file pre-file
:environment-pairs
(list "*qrmapper-object-name*"
name)
:evals evals)))
(status (nth 2 l))
(output (first l)))
(if (eql status 0)
(with-mutex (mutex)
(endpush name *buffer*)
(condition-notify waitqueue))
(with-open-file (file
(from-quickref-dir
(format nil "logs/declt-map/~A.log" name))
:direction :output
:if-exists :supersede
:if-does-not-exist :create)
(format file "~A~%" output))))))))))
(with-mutex (mutex)
(endpush :done *buffer*)))
(log-sbcl name
:file file
:pre-file pre-file
:environment-pairs
(list "*qrmapper-object-name*"
name)
:evals evals)
(with-mutex (mutex)
(endpush name *buffer*)
(condition-notify waitqueue)))))))))
(defun map-releases-thread (file mutex waitqueue
&key (dist-name "quicklisp") (filter 'identity)
......
......@@ -66,6 +66,14 @@
(dolist (release (ql-dist:provided-releases t))
(print (get-primary-system-name (ql-dist:name release)))))
(defparameter *other-systems* '("asdf" "quickref"))
(defun map-system (system)
(log-sbcl system
:file (merge-pathnames "map-declt.lisp"
(asdf:system-source-directory "quickref"))
:environment-pairs (list "*qrmapper-object-name*" system)))
(defun build-releases (&key (remove-cache *remove-cache*))
"Calls NET.DIDIERVERNA.DECLT:DECLT on the primary system of each Quicklisp
release.
......@@ -75,7 +83,9 @@ The resulting .texi file is placed inside the release's directory, in
(setup-quickref-dir :declt t)
(map-releases
(merge-pathnames "map-declt.lisp"
(asdf:system-source-directory "quickref")))))
(asdf:system-source-directory "quickref")))
(dolist (system *other-systems*)
(map-system system))))
(defvar *buffer* nil)
......@@ -91,6 +101,14 @@ The resulting .texi file is placed inside the release's directory, in
(asdf:system-source-directory "quickref"))
mutex
wq)
(dolist (system *other-systems*)
(map-system system)
(with-mutex (mutex)
(endpush system *buffer*)
(condition-notify wq)))
(with-mutex (mutex)
(endpush :done *buffer*)
(condition-notify wq))
(join-thread thread)))
(defun uninstall-releases ()
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment