Commit d29dfb9c authored by Antoine Martin's avatar Antoine Martin
Browse files

Use our own qlmapper

Using our own version allows to:

- Fix a bug that occured when qlmapper was called from another package:
  *compile-file-truename* would point to the other package's directory.

- Make more modifications to the way sbcl is called, including checking
  for the exit code and log the error if non null
parent 82b8ffef
......@@ -4,11 +4,11 @@
(ql:quickload "net.didierverna.declt")
(let ((primary-system
(quickref:get-primary-system-name cl-user::*qlmapper-object-name*)))
(quickref:get-primary-system-name cl-user::*qrmapper-object-name*)))
;; #### TODO: encapsulate this into an error catching form.
(format t "STARTED BUILDING PACKAGE ~A~%" primary-system)
(ql:quickload primary-system)
;; #### TODO: See about providing more information to the DECLT call.
(net.didierverna.declt:declt primary-system
:library cl-user::*qlmapper-object-name*)
:library cl-user::*qrmapper-object-name*)
(format t "FINISHED BUILDING PACKAGE ~A~%" primary-system))
(in-package #:cl-user)
(defmacro with-qrmapper-output ((stream file) &body body)
`(with-open-file (,stream ,file :direction :output
:if-exists :append
:if-does-not-exist :create)
(export 'with-qrmapper-output)
;; Shamelessly copied and adapted from:
(in-package quickref)
(defvar *sbcl-program* sb-ext:*runtime-pathname*)
(defvar *init-file* (merge-pathnames "qrmapper-init.lisp"
(asdf:system-source-directory "quickref")))
(defun native-truename (file)
(native-namestring (truename file)))
(defun eval-defvar-forms (environment-pairs)
(loop for (name value) on environment-pairs by #'cddr
for sym = (format nil "cl-user::~A" name)
collect "--eval"
collect (format nil "(defvar ~A (sb-posix:getenv ~S))" sym name)
collect "--eval"
collect (format nil "(export '~A '#:cl-user)" sym)))
(defun environment-list (environment-pairs)
(loop for (name value) on environment-pairs by #'cddr
collect (format nil "~A=~A" name value)))
(defun flatlist (&rest args)
(alexandria:flatten args))
(defun run-sbcl (&key file pre-file environment-pairs evals)
(run-program (native-truename *sbcl-program*)
(flatlist "--noinform"
"--load" (native-truename
(ql-setup:qmerge "setup.lisp"))
(eval-defvar-forms environment-pairs)
(format nil "(setf cl:*default-pathname-defaults* ~
(native-truename *default-pathname-defaults*))
(native-truename *init-file*)
(when pre-file
(list "--load" (native-truename pre-file)))
(mapcar (lambda (eval)
(list "--eval" eval))
"--load" (native-truename file))
:environment (append (environment-list environment-pairs)
:output *standard-output*))
(defgeneric base-directory (object)
(:method ((release ql-dist:release))
(ql-dist:base-directory release))
(:method ((system ql-dist:system))
(base-directory (ql-dist:release system))))
(defun map-objects (file
&key dist-name function (filter 'identity) evals pre-file)
(unless (probe-file file)
(error "~S does not exist" file))
(let ((dist (ql-dist:find-dist dist-name)))
(unless dist
(error "~S does not name any known dist" dist-name))
(let ((objects (funcall function dist)))
(dolist (object objects)
(let ((name (ql-dist:name object)))
(when (funcall filter name)
(ql-dist:ensure-installed object)
(let ((*default-pathname-defaults*
(base-directory object)))
(run-sbcl :file file
:pre-file pre-file
:environment-pairs (list "*qrmapper-object-name*"
:evals evals))))))))
(defun map-releases (file &key (dist-name "quicklisp") (filter 'identity)
"For each release in a dist (defaults to the \"quicklisp\" dist),
start an independent SBCL process and load FILE with the variable
CL-USER:*QRMAPPER-OBJECT-NAME* bound to the release's name."
(map-objects file
:pre-file pre-file
:dist-name dist-name
:function #'ql-dist:provided-releases
:filter filter))
......@@ -3,5 +3,6 @@
:depends-on (:quicklisp :alexandria :qlmapper :net.didierverna.declt.setup)
:serial t
:components ((:file "quickref")
(:file "qrmapper")
(:file "website")
(:file "file")))
(defpackage quickref
(:use :cl)
(:import-from :alexandria
(:import-from :sb-ext
(:export :print-primary-systems
......@@ -55,7 +58,7 @@ release.
The resulting .texi file is placed inside the release's directory, in
(clean-or-create (from-homedir "declt-logfiles/"))
(merge-pathnames "map-declt.lisp"
(asdf:system-source-directory "quickref"))))
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