-;;; This is asdf: Another System Definition Facility. $Revision$
+;;; This is asdf: Another System Definition Facility. 1.102
;;;
;;; Feedback, bug reports, and patches are all welcome: please mail to
;;; <cclan-list@lists.sf.net>. But note first that the canonical
#:system-author
#:system-maintainer
#:system-license
+ #:system-licence
#:operation-on-warnings
#:operation-on-failure
#:missing-component
#:missing-dependency
#:circular-dependency ; errors
+ #:duplicate-names
#:retry
#:accept ; restarts
+ #:preference-file-for-system/operation
+ #:load-preferences
)
(:use :cl))
(in-package #:asdf)
-(defvar *asdf-revision* (let* ((v "$Revision$")
+(defvar *asdf-revision* (let* ((v "1.102")
(colon (or (position #\: v) -1))
(dot (position #\. v)))
(and v colon dot
(define-condition circular-dependency (system-definition-error)
((components :initarg :components :reader circular-dependency-components)))
+(define-condition duplicate-names (system-definition-error)
+ ((name :initarg :name :reader duplicate-names-name)))
+
(define-condition missing-component (system-definition-error)
((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
(version :initform nil :reader missing-version :initarg :version)
:accessor system-long-description :initarg :long-description)
(author :accessor system-author :initarg :author)
(maintainer :accessor system-maintainer :initarg :maintainer)
- (licence :accessor system-licence :initarg :licence)))
+ (licence :accessor system-licence :initarg :licence
+ :accessor system-license :initarg :license)))
;;; version-satisfies
(if (and file (probe-file file))
(return file)))))))
+(defun make-temporary-package ()
+ (flet ((try (counter)
+ (ignore-errors
+ (make-package (format nil "ASDF~D" counter)
+ :use '(:cl :asdf)))))
+ (do* ((counter 0 (+ counter 1))
+ (package (try counter) (try counter)))
+ (package package))))
(defun find-system (name &optional (error-p t))
(let* ((name (coerce-name name))
(when (and on-disk
(or (not in-memory)
(< (car in-memory) (file-write-date on-disk))))
- (let ((*package* (make-package (gensym #.(package-name *package*))
- :use '(:cl :asdf))))
- (format *verbose-out*
+ (let ((package (make-temporary-package)))
+ (unwind-protect
+ (let ((*package* package))
+ (format
+ *verbose-out*
"~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
;; FIXME: This wants to be (ENOUGH-NAMESTRING
;; ON-DISK), but CMUCL barfs on that.
on-disk
*package*)
- (load on-disk)))
+ (load on-disk))
+ (delete-package package))))
(let ((in-memory (gethash name *defined-systems*)))
(if in-memory
(progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
(defmethod source-file-type ((c static-file) (s module)) nil)
(defmethod component-relative-pathname ((component source-file))
- (let* ((*default-pathname-defaults* (component-parent-pathname component))
- (name-type
- (make-pathname
- :name (component-name component)
- :type (source-file-type component
- (component-system component)))))
- (if (slot-value component 'relative-pathname)
+ (let ((relative-pathname (slot-value component 'relative-pathname)))
+ (if relative-pathname
(merge-pathnames
- (slot-value component 'relative-pathname)
- name-type)
- name-type)))
+ relative-pathname
+ (make-pathname
+ :type (source-file-type component (component-system component))))
+ (let* ((*default-pathname-defaults*
+ (component-parent-pathname component))
+ (name-type
+ (make-pathname
+ :name (component-name component)
+ :type (source-file-type component
+ (component-system component)))))
+ name-type))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; operations
(defmethod input-files ((operation operation) (c module)) nil)
(defmethod operation-done-p ((o operation) (c component))
- (let ((out-files (output-files o c))
- (in-files (input-files o c)))
- (cond ((and (not in-files) (not out-files))
- ;; arbitrary decision: an operation that uses nothing to
- ;; produce nothing probably isn't doing much
- t)
- ((not out-files)
- (let ((op-done
- (gethash (type-of o)
- (component-operation-times c))))
- (and op-done
- (>= op-done
- (or (apply #'max
- (mapcar #'file-write-date in-files)) 0)))))
- ((not in-files) nil)
- (t
- (and
- (every #'probe-file out-files)
- (> (apply #'min (mapcar #'file-write-date out-files))
- (apply #'max (mapcar #'file-write-date in-files)) ))))))
+ (flet ((fwd-or-return-t (file)
+ ;; 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.
+ (let ((date (file-write-date file)))
+ (cond
+ (date)
+ (t
+ (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
+ operation ~S on component ~S as done.~@:>"
+ file o c)
+ (return-from operation-done-p t))))))
+ (let ((out-files (output-files o c))
+ (in-files (input-files o c)))
+ (cond ((and (not in-files) (not out-files))
+ ;; arbitrary decision: an operation that uses nothing to
+ ;; produce nothing probably isn't doing much
+ t)
+ ((not out-files)
+ (let ((op-done
+ (gethash (type-of o)
+ (component-operation-times c))))
+ (and op-done
+ (>= op-done
+ (apply #'max
+ (mapcar #'fwd-or-return-t in-files))))))
+ ((not in-files) nil)
+ (t
+ (and
+ (every #'probe-file out-files)
+ (> (apply #'min (mapcar #'file-write-date out-files))
+ (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
;;; So you look at this code and think "why isn't it a bunch of
;;; methods". And the answer is, because standard method combination
(defmethod perform :after ((operation operation) (c component))
(setf (gethash (type-of operation) (component-operation-times c))
- (get-universal-time)))
+ (get-universal-time))
+ (load-preferences c operation))
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(let ((source-file (component-pathname c))
(output-file (car (output-files operation c))))
(multiple-value-bind (output warnings-p failure-p)
- (compile-file source-file
- :output-file output-file)
+ (compile-file source-file
+ :output-file output-file)
;(declare (ignore output))
(when warnings-p
(case (operation-on-warnings operation)
;;; load-op
-(defclass load-op (operation) ())
+(defclass basic-load-op (operation) ())
+
+(defclass load-op (basic-load-op) ())
(defmethod perform ((o load-op) (c cl-source-file))
(mapcar #'load (input-files o c)))
;;; load-source-op
-(defclass load-source-op (operation) ())
+(defclass load-source-op (basic-load-op) ())
(defmethod perform ((o load-source-op) (c cl-source-file))
(let ((source (component-pathname c)))
(defmethod perform ((operation test-op) (c component))
nil)
+(defgeneric load-preferences (system operation)
+ (:documentation "Called to load system preferences after <perform operation system>. Typical uses are to set parameters that don't exist until after the system has been loaded."))
+
+(defgeneric preference-file-for-system/operation (system operation)
+ (:documentation "Returns the pathname of the preference file for this system. Called by 'load-preferences to determine what file to load."))
+
+(defmethod load-preferences ((s t) (operation t))
+ ;; do nothing
+ (values))
+
+(defmethod load-preferences ((s system) (operation basic-load-op))
+ (let* ((*package* (find-package :common-lisp))
+ (file (probe-file (preference-file-for-system/operation s operation))))
+ (when file
+ (when *verbose-out*
+ (format *verbose-out*
+ "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%"
+ (component-name s)
+ (type-of operation) file))
+ (load file))))
+
+(defmethod preference-file-for-system/operation ((system t) (operation t))
+ ;; cope with anything other than systems
+ (preference-file-for-system/operation (find-system system t) operation))
+
+(defmethod preference-file-for-system/operation ((s system) (operation t))
+ (merge-pathnames
+ (make-pathname :name (component-name s)
+ :type "lisp"
+ :directory '(:relative ".asdf"))
+ (truename (user-homedir-pathname))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; invoking operations
-(defun operate (operation-class system &rest args)
+(defun operate (operation-class system &rest args &key (verbose t) version
+ &allow-other-keys)
(let* ((op (apply #'make-instance operation-class
- :original-initargs args args))
- (*verbose-out*
- (if (getf args :verbose t)
- *trace-output*
- (make-broadcast-stream)))
- (system (if (typep system 'component) system (find-system system)))
- (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))))))))
+ :original-initargs args
+ args))
+ (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
+ (system (if (typep system 'component) system (find-system system))))
+ (unless (version-satisfies system version)
+ (error 'missing-component :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)))))))))
(defun oos (&rest args)
"Alias of OPERATE function"
(defun class-for-type (parent type)
- (let ((class
- (find-class
- (or (find-symbol (symbol-name type) *package*)
- (find-symbol (symbol-name type) #.(package-name *package*)))
- nil)))
+ (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
+ (find-symbol (symbol-name type)
+ #.(package-name *package*))))
+ (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))))))
(or class
(and (eq type :file)
(or (module-default-component-class parent)
;; 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
- (check-component-input type name depends-on components in-order-to)
+ (check-component-input type name weakly-depends-on depends-on components in-order-to)
+
+ (when (and parent
+ (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))
+
(let* ((other-args (remove-keys
'(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)))
for c = (parse-component-form ret c-form)
collect c
if serial
- do (push (component-name c) *serial-depends-on*)))))
+ 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
(component-inline-methods ret))))
ret)))
-(defun check-component-input (type name depends-on components in-order-to)
+(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))
(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."
+output to *VERBOSE-OUT*. Returns the shell's exit code."
(let ((command (apply #'format nil control-string args)))
(format *verbose-out* "; $ ~A~%" command)
#+sbcl
- (sb-impl::process-exit-code
+ (sb-ext:process-exit-code
(sb-ext:run-program
- "/bin/sh"
+ #+win32 "sh" #-win32 "/bin/sh"
(list "-c" command)
+ #+win32 #+win32 :search t
:input nil :output *verbose-out*))
#+(or cmu scl)
(asdf:operate 'asdf:load-op name)
t))))
- (pushnew
- '(merge-pathnames "systems/"
- (truename (sb-ext:posix-getenv "SBCL_HOME")))
- *central-registry*)
+ (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)))))
(pushnew
- '(merge-pathnames "site-systems/"
- (truename (sb-ext:posix-getenv "SBCL_HOME")))
+ '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
+ (when (and home (not (string= home "")))
+ (merge-pathnames "site-systems/" (truename home))))
*central-registry*)
(pushnew
(user-homedir-pathname))
*central-registry*)
- (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*))
+ (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
+ (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
(provide 'asdf)
+
projects / sbcl.git / blobdiff