-;;; This is asdf: Another System Definition Facility. 1.97
+;;; 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
#:retry
#:accept ; restarts
+ #:preference-file-for-system/operation
+ #:load-preferences
)
(:use :cl))
(in-package #:asdf)
-(defvar *asdf-revision* (let* ((v "1.97")
+(defvar *asdf-revision* (let* ((v "1.102")
(colon (or (position #\: v) -1))
(dot (position #\. v)))
(and v colon dot
: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
(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 &key (verbose t) version)
+(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))
(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)
t))))
(defun contrib-sysdef-search (system)
- (let* ((name (coerce-name system))
- (home (truename (sb-ext:posix-getenv "SBCL_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 "")))
+ (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
(pushnew 'contrib-sysdef-search *system-definition-search-functions*))
(provide 'asdf)
+
projects / sbcl.git / blobdiff