Changeset 11305


Ignore:
Timestamp:
Nov 6, 2008, 2:28:41 AM (13 years ago)
Author:
gz
Message:

Update to asdf 1.130

File:
1 edited

Legend:

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

    r9211 r11305  
    1414;;; RELEASE may be slightly older but is considered `stable'
    1515
    16 ;;; Copyright (c) 2001-2007 Daniel Barlow and contributors
     16;;; Copyright (c) 2001-2008 Daniel Barlow and contributors
    1717;;;
    1818;;; Permission is hereby granted, free of charge, to any person obtaining
     
    4141  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
    4242           #:system-definition-pathname #:find-component ; miscellaneous
    43            #:hyperdocumentation #:hyperdoc
    44 
    45            #:compile-op #:load-op #:load-source-op #:test-system-version
     43
     44           #:compile-op #:load-op #:load-source-op
    4645           #:test-op
    47            #:operation                  ; operations
    48            #:feature                    ; sort-of operation
    49            #:version                    ; metaphorically sort-of an operation
    50 
    51            #:input-files #:output-files #:perform       ; operation methods
     46           #:operation          ; operations
     47           #:feature            ; sort-of operation
     48           #:version            ; metaphorically sort-of an operation
     49
     50           #:input-files #:output-files #:perform ; operation methods
    5251           #:operation-done-p #:explain
    5352
     
    8685           #:operation-on-failure
    8786
    88            ;#:*component-parent-pathname*
     87                                        ;#:*component-parent-pathname*
    8988           #:*system-definition-search-functions*
    9089           #:*central-registry*         ; variables
     
    9796           #:system-definition-error
    9897           #:missing-component
     98           #:missing-component-of-version
    9999           #:missing-dependency
     100           #:missing-dependency-of-version
    100101           #:circular-dependency        ; errors
    101102           #:duplicate-names
    102103
     104           #:try-recompiling
    103105           #:retry
    104106           #:accept                     ; restarts
    105107
    106            #:preference-file-for-system/operation
    107            #:load-preferences
    108            )
     108           #:standard-asdf-method-combination
     109           #:around                     ; protocol assistants
     110           )
    109111  (:use :cl))
    110112
     
    175177(define-condition missing-component (system-definition-error)
    176178  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
    177    (version :initform nil :reader missing-version :initarg :version)
    178179   (parent :initform nil :reader missing-parent :initarg :parent)))
     180
     181(define-condition missing-component-of-version (missing-component)
     182  ((version :initform nil :reader missing-version :initarg :version)))
    179183
    180184(define-condition missing-dependency (missing-component)
    181185  ((required-by :initarg :required-by :reader missing-required-by)))
     186
     187(define-condition missing-dependency-of-version (missing-dependency
     188                                                 missing-component-of-version)
     189  ())
    182190
    183191(define-condition operation-error (error)
     
    225233
    226234(defmethod print-object ((c missing-component) s)
    227   (format s "~@<component ~S not found~
    228              ~@[ or does not match version ~A~]~
     235   (format s "~@<component ~S not found~
    229236             ~@[ in ~A~]~@:>"
    230237          (missing-requires c)
    231           (missing-version c)
    232238          (when (missing-parent c)
    233239            (component-name (missing-parent c)))))
     240
     241(defmethod print-object ((c missing-component-of-version) s)
     242  (format s "~@<component ~S does not match version ~A~
     243              ~@[ in ~A~]~@:>"
     244           (missing-requires c)
     245           (missing-version c)
     246           (when (missing-parent c)
     247             (component-name (missing-parent c)))))
    234248
    235249(defgeneric component-system (component)
     
    352366
    353367(defun system-definition-pathname (system)
    354   (some (lambda (x) (funcall x system))
    355         *system-definition-search-functions*))
     368  (let ((system-name (coerce-name system)))
     369    (or
     370     (some (lambda (x) (funcall x system-name))
     371           *system-definition-search-functions*)
     372     (let ((system-pair (system-registered-p system-name)))
     373       (and system-pair
     374            (system-source-file (cdr system-pair)))))))
    356375
    357376(defvar *central-registry*
     
    383402(defun find-system (name &optional (error-p t))
    384403  (let* ((name (coerce-name name))
    385          (in-memory (gethash name *defined-systems*))
     404         (in-memory (system-registered-p name))
    386405         (on-disk (system-definition-pathname name)))
    387406    (when (and on-disk
     
    400419               (load on-disk))
    401420          (delete-package package))))
    402     (let ((in-memory (gethash name *defined-systems*)))
     421    (let ((in-memory (system-registered-p name)))
    403422      (if in-memory
    404423          (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
     
    408427(defun register-system (name system)
    409428  (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
    410   (setf (gethash (coerce-name  name) *defined-systems*)
     429  (setf (gethash (coerce-name name) *defined-systems*)
    411430        (cons (get-universal-time) system)))
    412431
    413432(defun system-registered-p (name)
    414433  (gethash (coerce-name name) *defined-systems*))
     434
    415435
    416436;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    493513  )
    494514
    495 (defgeneric perform (operation component))
    496 (defgeneric operation-done-p (operation component))
    497 (defgeneric explain (operation component))
    498 (defgeneric output-files (operation component))
    499 (defgeneric input-files (operation component))
     515(define-method-combination standard-asdf-method-combination ()
     516  ((around-asdf (around))
     517   (around (:around))
     518   (before (:before))
     519   (primary () :required t)
     520   (after (:after)))
     521  (flet ((call-methods (methods)
     522           (mapcar #'(lambda (method)
     523                       `(call-method ,method))
     524                   methods)))
     525    (let* ((form (if (or before after (rest primary))
     526                     `(multiple-value-prog1
     527                          (progn ,@(call-methods before)
     528                                 (call-method ,(first primary)
     529                                              ,(rest primary)))
     530                        ,@(call-methods (reverse after)))
     531                     `(call-method ,(first primary))))
     532           (standard-form (if around
     533                              `(call-method ,(first around)
     534                                            (,@(rest around)
     535                                               (make-method ,form)))
     536                              form)))
     537      (if around-asdf
     538          `(call-method ,(first around-asdf)
     539                        (,@(rest around-asdf) (make-method ,standard-form)))
     540          standard-form))))
     541
     542(defgeneric perform (operation component)
     543  (:method-combination standard-asdf-method-combination))
     544(defgeneric operation-done-p (operation component)
     545  (:method-combination standard-asdf-method-combination))
     546(defgeneric explain (operation component)
     547  (:method-combination standard-asdf-method-combination))
     548(defgeneric output-files (operation component)
     549  (:method-combination standard-asdf-method-combination))
     550(defgeneric input-files (operation component)
     551  (:method-combination standard-asdf-method-combination))
    500552
    501553(defun node-for (o c)
     
    533585
    534586
     587(defgeneric component-visited-p (operation component))
     588
    535589(defgeneric visit-component (operation component data))
    536590
     
    539593    (push (cons (node-for o c) data)
    540594          (operation-visited-nodes (operation-ancestor o)))))
    541 
    542 (defgeneric component-visited-p (operation component))
    543595
    544596(defmethod component-visited-p ((o operation) (c component))
     
    564616
    565617(defmethod component-visiting-p ((o operation) (c component))
    566   (let ((node (cons o c)))
     618  (let ((node (node-for o c)))
    567619    (member node (operation-visiting-nodes (operation-ancestor o))
    568620            :test 'equal)))
     
    667719                                  ;; names instead of coercing this late
    668720                                  (coerce-name required-c) required-v)
    669                                  (error 'missing-dependency
    670                                         :required-by c
    671                                         :version required-v
    672                                         :requires required-c)))
     721                                 (if required-v
     722                                     (error 'missing-dependency-of-version
     723                                            :required-by c
     724                                            :version required-v
     725                                            :requires required-c)
     726                                     (error 'missing-dependency
     727                                            :required-by c
     728                                            :requires required-c))))
    673729                      (op (make-sub-operation c operation dep-c required-op)))
    674730                 (traverse op dep-c)))
     
    678734                          (error 'missing-dependency
    679735                                 :required-by c
    680                                  :requires (car dep)
    681                                  :version nil)))
     736                                 :requires (car dep))))
    682737                     (t
    683738                      (dolist (d dep)
     
    697752          (error 'circular-dependency :components (list c)))
    698753      (setf (visiting-component operation c) t)
    699       (loop for (required-op . deps) in (component-depends-on operation c)
    700             do (do-dep required-op deps))
    701       ;; constituent bits
    702       (let ((module-ops
    703              (when (typep c 'module)
    704                (let ((at-least-one nil)
    705                      (forced nil)
    706                      (error nil))
    707                  (loop for kid in (module-components c)
    708                        do (handler-case
    709                               (appendf forced (traverse operation kid ))
    710                             (missing-dependency (condition)
    711                               (if (eq (module-if-component-dep-fails c) :fail)
    712                                   (error condition))
    713                               (setf error condition))
    714                             (:no-error (c)
    715                               (declare (ignore c))
    716                               (setf at-least-one t))))
    717                  (when (and (eq (module-if-component-dep-fails c) :try-next)
    718                             (not at-least-one))
    719                    (error error))
    720                  forced))))
    721         ;; now the thing itself
    722         (when (or forced module-ops
    723                   (not (operation-done-p operation c))
    724                   (let ((f (operation-forced (operation-ancestor operation))))
    725                     (and f (or (not (consp f))
    726                                (member (component-name
    727                                         (operation-ancestor operation))
    728                                        (mapcar #'coerce-name f)
    729                                        :test #'string=)))))
    730           (let ((do-first (cdr (assoc (class-name (class-of operation))
    731                                       (slot-value c 'do-first)))))
    732             (loop for (required-op . deps) in do-first
    733                   do (do-dep required-op deps)))
    734           (setf forced (append (delete 'pruned-op forced :key #'car)
    735                                (delete 'pruned-op module-ops :key #'car)
    736                                (list (cons operation c))))))
    737       (setf (visiting-component operation c) nil)
     754      (unwind-protect
     755           (progn
     756             (loop for (required-op . deps) in
     757                  (component-depends-on operation c)
     758                do (do-dep required-op deps))
     759             ;; constituent bits
     760             (let ((module-ops
     761                    (when (typep c 'module)
     762                      (let ((at-least-one nil)
     763                            (forced nil)
     764                            (error nil))
     765                        (loop for kid in (module-components c)
     766                           do (handler-case
     767                                  (appendf forced (traverse operation kid ))
     768                                (missing-dependency (condition)
     769                                  (if (eq (module-if-component-dep-fails c)
     770                                          :fail)
     771                                      (error condition))
     772                                  (setf error condition))
     773                                (:no-error (c)
     774                                  (declare (ignore c))
     775                                  (setf at-least-one t))))
     776                        (when (and (eq (module-if-component-dep-fails c)
     777                                       :try-next)
     778                                   (not at-least-one))
     779                          (error error))
     780                        forced))))
     781               ;; now the thing itself
     782               (when (or forced module-ops
     783                         (not (operation-done-p operation c))
     784                         (let ((f (operation-forced
     785                                   (operation-ancestor operation))))
     786                           (and f (or (not (consp f))
     787                                      (member (component-name
     788                                               (operation-ancestor operation))
     789                                              (mapcar #'coerce-name f)
     790                                              :test #'string=)))))
     791                 (let ((do-first (cdr (assoc (class-name (class-of operation))
     792                                             (slot-value c 'do-first)))))
     793                   (loop for (required-op . deps) in do-first
     794                      do (do-dep required-op deps)))
     795                 (setf forced (append (delete 'pruned-op forced :key #'car)
     796                                      (delete 'pruned-op module-ops :key #'car)
     797                                      (list (cons operation c)))))))
     798        (setf (visiting-component operation c) nil))
    738799      (visit-component operation c (and forced t))
    739800      forced)))
     
    766827(defmethod perform :after ((operation operation) (c component))
    767828  (setf (gethash (type-of operation) (component-operation-times c))
    768         (get-universal-time))
    769   (load-preferences c operation))
     829        (get-universal-time)))
    770830
    771831;;; perform is required to check output-files to find out where to put
     
    817877  (mapcar #'load (input-files o c)))
    818878
     879(defmethod perform around ((o load-op) (c cl-source-file))
     880  (let ((state :initial))
     881    (loop until (or (eq state :success)
     882                    (eq state :failure)) do
     883         (case state
     884           (:recompiled
     885            (setf state :failure)
     886            (call-next-method)
     887            (setf state :success))
     888           (:failed-load
     889            (setf state :recompiled)
     890            (perform (make-instance 'asdf:compile-op) c))
     891           (t
     892            (with-simple-restart
     893                (try-recompiling "Recompile ~a and try loading it again"
     894                                  (component-name c))
     895              (setf state :failed-load)
     896              (call-next-method)
     897              (setf state :success)))))))
     898
     899(defmethod perform around ((o compile-op) (c cl-source-file))
     900  (let ((state :initial))
     901    (loop until (or (eq state :success)
     902                    (eq state :failure)) do
     903         (case state
     904           (:recompiled
     905            (setf state :failure)
     906            (call-next-method)
     907            (setf state :success))
     908           (:failed-compile
     909            (setf state :recompiled)
     910            (perform (make-instance 'asdf:compile-op) c))
     911           (t
     912            (with-simple-restart
     913                (try-recompiling "Try recompiling ~a"
     914                                  (component-name c))
     915              (setf state :failed-compile)
     916              (call-next-method)
     917              (setf state :success)))))))
     918
    819919(defmethod perform ((operation load-op) (c static-file))
    820920  nil)
     921
    821922(defmethod operation-done-p ((operation load-op) (c static-file))
    822923  t)
     
    866967  nil)
    867968
    868 (defgeneric load-preferences (system operation)
    869   (:documentation
    870    "Called to load system preferences after <perform operation
    871 system>. Typical uses are to set parameters that don't exist until
    872 after the system has been loaded."))
    873 
    874 (defgeneric preference-file-for-system/operation (system operation)
    875   (:documentation
    876    "Returns the pathname of the preference file for this system.
    877 Called by 'load-preferences to determine what file to load."))
    878 
    879 (defmethod load-preferences ((s t) (operation t))
    880   ;; do nothing
    881   (values))
    882 
    883 (defmethod load-preferences ((s system) (operation basic-load-op))
    884   (let* ((*package* (find-package :common-lisp))
    885          (file (probe-file (preference-file-for-system/operation s operation))))
    886     (when file
    887       (when *verbose-out*
    888         (format *verbose-out*
    889                 "~&~@<; ~@;loading preferences for ~A/~(~A~) from ~A~@:>~%"
    890                 (component-name s)
    891                 (type-of operation) file))
    892       (load file))))
    893 
    894 (defmethod preference-file-for-system/operation ((system t) (operation t))
    895   ;; cope with anything other than systems
    896   (preference-file-for-system/operation (find-system system t) operation))
    897 
    898 (defmethod preference-file-for-system/operation ((s system) (operation t))
    899   (let ((*default-pathname-defaults*
    900          (make-pathname :name nil :type nil
    901                         :defaults *default-pathname-defaults*)))
    902      (merge-pathnames
    903       (make-pathname :name (component-name s)
    904                      :type "lisp"
    905                      :directory '(:relative ".asdf"))
    906       (truename (user-homedir-pathname)))))
     969(defmethod operation-done-p ((operation test-op) (c system))
     970  "Testing a system is _never_ done."
     971  nil)
    907972
    908973;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    931996         (system (if (typep system 'component) system (find-system system))))
    932997    (unless (version-satisfies system version)
    933       (error 'missing-component :requires system :version version))
     998      (error 'missing-component-of-version :requires system :version version))
    934999    (let ((steps (traverse op system)))
    9351000      (with-compilation-unit ()
     
    12411306    ))
    12421307
    1243 
    1244 (defgeneric hyperdocumentation (package name doc-type))
    1245 (defmethod hyperdocumentation ((package symbol) name doc-type)
    1246   (hyperdocumentation (find-package package) name doc-type))
    1247 
    1248 (defun hyperdoc (name doc-type)
    1249   (hyperdocumentation (symbol-package name) name doc-type))
    1250 
    1251 (defun system-source-file (system-name)
    1252   (let ((system (asdf:find-system system-name)))
    1253     (make-pathname
    1254      :type "asd"
    1255      :name (asdf:component-name system)
    1256      :defaults (asdf:component-relative-pathname system))))
    1257 
     1308(defgeneric system-source-file (system)
     1309  (:documentation "Return the source file in which system is defined."))
     1310
     1311(defmethod system-source-file ((system-name t))
     1312  (system-source-file (find-system system-name)))
     1313
     1314(defmethod system-source-file ((system system))
     1315  (let ((pn (and (slot-boundp system 'relative-pathname)
     1316                 (make-pathname
     1317                  :type "asd"
     1318                  :name (asdf:component-name system)
     1319                  :defaults (asdf:component-relative-pathname system)))))
     1320    (when pn
     1321      (probe-file pn))))
     1322 
    12581323(defun system-source-directory (system-name)
    12591324  (make-pathname :name nil
     
    12621327
    12631328(defun system-relative-pathname (system pathname &key name type)
    1264   (let ((directory (pathname-directory pathname)))
     1329  ;; you're not allowed to muck with the return value of pathname-X
     1330  (let ((directory (copy-list (pathname-directory pathname))))
    12651331    (when (eq (car directory) :absolute)
    12661332      (setf (car directory) :relative))
     
    12701336                    :directory directory)
    12711337     (system-source-directory system))))
    1272 
    12731338
    12741339(pushnew :asdf *features*)
Note: See TracChangeset for help on using the changeset viewer.