Changeset 13888


Ignore:
Timestamp:
Jun 25, 2010, 2:42:04 AM (9 years ago)
Author:
rme
Message:

ASDF 2.003 from upstream.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/tools/asdf.lisp

    r13874 r13888  
    4848#+xcvb (module ())
    4949
    50 (cl:in-package :cl-user)
    51 
    52 #|(declaim (optimize (speed 2) (debug 2) (safety 3))
    53 #+sbcl (sb-ext:muffle-conditions sb-ext:compiler-note))|#
    54 
    55 #+ecl (require :cmp)
    56 
    57 ;;;; Create packages in a way that is compatible with hot-upgrade.
    58 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
    59 ;;;; See more at the end of the file.
    60 
    61 #+gcl
    62 (eval-when (:compile-toplevel :load-toplevel)
    63   (defpackage :asdf-utilities (:use :cl))
    64   (defpackage :asdf (:use :cl :asdf-utilities)))
    65 
    66 (eval-when (:load-toplevel :compile-toplevel :execute)
     50(cl:in-package :cl)
     51(defpackage :asdf-bootstrap (:use :cl))
     52(in-package :asdf-bootstrap)
     53
     54;; Implementation-dependent tweaks
     55(eval-when (:compile-toplevel :load-toplevel :execute)
     56  ;; (declaim (optimize (speed 2) (debug 2) (safety 3)) ; NO: rely on the implementation defaults.
    6757  #+allegro
    6858  (setf excl::*autoload-package-name-alist*
    6959        (remove "asdf" excl::*autoload-package-name-alist*
    7060                :test 'equalp :key 'car))
    71   (let* ((asdf-version
    72           ;; the 1+ helps the version bumping script discriminate
    73           (subseq "VERSION:2.002" (1+ (length "VERSION"))))
     61  #+ecl (require :cmp)
     62  #+gcl
     63  (eval-when (:compile-toplevel :load-toplevel)
     64    (defpackage :asdf-utilities (:use :cl))
     65    (defpackage :asdf (:use :cl :asdf-utilities))))
     66
     67;;;; Create packages in a way that is compatible with hot-upgrade.
     68;;;; See https://bugs.launchpad.net/asdf/+bug/485687
     69;;;; See more at the end of the file.
     70
     71(eval-when (:load-toplevel :compile-toplevel :execute)
     72  (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate
     73          (subseq "VERSION:2.003" (1+ (length "VERSION")))) ; NB: same as 2.105.
    7474         (existing-asdf (find-package :asdf))
    7575         (vername '#:*asdf-version*)
     
    156156            ((pkgdcl (name &key nicknames use export
    157157                           redefined-functions unintern fmakunbound shadow)
    158                `(ensure-package
    159                  ',name :nicknames ',nicknames :use ',use :export ',export
    160                  :shadow ',shadow
    161                  :unintern ',(append #-(or gcl ecl) redefined-functions
    162                                      unintern)
    163                  :fmakunbound ',(append #+(or gcl ecl) redefined-functions
    164                                         fmakunbound))))
     158                 `(ensure-package
     159                   ',name :nicknames ',nicknames :use ',use :export ',export
     160                   :shadow ',shadow
     161                   :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
     162                   :fmakunbound ',(append fmakunbound))))
    165163          (pkgdcl
    166164           :asdf-utilities
     
    291289            #:ensure-output-translations
    292290            #:apply-output-translations
     291            #:compile-file*
    293292            #:compile-file-pathname*
    294293            #:enable-asdf-binary-locations-compatibility
     
    346345Defaults to `t`.")
    347346
    348 (defvar *compile-file-warnings-behaviour* :warn)
    349 
    350 (defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
     347(defvar *compile-file-warnings-behaviour* :warn
     348  "How should ASDF react if it encounters a warning when compiling a
     349file?  Valid values are :error, :warn, and :ignore.")
     350
     351(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn
     352        "How should ASDF react if it encounters a failure \(per the
     353ANSI spec of COMPILE-FILE\) when compiling a file?  Valid values are
     354:error, :warn, and :ignore.  Note that ASDF ALWAYS raises an error
     355if it fails to create an output file when compiling.")
    351356
    352357(defvar *verbose-out* nil)
     
    367372;;;; -------------------------------------------------------------------------
    368373;;;; ASDF Interface, in terms of generic functions.
    369 
    370 (defgeneric perform-with-restarts (operation component))
    371 (defgeneric perform (operation component))
    372 (defgeneric operation-done-p (operation component))
    373 (defgeneric explain (operation component))
    374 (defgeneric output-files (operation component))
    375 (defgeneric input-files (operation component))
     374(defmacro defgeneric* (name formals &rest options)
     375  `(progn
     376     #+(or gcl ecl) (fmakunbound ',name)
     377     (defgeneric ,name ,formals ,@options)))
     378
     379(defgeneric* perform-with-restarts (operation component))
     380(defgeneric* perform (operation component))
     381(defgeneric* operation-done-p (operation component))
     382(defgeneric* explain (operation component))
     383(defgeneric* output-files (operation component))
     384(defgeneric* input-files (operation component))
    376385(defgeneric component-operation-time (operation component))
    377386
    378 (defgeneric system-source-file (system)
     387(defgeneric* system-source-file (system)
    379388  (:documentation "Return the source file in which system is defined."))
    380389
     
    398407(defgeneric version-satisfies (component version))
    399408
    400 (defgeneric find-component (base path)
     409(defgeneric* find-component (base path)
    401410  (:documentation "Finds the component with PATH starting from BASE module;
    402411if BASE is nil, then the component is assumed to be a system."))
     
    10831092  '(sysdef-central-registry-search sysdef-source-registry-search sysdef-find-asdf))
    10841093
    1085 (defun sysdef-find-asdf (system)
    1086   (let ((name (coerce-name system)))
    1087     (when (equal name "asdf")
    1088       (eval
    1089        `(defsystem :asdf
    1090           :pathname ,(or *compile-file-truename* *load-truename*)
    1091           :depends-on () :components ())))))
    1092 
    10931094(defun system-definition-pathname (system)
    10941095  (let ((system-name (coerce-name system)))
     
    12041205
    12051206(defun find-system (name &optional (error-p t))
    1206   (let* ((name (coerce-name name))
    1207          (in-memory (system-registered-p name))
    1208          (on-disk (system-definition-pathname name)))
    1209     (when (and on-disk
    1210                (or (not in-memory)
    1211                    (< (car in-memory) (safe-file-write-date on-disk))))
    1212       (let ((package (make-temporary-package)))
    1213         (unwind-protect
    1214              (handler-bind
    1215                  ((error (lambda (condition)
    1216                            (error 'load-system-definition-error
    1217                                   :name name :pathname on-disk
    1218                                   :condition condition))))
    1219                (let ((*package* package))
    1220                  (asdf-message
    1221                   "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    1222                   on-disk *package*)
    1223                  (load on-disk)))
    1224           (delete-package package))))
    1225     (let ((in-memory (system-registered-p name)))
    1226       (if in-memory
    1227           (progn (when on-disk (setf (car in-memory)
    1228                                      (safe-file-write-date on-disk)))
    1229                  (cdr in-memory))
    1230           (when error-p (error 'missing-component :requires name))))))
     1207  (catch 'find-system
     1208    (let* ((name (coerce-name name))
     1209           (in-memory (system-registered-p name))
     1210           (on-disk (system-definition-pathname name)))
     1211      (when (and on-disk
     1212                 (or (not in-memory)
     1213                     (< (car in-memory) (safe-file-write-date on-disk))))
     1214        (let ((package (make-temporary-package)))
     1215          (unwind-protect
     1216               (handler-bind
     1217                   ((error (lambda (condition)
     1218                             (error 'load-system-definition-error
     1219                                    :name name :pathname on-disk
     1220                                    :condition condition))))
     1221                 (let ((*package* package))
     1222                   (asdf-message
     1223                    "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     1224                    on-disk *package*)
     1225                   (load on-disk)))
     1226            (delete-package package))))
     1227      (let ((in-memory (system-registered-p name)))
     1228        (if in-memory
     1229            (progn (when on-disk (setf (car in-memory)
     1230                                       (safe-file-write-date on-disk)))
     1231                   (cdr in-memory))
     1232            (when error-p (error 'missing-component :requires name)))))))
    12311233
    12321234(defun register-system (name system)
     
    12341236  (setf (gethash (coerce-name name) *defined-systems*)
    12351237        (cons (get-universal-time) system)))
     1238
     1239(defun sysdef-find-asdf (system)
     1240  (let ((name (coerce-name system)))
     1241    (when (equal name "asdf")
     1242      (let* ((registered (cdr (gethash name *defined-systems*)))
     1243             (asdf (or registered
     1244                       (make-instance
     1245                        'system :name "asdf"
     1246                        :source-file (or *compile-file-truename* *load-truename*)))))
     1247        (unless registered
     1248          (register-system "asdf" asdf))
     1249        (throw 'find-system asdf)))))
    12361250
    12371251
     
    17551769        (get-universal-time)))
    17561770
     1771(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys)
     1772                          (values t t t))
     1773                compile-file*))
     1774
    17571775;;; perform is required to check output-files to find out where to put
    17581776;;; its answers, in case it has been overridden for site policy
     
    17601778  #-:broken-fasl-loader
    17611779  (let ((source-file (component-pathname c))
    1762         (output-file (car (output-files operation c))))
     1780        (output-file (car (output-files operation c)))
     1781        (*compile-file-warnings-behaviour* (operation-on-warnings operation))
     1782        (*compile-file-failure-behaviour* (operation-on-failure operation)))
    17631783    (multiple-value-bind (output warnings-p failure-p)
    1764         (apply #'compile-file source-file :output-file output-file
     1784        (apply #'compile-file* source-file :output-file output-file
    17651785               (compile-op-flags operation))
    17661786      (when warnings-p
     
    19381958;;;; Invoking Operations
    19391959
    1940 (defgeneric operate (operation-class system &key &allow-other-keys))
     1960(defgeneric* operate (operation-class system &key &allow-other-keys))
    19411961
    19421962(defmethod operate (operation-class system &rest args
     
    20782098               ',component-options))))))
    20792099
    2080 
    20812100(defun class-for-type (parent type)
    2082   (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
    2083                               (find-symbol (symbol-name type)
    2084                                            (load-time-value
    2085                                             (package-name :asdf)))))
    2086          (class (dolist (symbol (if (keywordp type)
    2087                                     extra-symbols
    2088                                     (cons type extra-symbols)))
    2089                   (when (and symbol
    2090                              (find-class symbol nil)
    2091                              (subtypep symbol 'component))
    2092                     (return (find-class symbol))))))
    2093     (or class
    2094         (and (eq type :file)
    2095              (or (module-default-component-class parent)
    2096                  (find-class *default-component-class*)))
    2097         (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
     2101  (or (loop :for symbol :in (list
     2102                             (unless (keywordp type) type)
     2103                             (find-symbol (symbol-name type) *package*)
     2104                             (find-symbol (symbol-name type) :asdf))
     2105        :for class = (and symbol (find-class symbol nil))
     2106        :when (and class (subtypep class 'component))
     2107        :return class)
     2108      (and (eq type :file)
     2109           (or (module-default-component-class parent)
     2110               (find-class *default-component-class*)))
     2111      (sysdef-error "~@<don't recognize component type ~A~@:>" type)))
    20982112
    20992113(defun maybe-add-tree (tree op1 op2 c)
     
    29292943   t))
    29302944
    2931 (defun compile-file-pathname* (input-file &rest keys)
    2932   (apply-output-translations
    2933    (apply #'compile-file-pathname
    2934           (truenamize (lispize-pathname input-file))
    2935           keys)))
     2945(defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
     2946  (or output-file
     2947      (apply-output-translations
     2948       (apply 'compile-file-pathname
     2949              (truenamize (lispize-pathname input-file))
     2950              keys))))
     2951
     2952(defun tmpize-pathname (x)
     2953  (make-pathname
     2954   :name (format nil "ASDF-TMP-~A" (pathname-name x))
     2955   :defaults x))
     2956
     2957(defun delete-file-if-exists (x)
     2958  (when (probe-file x)
     2959    (delete-file x)))
     2960
     2961(defun compile-file* (input-file &rest keys &key &allow-other-keys)
     2962  (let* ((output-file (apply 'compile-file-pathname* input-file keys))
     2963         (tmp-file (tmpize-pathname output-file))
     2964         (status :error))
     2965    (multiple-value-bind (output-truename warnings-p failure-p)
     2966        (apply 'compile-file input-file :output-file tmp-file keys)
     2967      (cond
     2968        (failure-p
     2969         (setf status *compile-file-failure-behaviour*))
     2970        (warnings-p
     2971         (setf status *compile-file-warnings-behaviour*))
     2972        (t
     2973         (setf status :success)))
     2974      (ecase status
     2975        ((:success :warn :ignore)
     2976         (delete-file-if-exists output-file)
     2977         (when output-truename
     2978           (rename-file output-truename output-file)
     2979           (setf output-truename output-file)))
     2980        (:error
     2981         (delete-file-if-exists output-truename)
     2982         (setf output-truename nil)))
     2983      (values output-truename warnings-p failure-p))))
    29362984
    29372985#+abcl
     
    33653413;;;; Done!
    33663414(when *load-verbose*
    3367   (asdf-message ";; ASDF, version ~a" (asdf-version)))
     3415  (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
    33683416
    33693417#+allegro
Note: See TracChangeset for help on using the changeset viewer.