Skip to content
Snippets Groups Projects
asdf.lisp 56.3 KiB
Newer Older
Daniel Barlow's avatar
 
Daniel Barlow committed
  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)))

(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
                                           (slot-value c 'in-order-to)))))
    (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))
          (> (file-write-date (component-pathname c))
             (component-property c 'last-loaded-as-source)))
(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)

Daniel Barlow's avatar
Daniel Barlow committed
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations

(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))
Gary King's avatar
Gary King committed
                       (return)))))))
    op))
Daniel Barlow's avatar
Daniel Barlow committed

(defun oos (operation-class system &rest args &key force (verbose t) version
	    &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)
	(format nil
		"Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a"
		operate-docstring))
  (setf (documentation 'operate 'function)
	operate-docstring))

(defun load-system (system &rest args &key force (verbose t) version)
  "Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for details."
  (declare (ignore force verbose version))
  (apply #'operate 'load-op system args))

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

(defun test-system (system &rest args &key force (verbose t) version)
  "Shorthand for `(operate 'asdf:test-op system)`. See [operate][] for details."
  (declare (ignore force verbose version))
  (apply #'operate 'test-op system args))
Daniel Barlow's avatar
Daniel Barlow committed
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; syntax

(defun remove-keyword (key arglist)
  (labels ((aux (key arglist)
             (cond ((null arglist) nil)
                   ((eq key (car arglist)) (cddr arglist))
                   (t (cons (car arglist) (cons (cadr arglist)
                                                (remove-keyword
                                                 key (cddr arglist))))))))
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)))))
         (parse-component-form nil (apply
                                    #'list
                                    :module (coerce-name ',name)
                                    :pathname
                                    ;; to avoid a note about unreachable code
                                    ,(if pathname-arg-p
                                         pathname
                                         `(or (when *load-truename*
                                                (pathname-sans-name+type
                                                 (resolve-symlinks
                                                  *load-truename*)))
                                              *default-pathname-defaults*))
                                    ',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 remove-keys (key-names args)
  (loop for ( name val ) on args by #'cddr
        unless (member (symbol-name name) key-names
                       :key #'symbol-name :test 'equal)
        append (list name val)))
(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 depends-on components in-order-to)
  "A partial test of the values of a component."
  (when weakly-depends-on (warn "We got one! XXXXX"))
  (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)
  (loop for name in +asdf-methods+
        do (map 'nil
                ;; 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))
Gary King's avatar
Gary King committed
                (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)
  (loop for name in +asdf-methods+ do
       (let ((keyword (intern (symbol-name name) :keyword)))
	 (loop for data = rest then (cddr data)
	      while data
	      for key = (first data) 
	      for value = (second 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)))))))

(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)
                          t)))))

      (setf (slot-value ret 'in-order-to)
            (union-of-dependencies
             in-order-to
             `((compile-op (compile-op ,@depends-on))
               (load-op (load-op ,@depends-on))))
            (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))

Gary King's avatar
Gary King committed
      (%refresh-component-inline-methods ret rest)
(defun resolve-symlinks (path)
  #-allegro (truename path)
  #+allegro (excl:pathname-resolve-symbolic-links path)
  )
Daniel Barlow's avatar
Daniel Barlow committed
;;; optional extras

;;; run-shell-command functions for other lisp implementations will be
;;; gratefully accepted, if they do the same thing.  If the docstring
;;; is ambiguous, send a bug report

Daniel Barlow's avatar
Daniel Barlow committed
(defun run-shell-command (control-string &rest args)
  "Interpolate `args` into `control-string` as if by `format`, and
synchronously execute the result using a Bourne-compatible shell, with
output to `*verbose-out*`.  Returns the shell's exit code."
Daniel Barlow's avatar
Daniel Barlow committed
  (let ((command (apply #'format nil control-string args)))
    (asdf-message "; $ ~A~%" command)
    (sb-ext:process-exit-code
     (sb-ext:run-program
      #+win32 "sh" #-win32 "/bin/sh"
Daniel Barlow's avatar
Daniel Barlow committed
      (list  "-c" command)
      #+win32 #+win32 :search t
Daniel Barlow's avatar
Daniel Barlow committed
    (ext:process-exit-code
     (ext:run-program
Daniel Barlow's avatar
Daniel Barlow committed
      "/bin/sh"
      (list  "-c" command)
    ;; will this fail if command has embedded quotes - it seems to work
    (multiple-value-bind (stdout stderr exit-code)
        (excl.osi:command-output 
	 (format nil "~a -c \"~a\"" 
		 #+mswindows "sh" #-mswindows "/bin/sh" command)
	 :input nil :whole nil
	 #+mswindows :show-window #+mswindows :hide)
      (format *verbose-out* "~{~&; ~a~%~}~%" stderr)
      (format *verbose-out* "~{~&; ~a~%~}~%" stdout)
      exit-code)

    #+lispworks
    (system:call-system-showing-output
     command
     :shell-type "/bin/sh"

    #+clisp                     ;XXX not exactly *verbose-out*, I know
    (ext:run-shell-command  command :output :terminal :wait t)

    #+openmcl
               (ccl:external-process-status
                (ccl:run-program "/bin/sh" (list "-c" command)
                                 :input nil :output *verbose-out*
                                 :wait t)))
    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    (si:system command)
    #-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
    ))
(defgeneric system-source-file (system)
  (:documentation "Return the source file in which system is defined."))

(defmethod system-source-file ((system-name t))
  (system-source-file (find-system system-name)))

(defmethod system-source-file ((system system))
  (let ((pn (and (slot-boundp system 'relative-pathname)
		 (make-pathname
		  :type "asd"
		  :name (asdf:component-name system)
		  :defaults (asdf:component-relative-pathname system)))))
    (when pn
      (probe-file pn))))
(defun system-source-directory (system-name)
  (make-pathname :name nil
                 :type nil
                 :defaults (system-source-file system-name)))

(defun system-relative-pathname (system pathname &key name type)
  ;; you're not allowed to muck with the return value of pathname-X
  (let ((directory (copy-list (pathname-directory pathname))))
    (when (eq (car directory) :absolute)
      (setf (car directory) :relative))
    (merge-pathnames
     (make-pathname :name (or name (pathname-name pathname))
                    :type (or type (pathname-type pathname))
                    :directory directory)
     (system-source-directory system))))

Daniel Barlow's avatar
Daniel Barlow committed
(pushnew :asdf *features*)

#+sbcl
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
    (pushnew :sbcl-hooks-require *features*)))

#+(and sbcl sbcl-hooks-require)
(progn
  (defun module-provide-asdf (name)
    (handler-bind ((style-warning #'muffle-warning))
      (let* ((*verbose-out* (make-broadcast-stream))
             (system (asdf:find-system name nil)))
        (when system
          (asdf:operate 'asdf:load-op name)
          t))))
  (defun contrib-sysdef-search (system)
    (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
      (when (and home (not (string= home "")))
        (let* ((name (coerce-name system))
               (home (truename home))
               (contrib (merge-pathnames
                         (make-pathname :directory `(:relative ,name)
                                        :name name
                                        :type "asd"
                                        :case :local
                                        :version :newest)
                         home)))
          (probe-file contrib)))))
   '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
      (when (and home (not (string= home "")))
        (merge-pathnames "site-systems/" (truename home))))
   *central-registry*)
   '(merge-pathnames ".sbcl/systems/"
     (user-homedir-pathname))
   *central-registry*)
  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
(if *asdf-revision*
    (asdf-message ";; ASDF, revision ~a" *asdf-revision*)
    (asdf-message ";; ASDF, revision unknown; possibly a development version"))