Index: /trunk/source/tools/asdf.lisp =================================================================== --- /trunk/source/tools/asdf.lisp (revision 13887) +++ /trunk/source/tools/asdf.lisp (revision 13888) @@ -48,28 +48,28 @@ #+xcvb (module ()) -(cl:in-package :cl-user) - -#|(declaim (optimize (speed 2) (debug 2) (safety 3)) -#+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))|# - -#+ecl (require :cmp) - -;;;; Create packages in a way that is compatible with hot-upgrade. -;;;; See https://bugs.launchpad.net/asdf/+bug/485687 -;;;; See more at the end of the file. - -#+gcl -(eval-when (:compile-toplevel :load-toplevel) - (defpackage :asdf-utilities (:use :cl)) - (defpackage :asdf (:use :cl :asdf-utilities))) - -(eval-when (:load-toplevel :compile-toplevel :execute) +(cl:in-package :cl) +(defpackage :asdf-bootstrap (:use :cl)) +(in-package :asdf-bootstrap) + +;; Implementation-dependent tweaks +(eval-when (:compile-toplevel :load-toplevel :execute) + ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) - (let* ((asdf-version - ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.002" (1+ (length "VERSION")))) + #+ecl (require :cmp) + #+gcl + (eval-when (:compile-toplevel :load-toplevel) + (defpackage :asdf-utilities (:use :cl)) + (defpackage :asdf (:use :cl :asdf-utilities)))) + +;;;; Create packages in a way that is compatible with hot-upgrade. +;;;; See https://bugs.launchpad.net/asdf/+bug/485687 +;;;; See more at the end of the file. + +(eval-when (:load-toplevel :compile-toplevel :execute) + (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate + (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105. (existing-asdf (find-package :asdf)) (vername '#:*asdf-version*) @@ -156,11 +156,9 @@ ((pkgdcl (name &key nicknames use export redefined-functions unintern fmakunbound shadow) - `(ensure-package - ',name :nicknames ',nicknames :use ',use :export ',export - :shadow ',shadow - :unintern ',(append #-(or gcl ecl) redefined-functions - unintern) - :fmakunbound ',(append #+(or gcl ecl) redefined-functions - fmakunbound)))) + `(ensure-package + ',name :nicknames ',nicknames :use ',use :export ',export + :shadow ',shadow + :unintern ',(append #-(or gcl ecl) redefined-functions unintern) + :fmakunbound ',(append fmakunbound)))) (pkgdcl :asdf-utilities @@ -291,4 +289,5 @@ #:ensure-output-translations #:apply-output-translations + #:compile-file* #:compile-file-pathname* #:enable-asdf-binary-locations-compatibility @@ -346,7 +345,13 @@ Defaults to `t`.") -(defvar *compile-file-warnings-behaviour* :warn) - -(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn) +(defvar *compile-file-warnings-behaviour* :warn + "How should ASDF react if it encounters a warning when compiling a +file? Valid values are :error, :warn, and :ignore.") + +(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn + "How should ASDF react if it encounters a failure \(per the +ANSI spec of COMPILE-FILE\) when compiling a file? Valid values are +:error, :warn, and :ignore. Note that ASDF ALWAYS raises an error +if it fails to create an output file when compiling.") (defvar *verbose-out* nil) @@ -367,14 +372,18 @@ ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. - -(defgeneric perform-with-restarts (operation component)) -(defgeneric perform (operation component)) -(defgeneric operation-done-p (operation component)) -(defgeneric explain (operation component)) -(defgeneric output-files (operation component)) -(defgeneric input-files (operation component)) +(defmacro defgeneric* (name formals &rest options) + `(progn + #+(or gcl ecl) (fmakunbound ',name) + (defgeneric ,name ,formals ,@options))) + +(defgeneric* perform-with-restarts (operation component)) +(defgeneric* perform (operation component)) +(defgeneric* operation-done-p (operation component)) +(defgeneric* explain (operation component)) +(defgeneric* output-files (operation component)) +(defgeneric* input-files (operation component)) (defgeneric component-operation-time (operation component)) -(defgeneric system-source-file (system) +(defgeneric* system-source-file (system) (:documentation "Return the source file in which system is defined.")) @@ -398,5 +407,5 @@ (defgeneric version-satisfies (component version)) -(defgeneric find-component (base path) +(defgeneric* find-component (base path) (:documentation "Finds the component with PATH starting from BASE module; if BASE is nil, then the component is assumed to be a system.")) @@ -1083,12 +1092,4 @@ '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf)) -(defun sysdef-find-asdf (system) - (let ((name (coerce-name system))) - (when (equal name "asdf") - (eval - `(defsystem :asdf - :pathname ,(or *compile-file-truename* *load-truename*) - :depends-on () :components ()))))) - (defun system-definition-pathname (system) (let ((system-name (coerce-name system))) @@ -1204,29 +1205,30 @@ (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))) - (when (and on-disk - (or (not in-memory) - (< (car in-memory) (safe-file-write-date on-disk)))) - (let ((package (make-temporary-package))) - (unwind-protect - (handler-bind - ((error (lambda (condition) - (error 'load-system-definition-error - :name name :pathname on-disk - :condition condition)))) - (let ((*package* package)) - (asdf-message - "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" - on-disk *package*) - (load on-disk))) - (delete-package package)))) - (let ((in-memory (system-registered-p name))) - (if in-memory - (progn (when on-disk (setf (car in-memory) - (safe-file-write-date on-disk))) - (cdr in-memory)) - (when error-p (error 'missing-component :requires name)))))) + (catch 'find-system + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) + (on-disk (system-definition-pathname name))) + (when (and on-disk + (or (not in-memory) + (< (car in-memory) (safe-file-write-date on-disk)))) + (let ((package (make-temporary-package))) + (unwind-protect + (handler-bind + ((error (lambda (condition) + (error 'load-system-definition-error + :name name :pathname on-disk + :condition condition)))) + (let ((*package* package)) + (asdf-message + "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + on-disk *package*) + (load on-disk))) + (delete-package package)))) + (let ((in-memory (system-registered-p name))) + (if in-memory + (progn (when on-disk (setf (car in-memory) + (safe-file-write-date on-disk))) + (cdr in-memory)) + (when error-p (error 'missing-component :requires name))))))) (defun register-system (name system) @@ -1234,4 +1236,16 @@ (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) + +(defun sysdef-find-asdf (system) + (let ((name (coerce-name system))) + (when (equal name "asdf") + (let* ((registered (cdr (gethash name *defined-systems*))) + (asdf (or registered + (make-instance + 'system :name "asdf" + :source-file (or *compile-file-truename* *load-truename*))))) + (unless registered + (register-system "asdf" asdf)) + (throw 'find-system asdf))))) @@ -1755,4 +1769,8 @@ (get-universal-time))) +(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys) + (values t t t)) + compile-file*)) + ;;; perform is required to check output-files to find out where to put ;;; its answers, in case it has been overridden for site policy @@ -1760,7 +1778,9 @@ #-:broken-fasl-loader (let ((source-file (component-pathname c)) - (output-file (car (output-files operation c)))) + (output-file (car (output-files operation c))) + (*compile-file-warnings-behaviour* (operation-on-warnings operation)) + (*compile-file-failure-behaviour* (operation-on-failure operation))) (multiple-value-bind (output warnings-p failure-p) - (apply #'compile-file source-file :output-file output-file + (apply #'compile-file* source-file :output-file output-file (compile-op-flags operation)) (when warnings-p @@ -1938,5 +1958,5 @@ ;;;; Invoking Operations -(defgeneric operate (operation-class system &key &allow-other-keys)) +(defgeneric* operate (operation-class system &key &allow-other-keys)) (defmethod operate (operation-class system &rest args @@ -2078,22 +2098,16 @@ ',component-options)))))) - (defun class-for-type (parent type) - (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) - (load-time-value - (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)))))) - (or class - (and (eq type :file) - (or (module-default-component-class parent) - (find-class *default-component-class*))) - (sysdef-error "~@" type)))) + (or (loop :for symbol :in (list + (unless (keywordp type) type) + (find-symbol (symbol-name type) *package*) + (find-symbol (symbol-name type) :asdf)) + :for class = (and symbol (find-class symbol nil)) + :when (and class (subtypep class 'component)) + :return class) + (and (eq type :file) + (or (module-default-component-class parent) + (find-class *default-component-class*))) + (sysdef-error "~@" type))) (defun maybe-add-tree (tree op1 op2 c) @@ -2929,9 +2943,43 @@ t)) -(defun compile-file-pathname* (input-file &rest keys) - (apply-output-translations - (apply #'compile-file-pathname - (truenamize (lispize-pathname input-file)) - keys))) +(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) + (or output-file + (apply-output-translations + (apply 'compile-file-pathname + (truenamize (lispize-pathname input-file)) + keys)))) + +(defun tmpize-pathname (x) + (make-pathname + :name (format nil "ASDF-TMP-~A" (pathname-name x)) + :defaults x)) + +(defun delete-file-if-exists (x) + (when (probe-file x) + (delete-file x))) + +(defun compile-file* (input-file &rest keys &key &allow-other-keys) + (let* ((output-file (apply 'compile-file-pathname* input-file keys)) + (tmp-file (tmpize-pathname output-file)) + (status :error)) + (multiple-value-bind (output-truename warnings-p failure-p) + (apply 'compile-file input-file :output-file tmp-file keys) + (cond + (failure-p + (setf status *compile-file-failure-behaviour*)) + (warnings-p + (setf status *compile-file-warnings-behaviour*)) + (t + (setf status :success))) + (ecase status + ((:success :warn :ignore) + (delete-file-if-exists output-file) + (when output-truename + (rename-file output-truename output-file) + (setf output-truename output-file))) + (:error + (delete-file-if-exists output-truename) + (setf output-truename nil))) + (values output-truename warnings-p failure-p)))) #+abcl @@ -3365,5 +3413,5 @@ ;;;; Done! (when *load-verbose* - (asdf-message ";; ASDF, version ~a" (asdf-version))) + (asdf-message ";; ASDF, version ~a~%" (asdf-version))) #+allegro