Newer
Older
#+xcvb
(module
(:compile-depends-on ("simplifying-traversal" "commands")
:load-depends-on ("simplifying-traversal" "logging" "commands")))
(in-package :xcvb)
(defclass asdf-traversal (simplifying-traversal)
())
(defvar *target-builds* (make-hashset :test 'equal)
"A list of asdf system we supersede")
(defgeneric build-in-target-p (env build))
Francois-Rene Rideau
committed
(defmethod build-in-target-p ((env asdf-traversal) build)
(declare (ignorable env))
Francois-Rene Rideau
committed
(gethash (fullname build) *target-builds*))
Francois-Rene Rideau
committed
(defmethod issue-dependency ((env asdf-traversal) (grain lisp-module-grain))
(if (build-in-target-p env (build-module-grain-for grain))
Francois-Rene Rideau
committed
(call-next-method)
Francois-Rene Rideau
committed
(issue-asdf-equivalents env grain (typep grain 'build-module-grain)))
Francois-Rene Rideau
committed
(defun grain-asdf-equivalents (grain &optional (build (build-module-grain-for grain)))
(finalize-grain build)
Francois-Rene Rideau
committed
(loop :with fname = (fullname grain)
:with name = (etypecase grain
(build-module-grain fname)
(lisp-module-grain (second fname)))
Francois-Rene Rideau
committed
:for (asdf-name xcvb-name) :in (asdf-supersessions build)
:when (equal xcvb-name name)
:collect asdf-name))
(defun issue-asdf-equivalents (env grain errorp)
(let* ((build (build-module-grain-for grain))
(a (grain-asdf-equivalents grain build)))
(cond
(a
(dolist (s a)
(pushnew s *asdf-system-dependencies* :test 'equal))
(values))
((equal (fullname build) "/asdf")
(values)) ;; special case: ASDF is assumed to be there already when using an ASDF
Francois-Rene Rideau
committed
(errorp
(error "depending on grain ~A but it has no ASDF equivalent" (fullname build)))
((eq build grain)
(values))
(t
(issue-asdf-equivalents env build t)))))
(defmethod graph-for-build-module-grain ((env asdf-traversal) grain)
Francois-Rene Rideau
committed
(if (build-in-target-p env grain)
Francois-Rene Rideau
committed
(issue-asdf-equivalents env grain t))
(values))
(defun write-asd-prelude (s)
(format s
";;; This file was automatically generated by XCVB ~A with the arguments~%~
;;; ~{~A~^ ~}~%~
;;; It may have been specialized to the target implementation ~A~%~
;;; with the following features:~%~
Francois-Rene Rideau
committed
*xcvb-version* *arguments* *lisp-implementation-type* *features*))
(defun write-asd-file (&key build-names output-path asdf-name)
"Writes an asd file to OUTPUT-PATH
covering the builds specified by BUILD-NAMES.
Declare asd system as ASDF-NAME."
Francois-Rene Rideau
committed
(let* ((env (make-instance 'asdf-traversal))
(*use-cfasls* nil)
(*asdf-system-dependencies* nil)
(*require-dependencies* nil)
(builds (mapcar (lambda (n) (registered-build n :ensure-build t))
Francois-Rene Rideau
committed
build-names))
Francois-Rene Rideau
committed
(first-build (finalize-grain (first builds)))
Francois-Rene Rideau
committed
(or asdf-name
Francois-Rene Rideau
committed
(first (grain-asdf-equivalents first-build))
Francois-Rene Rideau
committed
(pathname-name (fullname first-build)))))
(default-output-path
(subpathname (grain-pathname first-build) (strcat asdf-name ".asd")))
(output-path
(if output-path
Francois-Rene Rideau
committed
(ensure-pathname-absolute output-path)
default-output-path)
default-output-path))
Francois-Rene Rideau
committed
(*target-builds* (make-hashset :test 'equal :list (mapcar #'fullname builds))))
(log-format 6 "T=~A building dependency graph" (get-universal-time))
(log-format 6 "T=~A creating asd file ~A" (get-universal-time) output-path)
:output-path output-path
:asdf-name asdf-name)))
(defun do-write-asd-file (env &key output-path asdf-name)
(let* ((output-path (merge-pathnames* output-path))
(_ (ensure-directories-exist output-path))
;; bind *default-pathname-defaults* to the asdf file's directory.
(*default-pathname-defaults* (pathname-directory-pathname output-path)))
(declare (ignore _))
(with-open-file (out output-path :direction :output :if-exists :supersede)
(write-asd-prelude out)
Francois-Rene Rideau
committed
(let ((form (make-asdf-form env asdf-name)))
(with-safe-io-syntax (:package :asdf)
(let ((*print-case* :downcase))
(format out "~@[~{(require ~S)~%~}~%~]" (reverse *require-dependencies*))
(write form :stream out :pretty t :miser-width 79)
(terpri out)))))))
(defun keywordify-asdf-name (name)
(kintern "~:@(~A~)" name))
(defgeneric asdf-spec (env grain))
(defmethod asdf-spec (env (grain lisp-file-grain))
Francois-Rene Rideau
committed
(let* ((namestring (grain-namestring env grain))
(pathname (pathname namestring))
(enough (enough-namestring namestring))
(noext (asdf-dependency-grovel::strip-extension enough "lisp"))
(around-compile (effective-around-compile grain))
(encoding (effective-encoding grain)))
Francois-Rene Rideau
committed
`(:file ,noext
,@(when (or (absolute-pathname-p (pathname enough))
Francois-Rene Rideau
committed
noext :type "lisp" :defaults *default-pathname-defaults*)
pathname)))
`(:pathname ,pathname))
,@(when around-compile
`(:around-compile ,around-compile))
,@(unless (eq encoding :utf-8)
`(:encoding ,encoding)))))
(defmethod asdf-spec (env (grain source-grain))
`(:static-file ,(enough-namestring (grain-namestring env grain))))
Francois-Rene Rideau
committed
(defmethod asdf-spec (env (build build-module-grain))
Francois-Rene Rideau
committed
(declare (ignorable env build))
;; should that be an error?
nil)
(defun make-asdf-form (env asdf-name)
;; we can assume computations is topologically sorted.
Francois-Rene Rideau
committed
;; TODO: ASDF is stupid, so we should try to optimize dependencies by removing extra ones:
;; for each dependency of current node, starting with the most recent one,
;; add the dependency and remove all those that it includes.
;; NOTE: we assume *default-pathname-defaults* is set to the destination directory
;; for the asdf file.
`(asdf:defsystem ,(keywordify-asdf-name asdf-name)
:depends-on ,(mapcar 'keywordify-asdf-name (reverse *asdf-system-dependencies*))
:encoding :utf-8
:components ,(loop :with visited = (make-hash-table :test 'equal)
:for computation :in (reverse *computations*)
:for lisp = (first (computation-inputs computation))
:for deps = (rest (computation-inputs computation))
:for spec = (and lisp (asdf-spec env lisp))
:for build = (and spec (build-module-grain-for lisp))
Francois-Rene Rideau
committed
:for includedp = (and build (build-in-target-p env build))
:for depends-on = (remove-duplicates
(loop :for dep :in deps
:for dspec = (asdf-spec env dep)
Francois-Rene Rideau
committed
:when (and dspec (typep dep 'lisp-file-grain)
(build-in-target-p env (build-module-grain-for dep)))
:collect (second dspec))
:test #'equal)
:for already-visited = (gethash spec visited)
:do (setf (gethash spec visited) t)
:when (and includedp (not already-visited)) :collect
`(,@spec ,@(when depends-on `(:depends-on ,depends-on))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; XCVB to ASDF ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-command xcvb-to-asdf-command
(("xcvb-to-asdf" "x2a")
(&rest keys &key)
`(,@+multi-build-option-spec+
(("name" #\n) :type string :optional t :documentation "name of the new ASDF system")
(("output-path" #\o) :type string :optional t :documentation "pathname for the new ASDF system")
,@+source-registry-option-spec+
,@+lisp-implementation-option-spec+
,@+verbosity-option-spec+)
"Extract an ASDF system from XCVB"
"Automatically extract an ASDF system from one or many XCVB builds."
(build name output-path))
(write-asd-file
:asdf-name name
:build-names (mapcar #'canonicalize-fullname build)
:output-path output-path))