Newer
Older
#+xcvb (module (:depends-on ("dependencies-interpreter" "commands")))
Francois-Rene Rideau
committed
(in-package :xcvb)
;;; LIST-GRAINS
(defparameter *grains-list* ())
(defparameter *grains-table* (make-hash-table :test 'equal))
Francois-Rene Rideau
committed
(defclass grain-listing-traversal (simplifying-traversal)
Francois-Rene Rideau
committed
())
(defmethod graph-for :around ((env grain-listing-traversal) spec)
(multiple-value-bind (v foundp) (gethash spec *grains-table*)
Francois-Rene Rideau
committed
(if foundp
v
(progn
Francois-Rene Rideau
committed
(let ((v (call-next-method)))
(setf (gethash spec *grains-table*) v)
(pushnew v *grains-list*)
Francois-Rene Rideau
committed
v)))))
Francois-Rene Rideau
committed
(defun list-grains (specs)
(let ((env (make-instance 'grain-listing-traversal))
(*grains-list* ())
(*grains-table* (make-hash-table :test 'equal)))
Francois-Rene Rideau
committed
(dolist (spec specs)
(build-command-for env spec))
Francois-Rene Rideau
committed
;;; TODO: some magic to break circularities that are due to flattening conditionals.
(define-build-command-for :when ((env grain-listing-traversal) expression &rest dependencies)
(declare (ignore expression))
Francois-Rene Rideau
committed
(build-command-for* env dependencies))
(define-build-command-for :cond ((env grain-listing-traversal) &rest cond-expressions)
Francois-Rene Rideau
committed
(dolist (cond-expression cond-expressions)
(build-command-for* env (cdr cond-expression))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; Remove XCVB ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-command remove-xcvb-command
(("remove-xcvb" "rm-x" "rmx" "rx")
(&rest keys &key)
`(,@+build-option-spec+
,@+source-registry-option-spec+
,@+verbosity-option-spec+)
"Remove XCVB modules from files in build"
"Given an XCVB build file, removes the XCVB modules from each of the files listed in the build file."
(build))
Francois-Rene Rideau
committed
(apply 'handle-global-options keys)
(remove-xcvb-from-build build))
(define-command list-files-command
(("list-files" "lf")
(&rest keys &key)
`(,@+multi-build-option-spec+
,@+source-registry-option-spec+
,@+verbosity-option-spec+
(("long" #\l) :type boolean :optional t :documentation "long format"))
"List files in a XCVB build"
"Given an XCVB build file, list all files that are directly part of that build."
(build long))
(log-format 10 "Listing files for build ~S~%" build)
;; TODO: Put handle-case here to trap the error for a noncanonical fullname
;; the the user is likely to type one day by accident.
Francois-Rene Rideau
committed
(loop :for spec :in build
:for (target bgrain) = (multiple-value-list (handle-target spec))
:collect target :into targets
:collect bgrain :into builds
:finally
(let* ((all-grains (list-grains targets))
(grains (remove-if-not
(lambda (grain)
(and (typep grain '(or lisp-module-grain source-grain))
(member (build-module-grain-for grain) builds)))
(remove-duplicates all-grains)))
(files (mapcar 'grain-pathname grains)))
(format t (if long "(~{~S~^~%~})~%" "~{~A~%~}") files))))
(define-command purge-xcvb-command
(("purge-xcvb" "pux" "px")
(files) ()
"Remove XCVB module statements from explicitly listed files"
"Given a list of files, remove the XCVB module statements from each Lisp file and delete specified build files.")
(initialize-environment)
(loop :for f :in files
:for p = (probe-file f) :do
(when p
(cond
((equal (cons (pathname-name p) (pathname-type p)) '("build" . "xcvb"))
(delete-file p))
((equal (pathname-type p) "lisp")
(log-format 4 "Removing module statements from ~A" p)
(remove-module-from-file p))))))
Francois-Rene Rideau
committed
;; Using the build.xcvb as a starting point, finds files and
;; strips XCVB modules from them.
(defun remove-xcvb-from-build (fullname)
(multiple-value-bind (target-dependency build) (handle-target fullname)
(log-format 7 "Removing XCVB from build ~A~% (path ~S)" build (grain-pathname build))
(flet ((source-lisp-grain-p (grain)
(log-format 7 "Inspecting grain ~A" grain)
(slot-boundp grain 'computation)
(null (grain-computation grain)))
(log-format 8 "This grain is in build ~A" (build-module-grain-for grain))
(log-format 9 "EQ: ~A EQUAL NAMES: ~A"
;; for some reason, the builds are different objects(!). HOW???
(eq build (build-module-grain-for grain))
(equal (fullname build) (fullname (build-module-grain-for grain))))
(equal (fullname build) (fullname (build-module-grain-for grain))))))
(dolist (grain (remove-if-not #'source-lisp-grain-p (list-grains (list target-dependency))))
(log-format 5 "Removing module declaration from ~A" (grain-pathname grain))
(remove-module-from-file (grain-pathname grain))))
(log-format 5 "Deleting build file for ~A" (grain-pathname build))
Francois-Rene Rideau
committed
(delete-file (grain-pathname build))))