Changeset 4703


Ignore:
Timestamp:
May 31, 2006, 1:27:35 AM (13 years ago)
Author:
gwking
Message:

Updated asdf to the current CVS head (revision 1.98)

File:
1 edited

Legend:

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

    r2258 r4703  
    360360              (return file)))))))
    361361
     362(defun make-temporary-package ()
     363  (flet ((try (counter)
     364           (ignore-errors
     365                   (make-package (format nil "ASDF~D" counter)
     366                                 :use '(:cl :asdf)))))
     367    (do* ((counter 0 (+ counter 1))
     368          (package (try counter) (try counter)))
     369         (package package))))
    362370
    363371(defun find-system (name &optional (error-p t))
     
    368376               (or (not in-memory)
    369377                   (< (car in-memory) (file-write-date on-disk))))
    370       (let ((*package* (make-package (gensym #.(package-name *package*))
    371                                      :use '(:cl :asdf))))
    372         (format *verbose-out*
    373                 "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    374                 ;; FIXME: This wants to be (ENOUGH-NAMESTRING
    375                 ;; ON-DISK), but CMUCL barfs on that.
     378      (let ((package (make-temporary-package)))
     379        (unwind-protect
     380             (let ((*package* package))
     381               (format
     382                *verbose-out*
     383                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
     384                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
     385                ;; ON-DISK), but CMUCL barfs on that.
    376386                on-disk
    377387                *package*)
    378         (load on-disk)))
     388               (load on-disk))
     389          (delete-package package))))
    379390    (let ((in-memory (gethash name *defined-systems*)))
    380391      (if in-memory
     
    430441
    431442(defmethod component-relative-pathname ((component source-file))
    432   (let* ((*default-pathname-defaults* (component-parent-pathname component))
    433          (name-type
    434           (make-pathname
    435            :name (component-name component)
    436            :type (source-file-type component
    437                                    (component-system component)))))
    438     (if (slot-value component 'relative-pathname)
    439         (merge-pathnames
    440          (slot-value component 'relative-pathname)
    441          name-type)
    442         name-type)))
     443  (let ((relative-pathname (slot-value component 'relative-pathname)))
     444    (if relative-pathname
     445        (merge-pathnames
     446         relative-pathname
     447         (make-pathname
     448          :type (source-file-type component (component-system component))))
     449        (let* ((*default-pathname-defaults*
     450                (component-parent-pathname component))
     451               (name-type
     452                (make-pathname
     453                 :name (component-name component)
     454                 :type (source-file-type component
     455                                         (component-system component)))))
     456          name-type))))
    443457
    444458;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    570584
    571585(defmethod operation-done-p ((o operation) (c component))
    572   (let ((out-files (output-files o c))
    573         (in-files (input-files o c)))
    574     (cond ((and (not in-files) (not out-files))
    575            ;; arbitrary decision: an operation that uses nothing to
    576            ;; produce nothing probably isn't doing much
    577            t)
    578           ((not out-files)
    579            (let ((op-done
    580                   (gethash (type-of o)
    581                            (component-operation-times c))))
    582              (and op-done
    583                   (>= op-done
    584                       (or (apply #'max
    585                                  (mapcar #'file-write-date in-files)) 0)))))
    586           ((not in-files) nil)
    587           (t
    588            (and
    589             (every #'probe-file out-files)
    590             (> (apply #'min (mapcar #'file-write-date out-files))
    591                (apply #'max (mapcar #'file-write-date in-files)) ))))))
     586  (flet ((fwd-or-return-t (file)
     587           ;; if FILE-WRITE-DATE returns NIL, it's possible that the
     588           ;; user or some other agent has deleted an input file.  If
     589           ;; that's the case, well, that's not good, but as long as
     590           ;; the operation is otherwise considered to be done we
     591           ;; could continue and survive.
     592           (let ((date (file-write-date file)))
     593             (cond
     594               (date)
     595               (t
     596                (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
     597                       operation ~S on component ~S as done.~@:>"
     598                      file o c)
     599                (return-from operation-done-p t))))))
     600    (let ((out-files (output-files o c))
     601          (in-files (input-files o c)))
     602      (cond ((and (not in-files) (not out-files))
     603             ;; arbitrary decision: an operation that uses nothing to
     604             ;; produce nothing probably isn't doing much
     605             t)
     606            ((not out-files)
     607             (let ((op-done
     608                    (gethash (type-of o)
     609                             (component-operation-times c))))
     610               (and op-done
     611                    (>= op-done
     612                        (apply #'max
     613                               (mapcar #'fwd-or-return-t in-files))))))
     614            ((not in-files) nil)
     615            (t
     616             (and
     617              (every #'probe-file out-files)
     618              (> (apply #'min (mapcar #'file-write-date out-files))
     619                 (apply #'max (mapcar #'fwd-or-return-t in-files)))))))))
    592620
    593621;;; So you look at this code and think "why isn't it a bunch of
     
    801829;;; invoking operations
    802830
    803 (defun operate (operation-class system &rest args)
     831(defun operate (operation-class system &rest args &key (verbose t) version
     832                                &allow-other-keys)
    804833  (let* ((op (apply #'make-instance operation-class
    805                     :original-initargs args args))
    806          (*verbose-out*
    807           (if (getf args :verbose t)
    808               *trace-output*
    809               (make-broadcast-stream)))
    810          (system (if (typep system 'component) system (find-system system)))
    811          (steps (traverse op system)))
    812     (with-compilation-unit ()
    813       (loop for (op . component) in steps do
    814             (loop
    815              (restart-case
    816                  (progn (perform op component)
    817                         (return))
    818                (retry ()
    819                  :report
    820                  (lambda (s)
    821                    (format s "~@<Retry performing ~S on ~S.~@:>"
    822                            op component)))
    823                (accept ()
    824                  :report
    825                  (lambda (s)
    826                    (format s
    827                            "~@<Continue, treating ~S on ~S as ~
    828                             having been successful.~@:>"
    829                            op component))
    830                  (setf (gethash (type-of op)
    831                                 (component-operation-times component))
    832                        (get-universal-time))
    833                  (return))))))))
     834                    :original-initargs args
     835                    args))
     836         (*verbose-out* (if verbose *trace-output* (make-broadcast-stream)))
     837         (system (if (typep system 'component) system (find-system system))))
     838    (unless (version-satisfies system version)
     839      (error 'missing-component :requires system :version version))
     840    (let ((steps (traverse op system)))
     841      (with-compilation-unit ()
     842        (loop for (op . component) in steps do
     843             (loop
     844                (restart-case
     845                    (progn (perform op component)
     846                           (return))
     847                  (retry ()
     848                    :report
     849                    (lambda (s)
     850                      (format s "~@<Retry performing ~S on ~S.~@:>"
     851                              op component)))
     852                  (accept ()
     853                    :report
     854                    (lambda (s)
     855                      (format s
     856                              "~@<Continue, treating ~S on ~S as ~
     857                               having been successful.~@:>"
     858                              op component))
     859                    (setf (gethash (type-of op)
     860                                   (component-operation-times component))
     861                          (get-universal-time))
     862                    (return)))))))))
    834863
    835864(defun oos (&rest args)
     
    931960              components pathname default-component-class
    932961              perform explain output-files operation-done-p
     962              weakly-depends-on
    933963              depends-on serial in-order-to
    934964              ;; list ends
    935965              &allow-other-keys) options
    936     (check-component-input type name depends-on components in-order-to)
     966    (check-component-input type name weakly-depends-on depends-on components in-order-to)
    937967
    938968    (when (and parent
     
    947977                        '(components pathname default-component-class
    948978                          perform explain output-files operation-done-p
     979                          weakly-depends-on
    949980                          depends-on serial in-order-to)
    950981                        rest))
     
    952983            (or (find-component parent name)
    953984                (make-instance (class-for-type parent type)))))
     985      (when weakly-depends-on
     986        (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
    954987      (when (boundp '*serial-depends-on*)
    955988        (setf depends-on
    956               (concatenate 'list *serial-depends-on* depends-on)))
     989              (concatenate 'list *serial-depends-on* depends-on)))     
    957990      (apply #'reinitialize-instance
    958991             ret
     
    9751008
    9761009        ;; check for duplicate names
    977         #+check-for-global-duplicates
    978         (let ((name-hash (make-hash-table :test #'equalp)))
     1010        (let ((name-hash (make-hash-table :test #'equal)))
    9791011          (loop for c in (module-components ret)
    9801012                do
     
    10111043      ret)))
    10121044
    1013 (defun check-component-input (type name depends-on components in-order-to)
     1045(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
    10141046  "A partial test of the values of a component."
     1047  (when weakly-depends-on (warn "We got one! XXXXX"))
    10151048  (unless (listp depends-on)
    10161049    (sysdef-error-component ":depends-on must be a list."
    10171050                            type name depends-on))
     1051  (unless (listp weakly-depends-on)
     1052    (sysdef-error-component ":weakly-depends-on must be a list."
     1053                            type name weakly-depends-on))
    10181054  (unless (listp components)
    10191055    (sysdef-error-component ":components must be NIL or a list of components."
     
    10421078  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
    10431079synchronously execute the result using a Bourne-compatible shell, with
    1044 output to *verbose-out*.  Returns the shell's exit code."
     1080output to *VERBOSE-OUT*.  Returns the shell's exit code."
    10451081  (let ((command (apply #'format nil control-string args)))
    10461082    (format *verbose-out* "; $ ~A~%" command)
    10471083    #+sbcl
    1048     (sb-impl::process-exit-code
     1084    (sb-ext:process-exit-code
    10491085     (sb-ext:run-program 
    1050       "/bin/sh"
     1086      #+win32 "sh" #-win32 "/bin/sh"
    10511087      (list  "-c" command)
     1088      #+win32 #+win32 :search t
    10521089      :input nil :output *verbose-out*))
    10531090   
     
    11091146          t))))
    11101147
    1111   (pushnew
    1112    '(merge-pathnames "systems/"
    1113      (truename (sb-ext:posix-getenv "SBCL_HOME")))
    1114    *central-registry*)
     1148  (defun contrib-sysdef-search (system)
     1149    (let* ((name (coerce-name system))
     1150           (home (truename (sb-ext:posix-getenv "SBCL_HOME")))
     1151           (contrib (merge-pathnames
     1152                     (make-pathname :directory `(:relative ,name)
     1153                                    :name name
     1154                                    :type "asd"
     1155                                    :case :local
     1156                                    :version :newest)
     1157                     home)))
     1158      (probe-file contrib)))
    11151159 
    11161160  (pushnew
     
    11241168   *central-registry*)
    11251169 
    1126   (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*))
    1127 
    1128 #+openmcl
    1129 (when (boundp 'ccl::*module-provider-functions*)  ;; openmcl 0.14.1 and newer
    1130   (defun module-provide-asdf (module)
    1131     (handler-bind ((style-warning #'muffle-warning))
    1132                   (let* ((*verbose-out* (make-broadcast-stream))
    1133                          (system (asdf:find-system module nil)))
    1134                     (when system
    1135                       (asdf:operate 'asdf:load-op module)
    1136                       t))))
    1137 
    1138   (pushnew 'module-provide-asdf ccl::*module-provider-functions*))
    1139 
     1170  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
     1171  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
    11401172
    11411173(provide 'asdf)
Note: See TracChangeset for help on using the changeset viewer.