X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=4005dc83fac1473ed79c337025286e5564108676;hb=0e03a9ac950b78d776c4869c809e202d9e929f39;hp=e2d7bb28c22bc806f14737e001fe4a68c95a71be;hpb=ae537cfb47286ccc945afd75c768e0411141f8f8;p=sbcl.git diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index e2d7bb2..4005dc8 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1,4 +1,4 @@ -;;; This is asdf: Another System Definition Facility. 1.96 +;;; This is asdf: Another System Definition Facility. 1.102 ;;; ;;; Feedback, bug reports, and patches are all welcome: please mail to ;;; . But note first that the canonical @@ -78,6 +78,7 @@ #:system-author #:system-maintainer #:system-license + #:system-licence #:operation-on-warnings #:operation-on-failure @@ -100,6 +101,8 @@ #:retry #:accept ; restarts + #:preference-file-for-system/operation + #:load-preferences ) (:use :cl)) @@ -109,7 +112,7 @@ (in-package #:asdf) -(defvar *asdf-revision* (let* ((v "1.96") +(defvar *asdf-revision* (let* ((v "1.102") (colon (or (position #\: v) -1)) (dot (position #\. v))) (and v colon dot @@ -285,7 +288,8 @@ and NIL NAME and TYPE components" :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 @@ -730,7 +734,8 @@ system.")) (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 @@ -739,8 +744,8 @@ system.")) (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) @@ -771,7 +776,9 @@ system.")) ;;; 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))) @@ -790,7 +797,7 @@ system.")) ;;; 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))) @@ -825,40 +832,73 @@ system.")) (defmethod perform ((operation test-op) (c component)) nil) +(defgeneric load-preferences (system operation) + (:documentation "Called to load system preferences after . 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 "~@" - op component))) - (accept () - :report - (lambda (s) - (format s - "~@" - 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 "~@" + op component))) + (accept () + :report + (lambda (s) + (format s + "~@" + op component)) + (setf (gethash (type-of op) + (component-operation-times component)) + (get-universal-time)) + (return))))))))) (defun oos (&rest args) "Alias of OPERATE function" @@ -906,11 +946,16 @@ system.")) (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) @@ -1145,20 +1190,23 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." 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 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 home + (merge-pathnames "site-systems/" (truename home)))) *central-registry*) (pushnew @@ -1170,3 +1218,4 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." (pushnew 'contrib-sysdef-search *system-definition-search-functions*)) (provide 'asdf) +