Skip to content
Snippets Groups Projects
asdf.lisp 119 KiB
Newer Older
                               (shortcut (make-pathname
                                          :defaults defaults :version :newest
                                          :name name :type "asd.lnk" :case :local)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                          (if (and file (probe-file file))
                              (return file))
                          #+(and (or win32 windows) (not :clisp))
                          (when (probe-file shortcut)
                            (let ((target (parse-windows-shortcut shortcut)))
                              (when target
                                (return (pathname target)))))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                       (t
                        (restart-case
                            (let* ((*print-circle* nil)
                                   (message
                                    (format nil
                                            "~@<While searching for system `~a`: `~a` evaluated ~
to `~a` which is not a directory.~@:>"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                                            system dir defaults)))
                              (error message))
                          (remove-entry-from-registry ()
                            :report "Remove entry from *central-registry* and continue"
                            (push dir to-remove))
                          (coerce-entry-to-directory ()
                            :report (lambda (s)
                                      (format s "Coerce entry to ~a, replace ~a and continue."
                                              (ensure-directory-pathname defaults) dir))
                            (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
        ;; cleanup
        (dolist (dir to-remove)
          (setf *central-registry* (remove dir *central-registry*)))
        (dolist (pair to-replace)
          (let* ((current (car pair))
                 (new (cdr pair))
                 (position (position current *central-registry*)))
            (setf *central-registry*
                  (append (subseq *central-registry* 0 position)
                          (list new)
                          (subseq *central-registry* (1+ position))))))))))
Christophe Rhodes's avatar
Christophe Rhodes committed
(defun make-temporary-package ()
  (flet ((try (counter)
           (ignore-errors
             (make-package (format nil "~a~D" 'asdf counter)
                           :use '(:cl :asdf)))))
Christophe Rhodes's avatar
Christophe Rhodes committed
    (do* ((counter 0 (+ counter 1))
          (package (try counter) (try counter)))
         (package package))))
(defun safe-file-write-date (pathname)
           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
           ;; user or some other agent has deleted an input file.  If
           ;; that's the case, well, that's not good, but as long as
           ;; the operation is otherwise considered to be done we
           ;; could continue and survive.
  (or (file-write-date pathname)
      (progn
        (warn "Missing FILE-WRITE-DATE for ~S: treating it as zero."
              pathname)
        0)))
Daniel Barlow's avatar
 
Daniel Barlow committed
(defun find-system (name &optional (error-p t))
  (let* ((name (coerce-name name))
         (in-memory (system-registered-p name))
         (on-disk (system-definition-pathname name)))
Daniel Barlow's avatar
 
Daniel Barlow committed
    (when (and on-disk
               (or (not in-memory)
                   (< (car in-memory) (safe-file-write-date on-disk))))
Christophe Rhodes's avatar
Christophe Rhodes committed
      (let ((package (make-temporary-package)))
        (unwind-protect
             (with-open-file (asd on-disk :if-does-not-exist nil)
               (if asd
                   (let ((*package* package))
                     (asdf-message
                      "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
                      ;; FIXME: This wants to be (ENOUGH-NAMESTRING
                      ;; ON-DISK), but CMUCL barfs on that.
                      on-disk
                      *package*)
                   (error 'missing-definition :name name :pathname on-disk)))
Christophe Rhodes's avatar
Christophe Rhodes committed
          (delete-package package))))
    (let ((in-memory (system-registered-p name)))
Daniel Barlow's avatar
 
Daniel Barlow committed
      (if in-memory
          (progn (if on-disk (setf (car in-memory)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                                   (safe-file-write-date on-disk)))
                 (cdr in-memory))
          (if error-p (error 'missing-component :requires name))))))
Daniel Barlow's avatar
 
Daniel Barlow committed

(defun register-system (name system)
  (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
  (setf (gethash (coerce-name name) *defined-systems*)
        (cons (get-universal-time) system)))
Daniel Barlow's avatar
 
Daniel Barlow committed

;;;; -------------------------------------------------------------------------
;;;; Finding components
Daniel Barlow's avatar
Daniel Barlow committed

(defmethod find-component ((module module) name &optional version)
Daniel Barlow's avatar
Daniel Barlow committed
  (if (slot-boundp module 'components)
      (let ((m (find name (module-components module)
                     :test #'equal :key #'component-name)))
        (if (and m (version-satisfies m version)) m))))

Daniel Barlow's avatar
Daniel Barlow committed

;;; a component with no parent is a system
(defmethod find-component ((module (eql nil)) name &optional version)
  (declare (ignorable module))
Daniel Barlow's avatar
 
Daniel Barlow committed
  (let ((m (find-system name nil)))
    (if (and m (version-satisfies m version)) m)))
Daniel Barlow's avatar
Daniel Barlow committed

Daniel Barlow's avatar
 
Daniel Barlow committed
;;; component subclasses

Daniel Barlow's avatar
Daniel Barlow committed
(defclass source-file (component) ())

(defclass cl-source-file (source-file) ())
Daniel Barlow's avatar
Daniel Barlow committed
(defclass c-source-file (source-file) ())
(defclass java-source-file (source-file) ())
(defclass static-file (source-file) ())
(defclass doc-file (static-file) ())
(defclass html-file (doc-file) ())
Daniel Barlow's avatar
Daniel Barlow committed

(defmethod source-file-type ((component module) (s module)) :directory)
Daniel Barlow's avatar
Daniel Barlow committed
(defmethod source-file-type ((c cl-source-file) (s module)) "lisp")
(defmethod source-file-type ((c c-source-file) (s module)) "c")
(defmethod source-file-type ((c java-source-file) (s module)) "java")
Daniel Barlow's avatar
 
Daniel Barlow committed
(defmethod source-file-type ((c html-file) (s module)) "html")
(defmethod source-file-type ((c static-file) (s module)) nil)

(defun merge-component-name-type (name &key type defaults)
  ;; The defaults are required notably because they provide the default host
  ;; to the below make-pathname, which may crucially matter to people using
  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
  ;; NOTE that the host and device slots will be taken from the defaults,
  ;; but that should only matter if you either (a) use absolute pathnames, or
  ;; (b) later merge relative pathnames with CL:MERGE-PATHNAMES instead of
  ;; ASDF:MERGE-PATHNAMES*
     (merge-component-name-type (string-downcase name) :type type :defaults defaults))
    (string
     (multiple-value-bind (relative path filename)
         (component-name-to-pathname-components name (eq type :directory))
       (multiple-value-bind (name type)
           (cond
             ((or (eq type :directory) (null filename))
              (values nil nil))
             (type
              (values filename type))
             (t
              (split-name-type filename)))
         (let* ((defaults (pathname (or defaults *default-pathname-defaults*)))
                (host (pathname-host defaults))
                (device (pathname-device defaults)))
           (make-pathname :directory `(,relative ,@path)
                          :name name :type type
                          :host host :device device)))))))

(defmethod component-relative-pathname ((component component))
  (merge-component-name-type
   (or (slot-value component 'relative-pathname)
       (component-name component))
   :type (source-file-type component (component-system component))
   :defaults (let ((parent (component-parent component)))
               (and parent (component-pathname parent)))))
;;;; -------------------------------------------------------------------------
;;;; Operations
Daniel Barlow's avatar
Daniel Barlow committed

;;; one of these is instantiated whenever #'operate is called
Daniel Barlow's avatar
Daniel Barlow committed

(defclass operation ()
  (
   ;; what is the TYPE of this slot?  seems like it should be boolean,
   ;; but TRAVERSE checks to see if it's a list of component names...
   ;; [2010/02/07:rpg]
   (forced :initform nil :initarg :force :accessor operation-forced)
   (original-initargs :initform nil :initarg :original-initargs
                      :accessor operation-original-initargs)
   (visited-nodes :initform nil :accessor operation-visited-nodes)
   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
   (parent :initform nil :initarg :parent :accessor operation-parent)))

(defmethod print-object ((o operation) stream)
  (print-unreadable-object (o stream :type t :identity t)
    (ignore-errors
      (prin1 (operation-original-initargs o) stream))))

(defmethod shared-initialize :after ((operation operation) slot-names
                                     &key force
                                     &allow-other-keys)
  (declare (ignorable operation slot-names force))
  ;; empty method to disable initarg validity checking
  )
Daniel Barlow's avatar
Daniel Barlow committed

(defun node-for (o c)
  (cons (class-name (class-of o)) c))

(defmethod operation-ancestor ((operation operation))
  (aif (operation-parent operation)
       (operation-ancestor it)
       operation))


(defun make-sub-operation (c o dep-c dep-o)
  "C is a component, O is an operation, DEP-C is another
component, and DEP-O, confusingly enough, is an operation
class specifier, not an operation."
  (let* ((args (copy-list (operation-original-initargs o)))
         (force-p (getf args :force)))
    ;; note explicit comparison with T: any other non-NIL force value
    ;; (e.g. :recursive) will pass through
    (cond ((and (null (component-parent c))
                (null (component-parent dep-c))
                (not (eql c dep-c)))
           (when (eql force-p t)
             (setf (getf args :force) nil))
           (apply #'make-instance dep-o
                  :parent o
                  :original-initargs args args))
          ((subtypep (type-of o) dep-o)
           o)
          (t
           (apply #'make-instance dep-o
                  :parent o :original-initargs args args)))))
Daniel Barlow's avatar
 
Daniel Barlow committed
(defmethod visit-component ((o operation) (c component) data)
  (unless (component-visited-p o c)
    (push (cons (node-for o c) data)
          (operation-visited-nodes (operation-ancestor o)))))
Daniel Barlow's avatar
Daniel Barlow committed

(defmethod component-visited-p ((o operation) (c component))
Daniel Barlow's avatar
 
Daniel Barlow committed
  (assoc (node-for o c)
         (operation-visited-nodes (operation-ancestor o))
         :test 'equal))
Daniel Barlow's avatar
Daniel Barlow committed

(defmethod (setf visiting-component) (new-value operation component)
  ;; MCL complains about unused lexical variables
  (declare (ignorable new-value operation component)))
Daniel Barlow's avatar
Daniel Barlow committed
(defmethod (setf visiting-component) (new-value (o operation) (c component))
  (let ((node (node-for o c))
        (a (operation-ancestor o)))
        (pushnew node (operation-visiting-nodes a) :test 'equal)
        (setf (operation-visiting-nodes a)
              (remove node  (operation-visiting-nodes a) :test 'equal)))))
Daniel Barlow's avatar
Daniel Barlow committed

(defmethod component-visiting-p ((o operation) (c component))
  (let ((node (node-for o c)))
    (member node (operation-visiting-nodes (operation-ancestor o))
            :test 'equal)))
Daniel Barlow's avatar
Daniel Barlow committed

(defmethod component-depends-on ((op-spec symbol) (c component))
  (component-depends-on (make-instance op-spec) c))

(defmethod component-depends-on ((o operation) (c component))
  (cdr (assoc (class-name (class-of o))
Daniel Barlow's avatar
 
Daniel Barlow committed
(defmethod component-self-dependencies ((o operation) (c component))
  (let ((all-deps (component-depends-on o c)))
    (remove-if-not (lambda (x)
                     (member (component-name c) (cdr x) :test #'string=))
                   all-deps)))

Daniel Barlow's avatar
 
Daniel Barlow committed
(defmethod input-files ((operation operation) (c component))
  (let ((parent (component-parent c))
        (self-deps (component-self-dependencies operation c)))
Daniel Barlow's avatar
 
Daniel Barlow committed
    (if self-deps
        (mapcan (lambda (dep)
                  (destructuring-bind (op name) dep
                    (output-files (make-instance op)
                                  (find-component parent name))))
                self-deps)
        ;; no previous operations needed?  I guess we work with the
        ;; original source file, then
        (list (component-pathname c)))))
Daniel Barlow's avatar
 
Daniel Barlow committed

(defmethod input-files ((operation operation) (c module)) nil)
Daniel Barlow's avatar
 
Daniel Barlow committed
(defmethod operation-done-p ((o operation) (c component))
  (let ((out-files (output-files o c))
        (in-files (input-files o c))
        (op-time (gethash (type-of o) (component-operation-times c))))
    (flet ((earliest-out ()
             (reduce #'min (mapcar #'safe-file-write-date out-files)))
           (latest-in ()
             (reduce #'max (mapcar #'safe-file-write-date in-files))))
      (cond
        ((and (not in-files) (not out-files))
         ;; arbitrary decision: an operation that uses nothing to
         ;; produce nothing probably isn't doing much.
         ;; e.g. operations on systems, modules that have no immediate action,
         ;; but are only meaningful through traversed dependencies
         t)
        ((not out-files)
         ;; an operation without output-files is probably meant
         ;; for its side-effects in the current image,
         ;; assumed to be idem-potent,
         ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
         (and op-time
              (>= op-time (latest-in))))
        ((not in-files)
         ;; an operation without output-files and no input-files
         ;; is probably meant for its side-effects on the file-system,
         ;; assumed to have to be done everytime.
         ;; (I don't think there is any such case in ASDF unless extended)
         nil)
        (t
         ;; an operation with both input and output files is assumed
         ;; as computing the latter from the former,
         ;; assumed to have been done if the latter are all older
         ;; than the former.
         ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
         (and
          (every #'probe-file in-files)
          (every #'probe-file out-files)
          (and (> (earliest-out) (latest-in)))))))))

Daniel Barlow's avatar
Daniel Barlow committed
;;; So you look at this code and think "why isn't it a bunch of
;;; methods".  And the answer is, because standard method combination
;;; runs :before methods most->least-specific, which is back to front
;;; for our purposes.
Daniel Barlow's avatar
Daniel Barlow committed

(defvar *forcing* nil
  "This dynamically-bound variable is used to force operations in
recursive calls to traverse.")

Daniel Barlow's avatar
Daniel Barlow committed
(defmethod traverse ((operation operation) (c component))
  (let ((forced nil))                   ;return value -- everyone side-effects onto this
    (labels ((%do-one-dep (required-op required-c required-v)
               ;; returns a partial plan that results from performing required-op
               ;; on required-c, possibly with a required-vERSION
               (let* ((dep-c (or (find-component
                                  (component-parent c)
                                  ;; XXX tacky.  really we should build the
                                  ;; in-order-to slot with canonicalized
                                  ;; names instead of coercing this late
                                  (coerce-name required-c) required-v)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                                 (if required-v
                                     (error 'missing-dependency-of-version
                                            :required-by c
                                            :version required-v
                                            :requires required-c)
                                     (error 'missing-dependency
                                            :required-by c
                                            :requires required-c))))
                      (op (make-sub-operation c operation dep-c required-op)))
                 (traverse op dep-c)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
             (do-one-dep (required-op required-c required-v)
               ;; this function is a thin, error-handling wrapper around
               ;; %do-one-dep.  Returns a partial plan per that function.
               (loop
                 (restart-case
                     (return (%do-one-dep required-op required-c required-v))
                   (retry ()
                     :report (lambda (s)
                               (format s "~@<Retry loading component ~S.~@:>"
                                       required-c))
                     :test
                     (lambda (c)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                        (print (list :c1 c (typep c 'missing-dependency)))
                        (when (typep c 'missing-dependency)
                          (print (list :c2 (missing-requires c) required-c
                                       (equalp (missing-requires c)
                                               required-c))))
                       (or (null c)
                           (and (typep c 'missing-dependency)
                                (equalp (missing-requires c)
                                        required-c))))))))
             (do-dep (op dep)
               ;; type of arguments uncertain:  op seems to at least potentially be a
               ;; symbol, rather than an operation
               ;; dep is either a list of component names (?) or (we hope) a single
               ;; component name.
               ;; handle a single dependency, returns nothing of interest --- side-
               ;; effects onto the FORCED variable, which is scoped over TRAVERSE
               (cond ((eq op 'feature)
                      (or (member (car dep) *features*)
                          (error 'missing-dependency
                                 :required-by c
                     (t
                      (dolist (d dep)
                        ;; structured dependencies --- this parses keywords
                        ;; the keywords could be broken out and cleanly (extensibly)
                        ;; processed by EQL methods, but for the pervasive side-effecting
                        ;; onto FORCED
Daniel Barlow's avatar
 
Daniel Barlow committed
                        (cond ((consp d)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                               (cond ((string-equal
                                       (symbol-name (first d))
                                       "VERSION")
                                      (appendf
                                       forced
                                       (do-one-dep op (second d) (third d))))
                                     ;; this particular subform is not documented, indeed
                                     ;; clashes with the documentation, since it assumes a
                                     ;; third component
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                                     ((and (string-equal
                                            (symbol-name (first d))
                                            "FEATURE")
                                           (find (second d) *features*
                                                 :test 'string-equal))
                                      (appendf
                                       forced
                                       (do-one-dep op (second d) (third d))))
                                     (t
                                      (error "Bad dependency ~a.  Dependencies must be (:version <version>), (:feature <feature> [version]), or a name" d))))
Daniel Barlow's avatar
 
Daniel Barlow committed
                              (t
                               (appendf forced (do-one-dep op d nil)))))))))
      (aif (component-visited-p operation c)
           (return-from traverse
             (if (cdr it) (list (cons 'pruned-op c)) nil)))
Daniel Barlow's avatar
 
Daniel Barlow committed
      ;; dependencies
      (if (component-visiting-p operation c)
          (error 'circular-dependency :components (list c)))
Daniel Barlow's avatar
 
Daniel Barlow committed
      (setf (visiting-component operation c) t)
      (unwind-protect
            ;; first we check and do all the dependencies for the
            ;; module.  Operations planned in this loop will show up
            ;; in the contents of the FORCED variable, and are consumed
            ;; downstream (watch out for the shadowing FORCED variable
            ;; around the DOLIST below!)
            (let ((*forcing* nil))
              ;; upstream dependencies are never forced to happen just because
              ;; the things that depend on them are....
              (loop :for (required-op . deps) :in
                                              (component-depends-on operation c)
                    :do (do-dep required-op deps)))
            ;; constituent bits
            (let ((module-ops
                   (when (typep c 'module)
                     (let ((at-least-one nil)
                           (forced nil)
                           ;; this is set based on the results of the
                           ;; dependencies and whether we are in the
                           ;; context of a *forcing* call...
                           (must-operate (or *forcing*
                                             ;; inter-system dependencies do NOT trigger
                                             ;; building components
                                             (and
                                              (not (typep c 'system))
                                              forced)))
                           (error nil))
                       (dolist (kid (module-components c))
                           (handler-case
                               (let ((*forcing* must-operate))
                                 (appendf forced (traverse operation kid)))
                             (missing-dependency (condition)
                               (when (eq (module-if-component-dep-fails c)
                                       :fail)
                                   (error condition))
                               (setf error condition))
                             (:no-error (c)
                               (declare (ignore c))
                               (setf at-least-one t))))
                       (when (and (eq (module-if-component-dep-fails c)
                                      :try-next)
                                  (not at-least-one))
                         (error error))
                       forced))))
              ;; now the thing itself
              ;; the test here is a bit oddly written.  FORCED here doesn't
              ;; mean that this operation is forced on this component, but that
              ;; something upstream of this component has been forced.
              (when (or forced module-ops
                        (not (operation-done-p operation c))
                        (let ((f (operation-forced
                                  (operation-ancestor operation))))
                          ;; does anyone fully understand the following condition?
                          ;; if so, please add a comment to explain it...
                          (and f (or (not (consp f))
                                     (member (component-name
                                              (operation-ancestor operation))
                                             (mapcar #'coerce-name f)
                                             ;; this was string=, but for the benefit
                                             ;; of mlisp, we use string-equal for this
                                             ;; purpose.
                                             :test #'string-equal)))))
                (let ((do-first (cdr (assoc (class-name (class-of operation))
                                            (component-do-first c)))))
                  (loop :for (required-op . deps) :in do-first
                        :do (do-dep required-op deps)))
                (setf forced (append (delete 'pruned-op forced :key #'car)
                                     (delete 'pruned-op module-ops :key #'car)
                                     (list (cons operation c)))))))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        (setf (visiting-component operation c) nil))
Daniel Barlow's avatar
 
Daniel Barlow committed
      (visit-component operation c (and forced t))
      forced)))
Daniel Barlow's avatar
Daniel Barlow committed

(defmethod perform ((operation operation) (c source-file))
   "~@<required method PERFORM not implemented ~
    for operation ~A, component ~A~@:>"
Daniel Barlow's avatar
Daniel Barlow committed
   (class-of operation) (class-of c)))

(defmethod perform ((operation operation) (c module))
  nil)

(defmethod explain ((operation operation) (component component))
  (asdf-message "~&;;; ~A on ~A~%" operation component))
Daniel Barlow's avatar
Daniel Barlow committed

;;;; -------------------------------------------------------------------------
;;;; compile-op
Daniel Barlow's avatar
Daniel Barlow committed

(defclass compile-op (operation)
  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
Daniel Barlow's avatar
 
Daniel Barlow committed
   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
                :initform *compile-file-warnings-behaviour*)
Daniel Barlow's avatar
 
Daniel Barlow committed
   (on-failure :initarg :on-failure :accessor operation-on-failure
               :initform *compile-file-failure-behaviour*)
   (flags :initarg :flags :accessor compile-op-flags
          :initform #-ecl nil #+ecl '(:system-p t))))

(defmethod perform :before ((operation compile-op) (c source-file))
  (map nil #'ensure-directories-exist (output-files operation c)))
#+ecl
(defmethod perform :after ((o compile-op) (c cl-source-file))
  ;; Note how we use OUTPUT-FILES to find the binary locations
  ;; This allows the user to override the names.
  (let* ((input (output-files o c))
         (output (compile-file-pathname (first input) :type :fasl)))
    (c:build-fasl output :lisp-files (remove "fas" input :key #'pathname-type :test #'string=))))

Daniel Barlow's avatar
 
Daniel Barlow committed
(defmethod perform :after ((operation operation) (c component))
  (setf (gethash (type-of operation) (component-operation-times c))
        (get-universal-time)))
Daniel Barlow's avatar
Daniel Barlow committed

;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(defmethod perform ((operation compile-op) (c cl-source-file))
  #-:broken-fasl-loader
  (let ((source-file (component-pathname c))
        (output-file (car (output-files operation c))))
Daniel Barlow's avatar
Daniel Barlow committed
    (multiple-value-bind (output warnings-p failure-p)
        (apply #'compile-file source-file :output-file output-file
               (compile-op-flags operation))
Daniel Barlow's avatar
 
Daniel Barlow committed
      (when warnings-p
        (case (operation-on-warnings operation)
          (:warn (warn
                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
                  operation c))
          (:error (error 'compile-warned :component c :operation operation))
          (:ignore nil)))
Daniel Barlow's avatar
 
Daniel Barlow committed
      (when failure-p
        (case (operation-on-failure operation)
          (:warn (warn
                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
                  operation c))
          (:error (error 'compile-failed :component c :operation operation))
          (:ignore nil)))
        (error 'compile-error :component c :operation operation)))))
Daniel Barlow's avatar
Daniel Barlow committed

(defmethod output-files ((operation compile-op) (c cl-source-file))
  #-:broken-fasl-loader
  (list #-ecl (compile-file-pathname (component-pathname c))
        #+ecl (compile-file-pathname (component-pathname c) :type :object)
        #+ecl (compile-file-pathname (component-pathname c) :type :fasl))
  #+:broken-fasl-loader (list (component-pathname c)))
Daniel Barlow's avatar
Daniel Barlow committed

Daniel Barlow's avatar
Daniel Barlow committed
(defmethod perform ((operation compile-op) (c static-file))
  nil)

(defmethod output-files ((operation compile-op) (c static-file))
  nil)

(defmethod input-files ((op compile-op) (c static-file))
  nil)


;;;; -------------------------------------------------------------------------
;;;; load-op
Daniel Barlow's avatar
Daniel Barlow committed

(defclass basic-load-op (operation) ())

(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
  #-ecl (mapcar #'load (input-files o c))
  #+ecl (loop :for i :in (input-files o c)
          :unless (string= (pathname-type i) "fas")
          :collect (let ((output (compile-file-pathname i)))
                     (load output))))
Daniel Barlow's avatar
Daniel Barlow committed

(defmethod perform around ((o load-op) (c cl-source-file))
    (loop :until (or (eq state :success)
                     (eq state :failure)) :do
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
         (case state
           (:recompiled
            (setf state :failure)
            (call-next-method)
            (setf state :success))
           (:failed-load
            (setf state :recompiled)
            (perform (make-instance 'asdf:compile-op) c))
           (t
            (with-simple-restart
                (try-recompiling "Recompile ~a and try loading it again"
                                  (component-name c))
              (setf state :failed-load)
              (call-next-method)
              (setf state :success)))))))
(defmethod perform around ((o compile-op) (c cl-source-file))
    (loop :until (or (eq state :success)
                     (eq state :failure)) :do
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
         (case state
           (:recompiled
            (setf state :failure)
            (call-next-method)
            (setf state :success))
           (:failed-compile
            (setf state :recompiled)
            (perform (make-instance 'asdf:compile-op) c))
           (t
            (with-simple-restart
                (try-recompiling "Try recompiling ~a"
                                  (component-name c))
              (setf state :failed-compile)
              (call-next-method)
              (setf state :success)))))))
Daniel Barlow's avatar
Daniel Barlow committed
(defmethod perform ((operation load-op) (c static-file))
  nil)
Daniel Barlow's avatar
 
Daniel Barlow committed
(defmethod operation-done-p ((operation load-op) (c static-file))
  t)
Daniel Barlow's avatar
 
Daniel Barlow committed
(defmethod output-files ((o operation) (c component))
Daniel Barlow's avatar
Daniel Barlow committed
  nil)
(defmethod component-depends-on ((operation load-op) (c component))
  (cons (list 'compile-op (component-name c))
        (call-next-method)))

;;;; -------------------------------------------------------------------------
;;;; load-source-op
(defclass load-source-op (basic-load-op) ())

(defmethod perform ((o load-source-op) (c cl-source-file))
  (let ((source (component-pathname c)))
    (setf (component-property c 'last-loaded-as-source)
          (and (load source)
               (get-universal-time)))))

(defmethod perform ((operation load-source-op) (c static-file))
  nil)

(defmethod output-files ((operation load-source-op) (c component))
  nil)

;;; FIXME: we simply copy load-op's dependencies.  this is Just Not Right.
(defmethod component-depends-on ((o load-source-op) (c component))
  (let ((what-would-load-op-do (cdr (assoc 'load-op
    (mapcar (lambda (dep)
              (if (eq (car dep) 'load-op)
                  (cons 'load-source-op (cdr dep))
                  dep))
            what-would-load-op-do)))

(defmethod operation-done-p ((o load-source-op) (c source-file))
  (if (or (not (component-property c 'last-loaded-as-source))
          (> (safe-file-write-date (component-pathname c))
             (component-property c 'last-loaded-as-source)))

;;;; -------------------------------------------------------------------------
;;;; test-op

(defclass test-op (operation) ())

(defmethod perform ((operation test-op) (c component))
  nil)
(defmethod operation-done-p ((operation test-op) (c system))
  "Testing a system is _never_ done."
  nil)

(defmethod component-depends-on :around ((o test-op) (c system))
  (cons `(load-op ,(component-name c)) (call-next-method)))


;;;; -------------------------------------------------------------------------
;;;; Invoking Operations
Daniel Barlow's avatar
Daniel Barlow committed

(defun operate (operation-class system &rest args &key (verbose t) version force
                &allow-other-keys)
  (declare (ignore force))
  (let* ((*package* *package*)
         (*readtable* *readtable*)
         (op (apply #'make-instance operation-class
                    :original-initargs args
                    args))
         (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
         (system (if (typep system 'component) system (find-system system))))
    (unless (version-satisfies system version)
      (error 'missing-component-of-version :requires system :version version))
    (let ((steps (traverse op system)))
      (with-compilation-unit ()
        (loop :for (op . component) :in steps :do
          (loop
            (restart-case
                (progn (perform op component)
                       (return))
              (retry ()
                :report
                (lambda (s)
                  (format s "~@<Retry performing ~S on ~S.~@:>"
                          op component)))
              (accept ()
                :report
                (lambda (s)
                  (format s "~@<Continue, treating ~S on ~S as ~
                                   having been successful.~@:>"
                          op component))
                (setf (gethash (type-of op)
                               (component-operation-times component))
                      (get-universal-time))
                (return)))))))
Gary King's avatar
Gary King committed
    op))
Daniel Barlow's avatar
Daniel Barlow committed

(defun oos (operation-class system &rest args &key force (verbose t) version
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
            &allow-other-keys)
  (declare (ignore force verbose version))
  (apply #'operate operation-class system args))

(let ((operate-docstring
  "Operate does three things:

1. It creates an instance of `operation-class` using any keyword parameters
as initargs.
2. It finds the  asdf-system specified by `system` (possibly loading
it from disk).
3. It then calls `traverse` with the operation and system as arguments

The traverse operation is wrapped in `with-compilation-unit` and error
handling code. If a `version` argument is supplied, then operate also
ensures that the system found satisfies it using the `version-satisfies`
Gary King's avatar
Gary King committed
method.

Note that dependencies may cause the operation to invoke other
operations on the system or its components: the new operations will be
created with the same initargs as the original one.
"))
  (setf (documentation 'oos 'function)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        (format nil
                "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                operate-docstring))
  (setf (documentation 'operate 'function)
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
        operate-docstring))
(defun load-system (system &rest args &key force (verbose t) version
                    &allow-other-keys)
  "Shorthand for `(operate 'asdf:load-op system)`. See OPERATE for
  (declare (ignore force verbose version))
  (apply #'operate 'load-op system args))

(defun compile-system (system &rest args &key force (verbose t) version
                       &allow-other-keys)
  "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
  (declare (ignore force verbose version))
  (apply #'operate 'compile-op system args))

(defun test-system (system &rest args &key force (verbose t) version
                    &allow-other-keys)
  "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
  (declare (ignore force verbose version))
  (apply #'operate 'test-op system args))
;;;; -------------------------------------------------------------------------
;;;; Defsystem

(defun determine-system-pathname (pathname pathname-supplied-p)
  ;; called from the defsystem macro.
  ;; the pathname of a system is either
  ;; 1. the one supplied,
  ;; 2. derived from the *load-truename* (see below), or
  ;; 3. taken from *default-pathname-defaults*
  ;;
  ;; if using *load-truename*, then we also deal with whether or not
  ;; to resolve symbolic links. If not resolving symlinks, then we use
  ;; *load-pathname* instead of *load-truename* since in some
  ;; implementations, the latter has *already resolved it.
  (or (and pathname-supplied-p pathname)
      (when *load-pathname*
        (pathname-directory-pathname
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
         (if *resolve-symlinks*
             (resolve-symlinks *load-truename*)
             *load-pathname*)))
Daniel Barlow's avatar
Daniel Barlow committed
(defmacro defsystem (name &body options)
  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
                            &allow-other-keys)
    (let ((component-options (remove-keyword :class options)))
Daniel Barlow's avatar
 
Daniel Barlow committed
      `(progn
         ;; system must be registered before we parse the body, otherwise
         ;; we recur when trying to find an existing system of the same name
         ;; to reuse options (e.g. pathname) from
         (let ((s (system-registered-p ',name)))
           (cond ((and s (eq (type-of (cdr s)) ',class))
                  (setf (car s) (get-universal-time)))
                 (s
                  (change-class (cdr s) ',class))
                 (t
                  (register-system (quote ,name)
                                   (make-instance ',class :name ',name))))
           (%set-system-source-file *load-truename*
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                                    (cdr (system-registered-p ',name))))
         (parse-component-form
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
          nil (apply
               #'list
               :module (coerce-name ',name)
               :pathname
               ,(determine-system-pathname pathname pathname-arg-p)
               ',component-options))))))

(defun class-for-type (parent type)
  (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
                              (find-symbol (symbol-name type)
                                            (package-name :asdf)))))
         (class (dolist (symbol (if (keywordp type)
                                    extra-symbols
                                    (cons type extra-symbols)))
                  (when (and symbol
                             (find-class symbol nil)
                             (subtypep symbol 'component))
                    (return (find-class symbol))))))
        (and (eq type :file)
             (or (module-default-component-class parent)
                 (find-class 'cl-source-file)))
        (sysdef-error "~@<don't recognize component type ~A~@:>" type))))

(defun maybe-add-tree (tree op1 op2 c)
  "Add the node C at /OP1/OP2 in TREE, unless it's there already.
Returns the new tree (which probably shares structure with the old one)"
  (let ((first-op-tree (assoc op1 tree)))
    (if first-op-tree
        (progn
          (aif (assoc op2 (cdr first-op-tree))
               (if (find c (cdr it))
                   nil
                   (setf (cdr it) (cons c (cdr it))))
               (setf (cdr first-op-tree)
                     (acons op2 (list c) (cdr first-op-tree))))
          tree)
        (acons op1 (list (list op2 c)) tree))))

(defun union-of-dependencies (&rest deps)
  (let ((new-tree nil))
    (dolist (dep deps)
      (dolist (op-tree dep)
        (dolist (op  (cdr op-tree))
          (dolist (c (cdr op))
            (setf new-tree
                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
(defun sysdef-error-component (msg type name value)
  (sysdef-error (concatenate 'string msg
                             "~&The value specified for ~(~A~) ~A is ~W")
                type name value))

(defun check-component-input (type name weakly-depends-on
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
                              depends-on components in-order-to)
  "A partial test of the values of a component."
  (unless (listp depends-on)
    (sysdef-error-component ":depends-on must be a list."
                            type name depends-on))
  (unless (listp weakly-depends-on)
    (sysdef-error-component ":weakly-depends-on must be a list."
                            type name weakly-depends-on))
  (unless (listp components)
    (sysdef-error-component ":components must be NIL or a list of components."
                            type name components))
  (unless (and (listp in-order-to) (listp (car in-order-to)))
    (sysdef-error-component ":in-order-to must be NIL or a list of components."
                            type name in-order-to)))

Gary King's avatar
Gary King committed
(defun %remove-component-inline-methods (component)
  (dolist (name +asdf-methods+)
    (map ()
         ;; this is inefficient as most of the stored
         ;; methods will not be for this particular gf n
         ;; But this is hardly performance-critical
         (lambda (m)
           (remove-method (symbol-function name) m))
         (component-inline-methods component)))
  ;; clear methods, then add the new ones
Gary King's avatar
Gary King committed
  (setf (component-inline-methods component) nil))

(defun %define-component-inline-methods (ret rest)
  (dolist (name +asdf-methods+)
    (let ((keyword (intern (symbol-name name) :keyword)))
      (loop :for data = rest :then (cddr data)
        :for key = (first data)
        :for value = (second data)
        :while data
        :when (eq key keyword) :do
        (destructuring-bind (op qual (o c) &body body) value
          (pushnew
           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
                             ,@body))
           (component-inline-methods ret)))))))
Gary King's avatar
Gary King committed

(defun %refresh-component-inline-methods (component rest)
  (%remove-component-inline-methods component)
  (%define-component-inline-methods component rest))
(defun parse-component-form (parent options)
  (destructuring-bind
        (type name &rest rest &key
              ;; the following list of keywords is reproduced below in the
              ;; remove-keys form.  important to keep them in sync
              components pathname default-component-class
              perform explain output-files operation-done-p
              weakly-depends-on
              depends-on serial in-order-to
              ;; list ends
              &allow-other-keys) options
    (declare (ignorable perform explain output-files operation-done-p))
    (check-component-input type name weakly-depends-on depends-on components in-order-to)
               (find-component parent name)
               ;; ignore the same object when rereading the defsystem
               (not
                (typep (find-component parent name)
                       (class-for-type parent type))))
      (error 'duplicate-names :name name))
                        '(components pathname default-component-class
                          perform explain output-files operation-done-p
                          weakly-depends-on
                          depends-on serial in-order-to)
                        rest))
           (ret
            (or (find-component parent name)
                (make-instance (class-for-type parent type)))))
      (when weakly-depends-on
        (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
      (when (boundp '*serial-depends-on*)
        (setf depends-on
              (concatenate 'list *serial-depends-on* depends-on)))
      (apply #'reinitialize-instance ret
             :name (coerce-name name)
             :pathname pathname
             :parent parent
             other-args)
        (setf (module-default-component-class ret)
              (or default-component-class
                  (and (typep parent 'module)
                       (module-default-component-class parent))))
        (let ((*serial-depends-on* nil))
          (setf (module-components ret)
                (loop :for c-form :in components
                  :for c = (parse-component-form ret c-form)
                  :collect c
                  :if serial
                  :do (push (component-name c) *serial-depends-on*))))

        ;; check for duplicate names
        (let ((name-hash (make-hash-table :test #'equal)))
          (loop :for c in (module-components ret) :do
            (if (gethash (component-name c)
                         name-hash)
                (error 'duplicate-names
                       :name (component-name c))
                (setf (gethash (component-name c)
                               name-hash)