Changeset 11303


Ignore:
Timestamp:
Nov 5, 2008, 11:03:41 PM (12 years ago)
Author:
gz
Message:

Update to asdf 1.130

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/tools/asdf.lisp

    r4703 r11303  
    1414;;; RELEASE may be slightly older but is considered `stable'
    1515
    16 ;;; Copyright (c) 2001-2003 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
     
    4040(defpackage #:asdf
    4141  (:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
    42            #:system-definition-pathname #:find-component ; miscellaneous
    43            #:hyperdocumentation #:hyperdoc
    44            
    45            #:compile-op #:load-op #:load-source-op #:test-system-version
    46            #: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
    52            #:operation-done-p #:explain
    53            
    54            #:component #:source-file
    55            #:c-source-file #:cl-source-file #:java-source-file
    56            #:static-file
    57            #:doc-file
    58            #:html-file
    59            #:text-file
    60            #:source-file-type
    61            #:module                     ; components
    62            #:system
    63            #:unix-dso
    64            
    65            #:module-components          ; component accessors
    66            #:component-pathname
    67            #:component-relative-pathname
    68            #:component-name
    69            #:component-version
    70            #:component-parent
    71            #:component-property
    72            #:component-system
    73            
    74            #:component-depends-on
    75 
    76            #:system-description
    77            #:system-long-description
    78            #:system-author
    79            #:system-maintainer
    80            #:system-license
    81            
    82            #:operation-on-warnings
    83            #:operation-on-failure
    84            
    85            ;#:*component-parent-pathname*
    86            #:*system-definition-search-functions*
    87            #:*central-registry*         ; variables
    88            #:*compile-file-warnings-behaviour*
    89            #:*compile-file-failure-behaviour*
    90            #:*asdf-revision*
    91            
    92            #:operation-error #:compile-failed #:compile-warned #:compile-error
    93            #:error-component #:error-operation
    94            #:system-definition-error
    95            #:missing-component
    96            #:missing-dependency
    97            #:circular-dependency        ; errors
    98            #:duplicate-names
    99            
    100            #:retry
    101            #:accept                     ; restarts
    102            
     42           #:system-definition-pathname #:find-component ; miscellaneous
     43
     44           #:compile-op #:load-op #:load-source-op
     45           #:test-op
     46           #:operation           ; operations
     47           #:feature             ; sort-of operation
     48           #:version             ; metaphorically sort-of an operation
     49
     50           #:input-files #:output-files #:perform ; operation methods
     51           #:operation-done-p #:explain
     52
     53           #:component #:source-file
     54           #:c-source-file #:cl-source-file #:java-source-file
     55           #:static-file
     56           #:doc-file
     57           #:html-file
     58           #:text-file
     59           #:source-file-type
     60           #:module                     ; components
     61           #:system
     62           #:unix-dso
     63
     64           #:module-components          ; component accessors
     65           #:component-pathname
     66           #:component-relative-pathname
     67           #:component-name
     68           #:component-version
     69           #:component-parent
     70           #:component-property
     71           #:component-system
     72
     73           #:component-depends-on
     74
     75           #:system-description
     76           #:system-long-description
     77           #:system-author
     78           #:system-maintainer
     79           #:system-license
     80           #:system-licence
     81           #:system-source-file
     82           #:system-relative-pathname
     83
     84           #:operation-on-warnings
     85           #:operation-on-failure
     86
     87                                        ;#:*component-parent-pathname*
     88           #:*system-definition-search-functions*
     89           #:*central-registry*         ; variables
     90           #:*compile-file-warnings-behaviour*
     91           #:*compile-file-failure-behaviour*
     92           #:*asdf-revision*
     93
     94           #:operation-error #:compile-failed #:compile-warned #:compile-error
     95           #:error-component #:error-operation
     96           #:system-definition-error
     97           #:missing-component
     98           #:missing-component-of-version
     99           #:missing-dependency
     100           #:missing-dependency-of-version
     101           #:circular-dependency        ; errors
     102           #:duplicate-names
     103
     104           #:try-recompiling
     105           #:retry
     106           #:accept                     ; restarts
     107
     108           #:standard-asdf-method-combination
     109           #:around                     ; protocol assistants
    103110           )
    104111  (:use :cl))
    105112
     113
    106114#+nil
    107 (error "The author of this file habitually uses #+nil to comment out forms.  But don't worry, it was unlikely to work in the New Implementation of Lisp anyway")
    108 
     115(error "The author of this file habitually uses #+nil to comment out ~
     116        forms. But don't worry, it was unlikely to work in the New ~
     117        Implementation of Lisp anyway")
    109118
    110119(in-package #:asdf)
    111120
    112121(defvar *asdf-revision* (let* ((v "$Revision$")
    113                                (colon (or (position #\: v) -1))
    114                                (dot (position #\. v)))
    115                           (and v colon dot
    116                                (list (parse-integer v :start (1+ colon)
    117                                                     :junk-allowed t)
    118                                      (parse-integer v :start (1+ dot)
    119                                                     :junk-allowed t)))))
     122                               (colon (or (position #\: v) -1))
     123                               (dot (position #\. v)))
     124                          (and v colon dot
     125                               (list (parse-integer v :start (1+ colon)
     126                                                      :junk-allowed t)
     127                                     (parse-integer v :start (1+ dot)
     128                                                      :junk-allowed t)))))
    120129
    121130(defvar *compile-file-warnings-behaviour* :warn)
     131
    122132(defvar *compile-file-failure-behaviour* #+sbcl :error #-sbcl :warn)
    123133
    124134(defvar *verbose-out* nil)
     135
     136(defparameter +asdf-methods+
     137  '(perform explain output-files operation-done-p))
    125138
    126139;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    135148  (make-pathname :name nil :type nil :defaults pathname))
    136149
    137 (define-modify-macro appendf (&rest args) 
    138                      append "Append onto list")
     150(define-modify-macro appendf (&rest args)
     151  append "Append onto list")
    139152
    140153;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    154167   (format-arguments :initarg :format-arguments :reader format-arguments))
    155168  (:report (lambda (c s)
    156              (apply #'format s (format-control c) (format-arguments c)))))
     169             (apply #'format s (format-control c) (format-arguments c)))))
    157170
    158171(define-condition circular-dependency (system-definition-error)
     
    164177(define-condition missing-component (system-definition-error)
    165178  ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
    166    (version :initform nil :reader missing-version :initarg :version)
    167179   (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)))
    168183
    169184(define-condition missing-dependency (missing-component)
    170185  ((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  ())
    171190
    172191(define-condition operation-error (error)
     
    174193   (operation :reader error-operation :initarg :operation))
    175194  (:report (lambda (c s)
    176              (format s "~@<erred while invoking ~A on ~A~@:>"
    177                      (error-operation c) (error-component c)))))
     195             (format s "~@<erred while invoking ~A on ~A~@:>"
     196                     (error-operation c) (error-component c)))))
    178197(define-condition compile-error (operation-error) ())
    179198(define-condition compile-failed (compile-error) ())
     
    182201(defclass component ()
    183202  ((name :accessor component-name :initarg :name :documentation
    184         "Component name: designator for a string composed of portable pathname characters")
     203        "Component name: designator for a string composed of portable pathname characters")
    185204   (version :accessor component-version :initarg :version)
    186205   (in-order-to :initform nil :initarg :in-order-to)
    187    ;;; XXX crap name
     206   ;; XXX crap name
    188207   (do-first :initform nil :initarg :do-first)
    189208   ;; methods defined using the "inline" style inside a defsystem form:
     
    196215   (relative-pathname :initarg :pathname)
    197216   (operation-times :initform (make-hash-table )
    198                     :accessor component-operation-times)
     217                    :accessor component-operation-times)
    199218   ;; XXX we should provide some atomic interface for updating the
    200219   ;; component properties
    201220   (properties :accessor component-properties :initarg :properties
    202                :initform nil)))
     221               :initform nil)))
    203222
    204223;;;; methods: conditions
     
    206225(defmethod print-object ((c missing-dependency) s)
    207226  (format s "~@<~A, required by ~A~@:>"
    208           (call-next-method c nil) (missing-required-by c)))
     227          (call-next-method c nil) (missing-required-by c)))
    209228
    210229(defun sysdef-error (format &rest arguments)
     
    214233
    215234(defmethod print-object ((c missing-component) s)
    216   (format s "~@<component ~S not found~
    217              ~@[ or does not match version ~A~]~
     235   (format s "~@<component ~S not found~
    218236             ~@[ in ~A~]~@:>"
    219           (missing-requires c)
    220           (missing-version c)
    221           (when (missing-parent c)
    222             (component-name (missing-parent c)))))
     237          (missing-requires c)
     238          (when (missing-parent c)
     239            (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)))))
    223248
    224249(defgeneric component-system (component)
    225250  (:documentation "Find the top-level system containing COMPONENT"))
    226  
     251
    227252(defmethod component-system ((component component))
    228253  (aif (component-parent component)
     
    240265   ;; components.  This allows a limited form of conditional processing
    241266   (if-component-dep-fails :initform :fail
    242                            :accessor module-if-component-dep-fails
    243                            :initarg :if-component-dep-fails)
     267                           :accessor module-if-component-dep-fails
     268                           :initarg :if-component-dep-fails)
    244269   (default-component-class :accessor module-default-component-class
    245270     :initform 'cl-source-file :initarg :default-component-class)))
     
    255280(defgeneric component-relative-pathname (component)
    256281  (:documentation "Extracts the relative pathname applicable for a particular component."))
    257    
     282
    258283(defmethod component-relative-pathname ((component module))
    259284  (or (slot-value component 'relative-pathname)
     
    276301  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
    277302    (if a
    278         (setf (cdr a) new-value)
    279         (setf (slot-value c 'properties)
    280               (acons property new-value (slot-value c 'properties))))))
     303        (setf (cdr a) new-value)
     304        (setf (slot-value c 'properties)
     305              (acons property new-value (slot-value c 'properties))))))
    281306
    282307(defclass system (module)
     
    286311   (author :accessor system-author :initarg :author)
    287312   (maintainer :accessor system-maintainer :initarg :maintainer)
    288    (licence :accessor system-licence :initarg :licence)))
     313   (licence :accessor system-licence :initarg :licence
     314            :accessor system-license :initarg :license)))
    289315
    290316;;; version-satisfies
     
    296322     (let ((list nil) (start 0) (words 0) end)
    297323       (loop
    298         (when (and max (>= words (1- max)))
    299           (return (cons (subseq string start) list)))
    300         (setf end (position-if #'is-ws string :start start))
    301         (push (subseq string start end) list)
    302         (incf words)
    303         (unless end (return list))
    304         (setf start (1+ end)))))))
     324         (when (and max (>= words (1- max)))
     325           (return (cons (subseq string start) list)))
     326         (setf end (position-if #'is-ws string :start start))
     327         (push (subseq string start end) list)
     328         (incf words)
     329         (unless end (return list))
     330         (setf start (1+ end)))))))
    305331
    306332(defgeneric version-satisfies (component version))
     
    310336    (return-from version-satisfies t))
    311337  (let ((x (mapcar #'parse-integer
    312                    (split (component-version c) nil '(#\.))))
    313         (y (mapcar #'parse-integer
    314                    (split version nil '(#\.)))))
     338                   (split (component-version c) nil '(#\.))))
     339        (y (mapcar #'parse-integer
     340                   (split version nil '(#\.)))))
    315341    (labels ((bigger (x y)
    316                (cond ((not y) t)
    317                      ((not x) nil)
    318                      ((> (car x) (car y)) t)
    319                      ((= (car x) (car y))
    320                       (bigger (cdr x) (cdr y))))))
     342               (cond ((not y) t)
     343                     ((not x) nil)
     344                     ((> (car x) (car y)) t)
     345                     ((= (car x) (car y))
     346                      (bigger (cdr x) (cdr y))))))
    321347      (and (= (car x) (car y))
    322            (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
     348           (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
    323349
    324350;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    327353(defvar *defined-systems* (make-hash-table :test 'equal))
    328354(defun coerce-name (name)
    329    (typecase name
    330      (component (component-name name))
    331      (symbol (string-downcase (symbol-name name)))
    332      (string name)
    333      (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
     355  (typecase name
     356    (component (component-name name))
     357    (symbol (string-downcase (symbol-name name)))
     358    (string name)
     359    (t (sysdef-error "~@<invalid component designator ~A~@:>" name))))
    334360
    335361;;; for the sake of keeping things reasonably neat, we adopt a
     
    340366
    341367(defun system-definition-pathname (system)
    342   (some (lambda (x) (funcall x system))
    343         *system-definition-search-functions*))
    344        
     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)))))))
     375
    345376(defvar *central-registry*
    346377  '(*default-pathname-defaults*
     
    352383    (block nil
    353384      (dolist (dir *central-registry*)
    354         (let* ((defaults (eval dir))
    355                (file (and defaults
    356                           (make-pathname
    357                            :defaults defaults :version :newest
    358                            :name name :type "asd" :case :local))))
    359           (if (and file (probe-file file))
    360               (return file)))))))
     385        (let* ((defaults (eval dir))
     386               (file (and defaults
     387                          (make-pathname
     388                           :defaults defaults :version :newest
     389                           :name name :type "asd" :case :local))))
     390          (if (and file (probe-file file))
     391              (return file)))))))
    361392
    362393(defun make-temporary-package ()
    363394  (flet ((try (counter)
    364395           (ignore-errors
    365                    (make-package (format nil "ASDF~D" counter)
    366                                  :use '(:cl :asdf)))))
     396             (make-package (format nil "ASDF~D" counter)
     397                           :use '(:cl :asdf)))))
    367398    (do* ((counter 0 (+ counter 1))
    368399          (package (try counter) (try counter)))
     
    371402(defun find-system (name &optional (error-p t))
    372403  (let* ((name (coerce-name name))
    373          (in-memory (gethash name *defined-systems*))
    374          (on-disk (system-definition-pathname name)))   
     404         (in-memory (system-registered-p name))
     405         (on-disk (system-definition-pathname name)))
    375406    (when (and on-disk
    376                (or (not in-memory)
    377                    (< (car in-memory) (file-write-date on-disk))))
     407               (or (not in-memory)
     408                   (< (car in-memory) (file-write-date on-disk))))
    378409      (let ((package (make-temporary-package)))
    379410        (unwind-protect
    380411             (let ((*package* package))
    381                (format 
     412               (format
    382413                *verbose-out*
    383414                "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
    384415                ;; FIXME: This wants to be (ENOUGH-NAMESTRING
    385416                ;; ON-DISK), but CMUCL barfs on that.
    386                 on-disk
    387                 *package*)
     417                on-disk
     418                *package*)
    388419               (load on-disk))
    389420          (delete-package package))))
    390     (let ((in-memory (gethash name *defined-systems*)))
     421    (let ((in-memory (system-registered-p name)))
    391422      (if in-memory
    392           (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
    393                 (cdr in-memory))
    394           (if error-p (error 'missing-component :requires name))))))
     423          (progn (if on-disk (setf (car in-memory) (file-write-date on-disk)))
     424                (cdr in-memory))
     425          (if error-p (error 'missing-component :requires name))))))
    395426
    396427(defun register-system (name system)
    397428  (format *verbose-out* "~&~@<; ~@;registering ~A as ~A~@:>~%" system name)
    398   (setf (gethash (coerce-name  name) *defined-systems*)
    399         (cons (get-universal-time) system)))
     429  (setf (gethash (coerce-name name) *defined-systems*)
     430        (cons (get-universal-time) system)))
    400431
    401432(defun system-registered-p (name)
    402433  (gethash (coerce-name name) *defined-systems*))
     434
    403435
    404436;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    413445  (if (slot-boundp module 'components)
    414446      (let ((m (find name (module-components module)
    415                      :test #'equal :key #'component-name)))
    416         (if (and m (version-satisfies m version)) m))))
    417            
     447                     :test #'equal :key #'component-name)))
     448        (if (and m (version-satisfies m version)) m))))
     449
    418450
    419451;;; a component with no parent is a system
     
    443475  (let ((relative-pathname (slot-value component 'relative-pathname)))
    444476    (if relative-pathname
    445         (merge-pathnames 
     477        (merge-pathnames
    446478         relative-pathname
    447          (make-pathname 
     479         (make-pathname
    448480          :type (source-file-type component (component-system component))))
    449         (let* ((*default-pathname-defaults* 
     481        (let* ((*default-pathname-defaults*
    450482                (component-parent-pathname component))
    451483               (name-type
     
    464496  ((forced :initform nil :initarg :force :accessor operation-forced)
    465497   (original-initargs :initform nil :initarg :original-initargs
    466                       :accessor operation-original-initargs)
     498                      :accessor operation-original-initargs)
    467499   (visited-nodes :initform nil :accessor operation-visited-nodes)
    468500   (visiting-nodes :initform nil :accessor operation-visiting-nodes)
     
    475507
    476508(defmethod shared-initialize :after ((operation operation) slot-names
    477                                      &key force
    478                                      &allow-other-keys)
     509                                     &key force
     510                                     &allow-other-keys)
    479511  (declare (ignore slot-names force))
    480512  ;; empty method to disable initarg validity checking
    481513  )
    482514
    483 (defgeneric perform (operation component))
    484 (defgeneric operation-done-p (operation component))
    485 (defgeneric explain (operation component))
    486 (defgeneric output-files (operation component))
    487 (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))
    488552
    489553(defun node-for (o c)
     
    491555
    492556(defgeneric operation-ancestor (operation)
    493   (:documentation   "Recursively chase the operation's parent pointer until we get to the head of the tree"))
     557  (:documentation
     558   "Recursively chase the operation's parent pointer until we get to
     559the head of the tree"))
    494560
    495561(defmethod operation-ancestor ((operation operation))
     
    501567(defun make-sub-operation (c o dep-c dep-o)
    502568  (let* ((args (copy-list (operation-original-initargs o)))
    503         (force-p (getf args :force)))
     569        (force-p (getf args :force)))
    504570    ;; note explicit comparison with T: any other non-NIL force value
    505571    ;; (e.g. :recursive) will pass through
    506572    (cond ((and (null (component-parent c))
    507                 (null (component-parent dep-c))
    508                 (not (eql c dep-c)))
    509            (when (eql force-p t)
    510              (setf (getf args :force) nil))
    511            (apply #'make-instance dep-o
    512                   :parent o
    513                   :original-initargs args args))
    514           ((subtypep (type-of o) dep-o)
    515            o)
    516           (t
    517            (apply #'make-instance dep-o
    518                   :parent o :original-initargs args args)))))
    519 
     573                (null (component-parent dep-c))
     574                (not (eql c dep-c)))
     575           (when (eql force-p t)
     576             (setf (getf args :force) nil))
     577           (apply #'make-instance dep-o
     578                  :parent o
     579                  :original-initargs args args))
     580          ((subtypep (type-of o) dep-o)
     581           o)
     582          (t
     583           (apply #'make-instance dep-o
     584                  :parent o :original-initargs args args)))))
     585
     586
     587(defgeneric component-visited-p (operation component))
    520588
    521589(defgeneric visit-component (operation component data))
     
    524592  (unless (component-visited-p o c)
    525593    (push (cons (node-for o c) data)
    526           (operation-visited-nodes (operation-ancestor o)))))
    527 
    528 (defgeneric component-visited-p (operation component))
     594          (operation-visited-nodes (operation-ancestor o)))))
    529595
    530596(defmethod component-visited-p ((o operation) (c component))
    531597  (assoc (node-for o c)
    532         (operation-visited-nodes (operation-ancestor o))
    533         :test 'equal))
     598        (operation-visited-nodes (operation-ancestor o))
     599        :test 'equal))
    534600
    535601(defgeneric (setf visiting-component) (new-value operation component))
     
    541607(defmethod (setf visiting-component) (new-value (o operation) (c component))
    542608  (let ((node (node-for o c))
    543         (a (operation-ancestor o)))
     609        (a (operation-ancestor o)))
    544610    (if new-value
    545         (pushnew node (operation-visiting-nodes a) :test 'equal)
    546         (setf (operation-visiting-nodes a)
    547               (remove node  (operation-visiting-nodes a) :test 'equal)))))
     611        (pushnew node (operation-visiting-nodes a) :test 'equal)
     612        (setf (operation-visiting-nodes a)
     613              (remove node  (operation-visiting-nodes a) :test 'equal)))))
    548614
    549615(defgeneric component-visiting-p (operation component))
    550616
    551617(defmethod component-visiting-p ((o operation) (c component))
    552   (let ((node (cons o c)))
     618  (let ((node (node-for o c)))
    553619    (member node (operation-visiting-nodes (operation-ancestor o))
    554             :test 'equal)))
    555 
    556 (defgeneric component-depends-on (operation component))
     620            :test 'equal)))
     621
     622(defgeneric component-depends-on (operation component)
     623  (:documentation
     624   "Returns a list of dependencies needed by the component to perform
     625    the operation.  A dependency has one of the following forms:
     626
     627      (<operation> <component>*), where <operation> is a class
     628        designator and each <component> is a component
     629        designator, which means that the component depends on
     630        <operation> having been performed on each <component>; or
     631
     632      (FEATURE <feature>), which means that the component depends
     633        on <feature>'s presence in *FEATURES*.
     634
     635    Methods specialized on subclasses of existing component types
     636    should usually append the results of CALL-NEXT-METHOD to the
     637    list."))
     638
     639(defmethod component-depends-on ((op-spec symbol) (c component))
     640  (component-depends-on (make-instance op-spec) c))
    557641
    558642(defmethod component-depends-on ((o operation) (c component))
    559643  (cdr (assoc (class-name (class-of o))
    560               (slot-value c 'in-order-to))))
     644              (slot-value c 'in-order-to))))
    561645
    562646(defgeneric component-self-dependencies (operation component))
     
    565649  (let ((all-deps (component-depends-on o c)))
    566650    (remove-if-not (lambda (x)
    567                      (member (component-name c) (cdr x) :test #'string=))
    568                    all-deps)))
    569    
     651                     (member (component-name c) (cdr x) :test #'string=))
     652                   all-deps)))
     653
    570654(defmethod input-files ((operation operation) (c component))
    571655  (let ((parent (component-parent c))
    572         (self-deps (component-self-dependencies operation c)))
     656        (self-deps (component-self-dependencies operation c)))
    573657    (if self-deps
    574         (mapcan (lambda (dep)
    575                   (destructuring-bind (op name) dep
    576                     (output-files (make-instance op)
    577                                   (find-component parent name))))
    578                 self-deps)
    579         ;; no previous operations needed?  I guess we work with the
    580         ;; original source file, then
    581         (list (component-pathname c)))))
     658        (mapcan (lambda (dep)
     659                  (destructuring-bind (op name) dep
     660                    (output-files (make-instance op)
     661                                  (find-component parent name))))
     662                self-deps)
     663        ;; no previous operations needed?  I guess we work with the
     664        ;; original source file, then
     665        (list (component-pathname c)))))
    582666
    583667(defmethod input-files ((operation operation) (c module)) nil)
     
    593677             (cond
    594678               (date)
    595                (t 
     679               (t
    596680                (warn "~@<Missing FILE-WRITE-DATE for ~S: treating ~
    597                        operation ~S on component ~S as done.~@:>" 
     681                       operation ~S on component ~S as done.~@:>"
    598682                      file o c)
    599683                (return-from operation-done-p t))))))
     
    602686      (cond ((and (not in-files) (not out-files))
    603687             ;; arbitrary decision: an operation that uses nothing to
    604              ;; produce nothing probably isn't doing much 
     688             ;; produce nothing probably isn't doing much
    605689             t)
    606             ((not out-files) 
     690            ((not out-files)
    607691             (let ((op-done
    608692                    (gethash (type-of o)
     
    629713  (let ((forced nil))
    630714    (labels ((do-one-dep (required-op required-c required-v)
    631                (let* ((dep-c (or (find-component
    632                                   (component-parent c)
    633                                   ;; XXX tacky.  really we should build the
    634                                   ;; in-order-to slot with canonicalized
    635                                   ;; names instead of coercing this late
    636                                   (coerce-name required-c) required-v)
    637                                  (error 'missing-dependency :required-by c
    638                                         :version required-v
    639                                         :requires required-c)))
    640                       (op (make-sub-operation c operation dep-c required-op)))
    641                  (traverse op dep-c)))             
    642              (do-dep (op dep)
    643                (cond ((eq op 'feature)
    644                       (or (member (car dep) *features*)
    645                           (error 'missing-dependency :required-by c
    646                                  :requires (car dep) :version nil)))
    647                      (t
    648                       (dolist (d dep)
     715               (let* ((dep-c (or (find-component
     716                                  (component-parent c)
     717                                  ;; XXX tacky.  really we should build the
     718                                  ;; in-order-to slot with canonicalized
     719                                  ;; names instead of coercing this late
     720                                  (coerce-name required-c) required-v)
     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))))
     729                      (op (make-sub-operation c operation dep-c required-op)))
     730                 (traverse op dep-c)))
     731             (do-dep (op dep)
     732               (cond ((eq op 'feature)
     733                      (or (member (car dep) *features*)
     734                          (error 'missing-dependency
     735                                 :required-by c
     736                                 :requires (car dep))))
     737                     (t
     738                      (dolist (d dep)
    649739                        (cond ((consp d)
    650740                               (assert (string-equal
     
    652742                                        "VERSION"))
    653743                               (appendf forced
    654                                         (do-one-dep op (second d) (third d))))
     744                                        (do-one-dep op (second d) (third d))))
    655745                              (t
    656746                               (appendf forced (do-one-dep op d nil)))))))))
    657747      (aif (component-visited-p operation c)
    658            (return-from traverse
    659              (if (cdr it) (list (cons 'pruned-op c)) nil)))
     748           (return-from traverse
     749             (if (cdr it) (list (cons 'pruned-op c)) nil)))
    660750      ;; dependencies
    661751      (if (component-visiting-p operation c)
    662           (error 'circular-dependency :components (list c)))
     752          (error 'circular-dependency :components (list c)))
    663753      (setf (visiting-component operation c) t)
    664       (loop for (required-op . deps) in (component-depends-on operation c)
    665             do (do-dep required-op deps))
    666       ;; constituent bits
    667       (let ((module-ops
    668              (when (typep c 'module)
    669                (let ((at-least-one nil)
    670                      (forced nil)
    671                      (error nil))
    672                  (loop for kid in (module-components c)
    673                        do (handler-case
    674                               (appendf forced (traverse operation kid ))
    675                             (missing-dependency (condition)
    676                               (if (eq (module-if-component-dep-fails c) :fail)
    677                                   (error condition))
    678                               (setf error condition))
    679                             (:no-error (c)
    680                               (declare (ignore c))
    681                               (setf at-least-one t))))
    682                  (when (and (eq (module-if-component-dep-fails c) :try-next)
    683                             (not at-least-one))
    684                    (error error))
    685                  forced))))
    686         ;; now the thing itself
    687         (when (or forced module-ops
    688                   (not (operation-done-p operation c))
    689                   (let ((f (operation-forced (operation-ancestor operation))))
    690                     (and f (or (not (consp f))
    691                                (member (component-name
    692                                         (operation-ancestor operation))
    693                                        (mapcar #'coerce-name f)
    694                                        :test #'string=)))))
    695           (let ((do-first (cdr (assoc (class-name (class-of operation))
    696                                       (slot-value c 'do-first)))))
    697             (loop for (required-op . deps) in do-first
    698                   do (do-dep required-op deps)))
    699           (setf forced (append (delete 'pruned-op forced :key #'car)
    700                                (delete 'pruned-op module-ops :key #'car)
    701                                (list (cons operation c))))))
    702       (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))
    703799      (visit-component operation c (and forced t))
    704800      forced)))
    705  
     801
    706802
    707803(defmethod perform ((operation operation) (c source-file))
     
    722818  ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
    723819   (on-warnings :initarg :on-warnings :accessor operation-on-warnings
    724                 :initform *compile-file-warnings-behaviour*)
     820                :initform *compile-file-warnings-behaviour*)
    725821   (on-failure :initarg :on-failure :accessor operation-on-failure
    726                :initform *compile-file-failure-behaviour*)))
     822               :initform *compile-file-failure-behaviour*)))
    727823
    728824(defmethod perform :before ((operation compile-op) (c source-file))
     
    731827(defmethod perform :after ((operation operation) (c component))
    732828  (setf (gethash (type-of operation) (component-operation-times c))
    733         (get-universal-time)))
     829        (get-universal-time)))
    734830
    735831;;; perform is required to check output-files to find out where to put
     
    738834  #-:broken-fasl-loader
    739835  (let ((source-file (component-pathname c))
    740         (output-file (car (output-files operation c))))
     836        (output-file (car (output-files operation c))))
    741837    (multiple-value-bind (output warnings-p failure-p)
    742         (compile-file source-file
    743                       :output-file output-file)
    744       ;(declare (ignore output))
     838        (compile-file source-file :output-file output-file)
    745839      (when warnings-p
    746         (case (operation-on-warnings operation)
    747           (:warn (warn
    748                   "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
    749                   operation c))
    750           (:error (error 'compile-warned :component c :operation operation))
    751           (:ignore nil)))
     840        (case (operation-on-warnings operation)
     841          (:warn (warn
     842                  "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>"
     843                  operation c))
     844          (:error (error 'compile-warned :component c :operation operation))
     845          (:ignore nil)))
    752846      (when failure-p
    753         (case (operation-on-failure operation)
    754           (:warn (warn
    755                   "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
    756                   operation c))
    757           (:error (error 'compile-failed :component c :operation operation))
    758           (:ignore nil)))
     847        (case (operation-on-failure operation)
     848          (:warn (warn
     849                  "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>"
     850                  operation c))
     851          (:error (error 'compile-failed :component c :operation operation))
     852          (:ignore nil)))
    759853      (unless output
    760         (error 'compile-error :component c :operation operation)))))
     854        (error 'compile-error :component c :operation operation)))))
    761855
    762856(defmethod output-files ((operation compile-op) (c cl-source-file))
     
    770864  nil)
    771865
     866(defmethod input-files ((op compile-op) (c static-file))
     867  nil)
     868
     869
    772870;;; load-op
    773871
    774 (defclass load-op (operation) ())
     872(defclass basic-load-op (operation) ())
     873
     874(defclass load-op (basic-load-op) ())
    775875
    776876(defmethod perform ((o load-op) (c cl-source-file))
    777877  (mapcar #'load (input-files o c)))
    778878
     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
    779919(defmethod perform ((operation load-op) (c static-file))
    780920  nil)
     921
    781922(defmethod operation-done-p ((operation load-op) (c static-file))
    782923  t)
     
    791932;;; load-source-op
    792933
    793 (defclass load-source-op (operation) ())
     934(defclass load-source-op (basic-load-op) ())
    794935
    795936(defmethod perform ((o load-source-op) (c cl-source-file))
     
    817958(defmethod operation-done-p ((o load-source-op) (c source-file))
    818959  (if (or (not (component-property c 'last-loaded-as-source))
    819           (> (file-write-date (component-pathname c))
    820              (component-property c 'last-loaded-as-source)))
     960          (> (file-write-date (component-pathname c))
     961             (component-property c 'last-loaded-as-source)))
    821962      nil t))
    822963
     
    826967  nil)
    827968
     969(defmethod operation-done-p ((operation test-op) (c system))
     970  "Testing a system is _never_ done."
     971  nil)
     972
    828973;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    829974;;; invoking operations
    830975
    831 (defun operate (operation-class system &rest args &key (verbose t) version
    832                                 &allow-other-keys)
     976(defvar *operate-docstring*
     977  "Operate does three things:
     978
     9791. It creates an instance of `operation-class` using any keyword parameters
     980as initargs.
     9812. It finds the  asdf-system specified by `system` (possibly loading
     982it from disk).
     9833. It then calls `traverse` with the operation and system as arguments
     984
     985The traverse operation is wrapped in `with-compilation-unit` and error
     986handling code. If a `version` argument is supplied, then operate also
     987ensures that the system found satisfies it using the `version-satisfies`
     988method.")
     989
     990(defun operate (operation-class system &rest args &key (verbose t) version
     991                &allow-other-keys)
    833992  (let* ((op (apply #'make-instance operation-class
    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))))
     993                    :original-initargs args
     994                    args))
     995         (*verbose-out* (if verbose *standard-output* (make-broadcast-stream)))
     996        (system (if (typep system 'component) system (find-system system))))
    838997    (unless (version-satisfies system version)
    839       (error 'missing-component :requires system :version version))
     998      (error 'missing-component-of-version :requires system :version version))
    840999    (let ((steps (traverse op system)))
    8411000      (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)))))))))
    863 
    864 (defun oos (&rest args)
    865   "Alias of OPERATE function"
    866   (apply #'operate args))
     1001        (loop for (op . component) in steps do
     1002                 (loop
     1003                   (restart-case
     1004                       (progn (perform op component)
     1005                              (return))
     1006                     (retry ()
     1007                       :report
     1008                       (lambda (s)
     1009                         (format s "~@<Retry performing ~S on ~S.~@:>"
     1010                                 op component)))
     1011                     (accept ()
     1012                       :report
     1013                       (lambda (s)
     1014                         (format s "~@<Continue, treating ~S on ~S as ~
     1015                                   having been successful.~@:>"
     1016                                 op component))
     1017                       (setf (gethash (type-of op)
     1018                                      (component-operation-times component))
     1019                             (get-universal-time))
     1020                       (return)))))))))
     1021
     1022(setf (documentation 'operate 'function)
     1023      *operate-docstring*)
     1024
     1025(defun oos (operation-class system &rest args &key force (verbose t) version)
     1026  (declare (ignore force verbose version))
     1027  (apply #'operate operation-class system args))
     1028
     1029(setf (documentation 'oos 'function)
     1030      (format nil
     1031              "Short for _operate on system_ and an alias for the `operate` function. ~&~&~a"
     1032              *operate-docstring*))
    8671033
    8681034;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     
    8711037(defun remove-keyword (key arglist)
    8721038  (labels ((aux (key arglist)
    873              (cond ((null arglist) nil)
    874                    ((eq key (car arglist)) (cddr arglist))
    875                    (t (cons (car arglist) (cons (cadr arglist)
    876                                                 (remove-keyword
    877                                                 key (cddr arglist))))))))
     1039             (cond ((null arglist) nil)
     1040                   ((eq key (car arglist)) (cddr arglist))
     1041                   (t (cons (car arglist) (cons (cadr arglist)
     1042                                                (remove-keyword
     1043                                                key (cddr arglist))))))))
    8781044    (aux key arglist)))
    8791045
    8801046(defmacro defsystem (name &body options)
    881   (destructuring-bind (&key pathname (class 'system) &allow-other-keys) options
     1047  (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
     1048                            &allow-other-keys)
     1049      options
    8821050    (let ((component-options (remove-keyword :class options)))
    8831051      `(progn
    884         ;; system must be registered before we parse the body, otherwise
    885         ;; we recur when trying to find an existing system of the same name
    886         ;; to reuse options (e.g. pathname) from
    887         (let ((s (system-registered-p ',name)))
    888           (cond ((and s (eq (type-of (cdr s)) ',class))
    889                  (setf (car s) (get-universal-time)))
    890                 (s
    891                  #+clisp
    892                  (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
    893                  #-clisp
    894                  (change-class (cdr s) ',class))
    895                 (t
    896                  (register-system (quote ,name)
    897                                   (make-instance ',class :name ',name)))))
    898         (parse-component-form nil (apply
    899                                    #'list
    900                                    :module (coerce-name ',name)
    901                                    :pathname
    902                                    (or ,pathname
    903                                        (pathname-sans-name+type
    904                                         (resolve-symlinks  *load-truename*))
    905                                        *default-pathname-defaults*)
    906                                    ',component-options))))))
    907  
     1052         ;; system must be registered before we parse the body, otherwise
     1053         ;; we recur when trying to find an existing system of the same name
     1054         ;; to reuse options (e.g. pathname) from
     1055         (let ((s (system-registered-p ',name)))
     1056           (cond ((and s (eq (type-of (cdr s)) ',class))
     1057                  (setf (car s) (get-universal-time)))
     1058                 (s
     1059                  #+clisp
     1060                  (sysdef-error "Cannot redefine the existing system ~A with a different class" s)
     1061                  #-clisp
     1062                  (change-class (cdr s) ',class))
     1063                 (t
     1064                  (register-system (quote ,name)
     1065                                   (make-instance ',class :name ',name)))))
     1066         (parse-component-form nil (apply
     1067                                    #'list
     1068                                    :module (coerce-name ',name)
     1069                                    :pathname
     1070                                    ;; to avoid a note about unreachable code
     1071                                    ,(if pathname-arg-p
     1072                                         pathname
     1073                                         `(or (when *load-truename*
     1074                                                (pathname-sans-name+type
     1075                                                 (resolve-symlinks
     1076                                                  *load-truename*)))
     1077                                              *default-pathname-defaults*))
     1078                                    ',component-options))))))
     1079
    9081080
    9091081(defun class-for-type (parent type)
    910   (let ((class
    911          (find-class
    912           (or (find-symbol (symbol-name type) *package*)
    913               (find-symbol (symbol-name type) #.(package-name *package*)))
    914           nil)))
     1082  (let* ((extra-symbols (list (find-symbol (symbol-name type) *package*)
     1083                              (find-symbol (symbol-name type)
     1084                                           (load-time-value
     1085                                            (package-name :asdf)))))
     1086         (class (dolist (symbol (if (keywordp type)
     1087                                    extra-symbols
     1088                                    (cons type extra-symbols)))
     1089                  (when (and symbol
     1090                             (find-class symbol nil)
     1091                             (subtypep symbol 'component))
     1092                    (return (find-class symbol))))))
    9151093    (or class
    916         (and (eq type :file)
    917              (or (module-default-component-class parent)
    918                 (find-class 'cl-source-file)))
    919         (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
     1094        (and (eq type :file)
     1095             (or (module-default-component-class parent)
     1096                (find-class 'cl-source-file)))
     1097        (sysdef-error "~@<don't recognize component type ~A~@:>" type))))
    9201098
    9211099(defun maybe-add-tree (tree op1 op2 c)
     
    9241102  (let ((first-op-tree (assoc op1 tree)))
    9251103    (if first-op-tree
    926         (progn
    927           (aif (assoc op2 (cdr first-op-tree))
    928                (if (find c (cdr it))
    929                    nil
    930                    (setf (cdr it) (cons c (cdr it))))
    931                (setf (cdr first-op-tree)
    932                      (acons op2 (list c) (cdr first-op-tree))))
    933           tree)
    934         (acons op1 (list (list op2 c)) tree))))
    935                
     1104        (progn
     1105          (aif (assoc op2 (cdr first-op-tree))
     1106               (if (find c (cdr it))
     1107                   nil
     1108                   (setf (cdr it) (cons c (cdr it))))
     1109               (setf (cdr first-op-tree)
     1110                     (acons op2 (list c) (cdr first-op-tree))))
     1111          tree)
     1112        (acons op1 (list (list op2 c)) tree))))
     1113
    9361114(defun union-of-dependencies (&rest deps)
    9371115  (let ((new-tree nil))
    9381116    (dolist (dep deps)
    9391117      (dolist (op-tree dep)
    940         (dolist (op  (cdr op-tree))
    941           (dolist (c (cdr op))
    942             (setf new-tree
    943                   (maybe-add-tree new-tree (car op-tree) (car op) c))))))
     1118        (dolist (op  (cdr op-tree))
     1119          (dolist (c (cdr op))
     1120            (setf new-tree
     1121                  (maybe-add-tree new-tree (car op-tree) (car op) c))))))
    9441122    new-tree))
    9451123
     
    9471125(defun remove-keys (key-names args)
    9481126  (loop for ( name val ) on args by #'cddr
    949         unless (member (symbol-name name) key-names
    950                        :key #'symbol-name :test 'equal)
    951         append (list name val)))
     1127        unless (member (symbol-name name) key-names
     1128                       :key #'symbol-name :test 'equal)
     1129        append (list name val)))
    9521130
    9531131(defvar *serial-depends-on*)
    9541132
    9551133(defun parse-component-form (parent options)
     1134
    9561135  (destructuring-bind
    957         (type name &rest rest &key
    958               ;; the following list of keywords is reproduced below in the
    959               ;; remove-keys form.  important to keep them in sync
    960               components pathname default-component-class
    961               perform explain output-files operation-done-p
    962               weakly-depends-on
    963               depends-on serial in-order-to
    964               ;; list ends
    965               &allow-other-keys) options
     1136        (type name &rest rest &key
     1137              ;; the following list of keywords is reproduced below in the
     1138              ;; remove-keys form.  important to keep them in sync
     1139              components pathname default-component-class
     1140              perform explain output-files operation-done-p
     1141              weakly-depends-on
     1142              depends-on serial in-order-to
     1143              ;; list ends
     1144              &allow-other-keys) options
     1145    (declare (ignorable perform explain output-files operation-done-p))
    9661146    (check-component-input type name weakly-depends-on depends-on components in-order-to)
    9671147
    9681148    (when (and parent
    969              (find-component parent name)
    970              ;; ignore the same object when rereading the defsystem
    971              (not
    972               (typep (find-component parent name)
    973                      (class-for-type parent type))))         
     1149               (find-component parent name)
     1150               ;; ignore the same object when rereading the defsystem
     1151               (not
     1152                (typep (find-component parent name)
     1153                       (class-for-type parent type))))
    9741154      (error 'duplicate-names :name name))
    975    
     1155
    9761156    (let* ((other-args (remove-keys
    977                         '(components pathname default-component-class
    978                           perform explain output-files operation-done-p
    979                           weakly-depends-on
    980                           depends-on serial in-order-to)
    981                         rest))
    982            (ret
    983             (or (find-component parent name)
    984                 (make-instance (class-for-type parent type)))))
     1157                        '(components pathname default-component-class
     1158                          perform explain output-files operation-done-p
     1159                          weakly-depends-on
     1160                          depends-on serial in-order-to)
     1161                        rest))
     1162           (ret
     1163            (or (find-component parent name)
     1164                (make-instance (class-for-type parent type)))))
    9851165      (when weakly-depends-on
    986         (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
     1166        (setf depends-on (append depends-on (remove-if (complement #'find-system) weakly-depends-on))))
    9871167      (when (boundp '*serial-depends-on*)
    988         (setf depends-on
    989               (concatenate 'list *serial-depends-on* depends-on)))     
    990       (apply #'reinitialize-instance
    991              ret
    992              :name (coerce-name name)
    993              :pathname pathname
    994              :parent parent
    995              other-args)
     1168        (setf depends-on
     1169              (concatenate 'list *serial-depends-on* depends-on)))
     1170      (apply #'reinitialize-instance ret
     1171             :name (coerce-name name)
     1172             :pathname pathname
     1173             :parent parent
     1174             other-args)
    9961175      (when (typep ret 'module)
    997         (setf (module-default-component-class ret)
    998               (or default-component-class
    999                   (and (typep parent 'module)
    1000                        (module-default-component-class parent))))
    1001         (let ((*serial-depends-on* nil))
    1002           (setf (module-components ret)
    1003                 (loop for c-form in components
    1004                       for c = (parse-component-form ret c-form)
    1005                       collect c
    1006                       if serial
    1007                       do (push (component-name c) *serial-depends-on*))))
    1008 
    1009         ;; check for duplicate names
    1010         (let ((name-hash (make-hash-table :test #'equal)))
    1011           (loop for c in (module-components ret)
    1012                 do
    1013                 (if (gethash (component-name c)
    1014                              name-hash)
    1015                     (error 'duplicate-names
    1016                            :name (component-name c))
    1017                   (setf (gethash (component-name c)
    1018                                 name-hash)
    1019                         t)))))
    1020      
     1176        (setf (module-default-component-class ret)
     1177              (or default-component-class
     1178                  (and (typep parent 'module)
     1179                       (module-default-component-class parent))))
     1180        (let ((*serial-depends-on* nil))
     1181          (setf (module-components ret)
     1182                (loop for c-form in components
     1183                      for c = (parse-component-form ret c-form)
     1184                      collect c
     1185                      if serial
     1186                      do (push (component-name c) *serial-depends-on*))))
     1187
     1188        ;; check for duplicate names
     1189        (let ((name-hash (make-hash-table :test #'equal)))
     1190          (loop for c in (module-components ret)
     1191                do
     1192                (if (gethash (component-name c)
     1193                             name-hash)
     1194                    (error 'duplicate-names
     1195                           :name (component-name c))
     1196                    (setf (gethash (component-name c)
     1197                                  name-hash)
     1198                          t)))))
     1199
    10211200      (setf (slot-value ret 'in-order-to)
    1022             (union-of-dependencies
    1023              in-order-to
    1024              `((compile-op (compile-op ,@depends-on))
    1025                (load-op (load-op ,@depends-on))))
    1026             (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
    1027      
    1028       (loop for (n v) in `((perform ,perform) (explain ,explain)
    1029                            (output-files ,output-files)
    1030                            (operation-done-p ,operation-done-p))
    1031             do (map 'nil
    1032                     ;; this is inefficient as most of the stored
    1033                     ;; methods will not be for this particular gf n
    1034                     ;; But this is hardly performance-critical
    1035                     (lambda (m) (remove-method (symbol-function n) m))
    1036                     (component-inline-methods ret))
    1037             when v
    1038             do (destructuring-bind (op qual (o c) &body body) v
    1039                  (pushnew
    1040                   (eval `(defmethod ,n ,qual ((,o ,op) (,c (eql ,ret)))
    1041                           ,@body))
    1042                   (component-inline-methods ret))))
     1201            (union-of-dependencies
     1202             in-order-to
     1203             `((compile-op (compile-op ,@depends-on))
     1204               (load-op (load-op ,@depends-on))))
     1205            (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
     1206
     1207      (%remove-component-inline-methods ret rest)
     1208
    10431209      ret)))
     1210
     1211(defun %remove-component-inline-methods (ret rest)
     1212  (loop for name in +asdf-methods+
     1213        do (map 'nil
     1214                ;; this is inefficient as most of the stored
     1215                ;; methods will not be for this particular gf n
     1216                ;; But this is hardly performance-critical
     1217                (lambda (m)
     1218                  (remove-method (symbol-function name) m))
     1219                (component-inline-methods ret)))
     1220  ;; clear methods, then add the new ones
     1221  (setf (component-inline-methods ret) nil)
     1222  (loop for name in +asdf-methods+
     1223        for v = (getf rest (intern (symbol-name name) :keyword))
     1224        when v do
     1225        (destructuring-bind (op qual (o c) &body body) v
     1226          (pushnew
     1227           (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
     1228                             ,@body))
     1229           (component-inline-methods ret)))))
    10441230
    10451231(defun check-component-input (type name weakly-depends-on depends-on components in-order-to)
     
    10481234  (unless (listp depends-on)
    10491235    (sysdef-error-component ":depends-on must be a list."
    1050                             type name depends-on))
     1236                            type name depends-on))
    10511237  (unless (listp weakly-depends-on)
    10521238    (sysdef-error-component ":weakly-depends-on must be a list."
    1053                             type name weakly-depends-on))
     1239                            type name weakly-depends-on))
    10541240  (unless (listp components)
    10551241    (sysdef-error-component ":components must be NIL or a list of components."
    1056                             type name components))
     1242                            type name components))
    10571243  (unless (and (listp in-order-to) (listp (car in-order-to)))
    10581244    (sysdef-error-component ":in-order-to must be NIL or a list of components."
    1059                            type name in-order-to)))
     1245                            type name in-order-to)))
    10601246
    10611247(defun sysdef-error-component (msg type name value)
    10621248  (sysdef-error (concatenate 'string msg
    1063                              "~&The value specified for ~(~A~) ~A is ~W")
    1064                 type name value))
     1249                             "~&The value specified for ~(~A~) ~A is ~W")
     1250                type name value))
    10651251
    10661252(defun resolve-symlinks (path)
     
    10831269    #+sbcl
    10841270    (sb-ext:process-exit-code
    1085      (sb-ext:run-program 
     1271     (sb-ext:run-program
    10861272      #+win32 "sh" #-win32 "/bin/sh"
    10871273      (list  "-c" command)
    10881274      #+win32 #+win32 :search t
    10891275      :input nil :output *verbose-out*))
    1090    
     1276
    10911277    #+(or cmu scl)
    10921278    (ext:process-exit-code
    1093      (ext:run-program 
     1279     (ext:run-program
    10941280      "/bin/sh"
    10951281      (list  "-c" command)
     
    10981284    #+allegro
    10991285    (excl:run-shell-command command :input nil :output *verbose-out*)
    1100    
     1286
    11011287    #+lispworks
    11021288    (system:call-system-showing-output
     
    11041290     :shell-type "/bin/sh"
    11051291     :output-stream *verbose-out*)
    1106    
    1107     #+clisp                             ;XXX not exactly *verbose-out*, I know
     1292
     1293    #+clisp                     ;XXX not exactly *verbose-out*, I know
    11081294    (ext:run-shell-command  command :output :terminal :wait t)
    11091295
    11101296    #+openmcl
    11111297    (nth-value 1
    1112                (ccl:external-process-status
    1113                 (ccl:run-program "/bin/sh" (list "-c" command)
    1114                                 :input nil :output *verbose-out*
    1115                                 :wait t)))
     1298               (ccl:external-process-status
     1299                (ccl:run-program "/bin/sh" (list "-c" command)
     1300                                :input nil :output *verbose-out*
     1301                                :wait t)))
    11161302    #+ecl ;; courtesy of Juan Jose Garcia Ripoll
    11171303    (si:system command)
     
    11201306    ))
    11211307
    1122 
    1123 (defgeneric hyperdocumentation (package name doc-type))
    1124 (defmethod hyperdocumentation ((package symbol) name doc-type)
    1125   (hyperdocumentation (find-package package) name doc-type))
    1126 
    1127 (defun hyperdoc (name doc-type)
    1128   (hyperdocumentation (symbol-package name) name doc-type))
    1129 
     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 
     1323(defun system-source-directory (system-name)
     1324  (make-pathname :name nil
     1325                 :type nil
     1326                 :defaults (system-source-file system-name)))
     1327
     1328(defun system-relative-pathname (system pathname &key name type)
     1329  ;; you're not allowed to muck with the return value of pathname-X
     1330  (let ((directory (copy-list (pathname-directory pathname))))
     1331    (when (eq (car directory) :absolute)
     1332      (setf (car directory) :relative))
     1333    (merge-pathnames
     1334     (make-pathname :name (or name (pathname-name pathname))
     1335                    :type (or type (pathname-type pathname))
     1336                    :directory directory)
     1337     (system-source-directory system))))
    11301338
    11311339(pushnew :asdf *features*)
     
    11411349    (handler-bind ((style-warning #'muffle-warning))
    11421350      (let* ((*verbose-out* (make-broadcast-stream))
    1143              (system (asdf:find-system name nil)))
    1144         (when system
    1145           (asdf:operate 'asdf:load-op name)
    1146           t))))
     1351             (system (asdf:find-system name nil)))
     1352        (when system
     1353          (asdf:operate 'asdf:load-op name)
     1354          t))))
    11471355
    11481356  (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)))
    1159  
     1357    (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
     1358      (when (and home (not (string= home "")))
     1359        (let* ((name (coerce-name system))
     1360               (home (truename home))
     1361               (contrib (merge-pathnames
     1362                         (make-pathname :directory `(:relative ,name)
     1363                                        :name name
     1364                                        :type "asd"
     1365                                        :case :local
     1366                                        :version :newest)
     1367                         home)))
     1368          (probe-file contrib)))))
     1369
    11601370  (pushnew
    1161    '(merge-pathnames "site-systems/"
    1162      (truename (sb-ext:posix-getenv "SBCL_HOME")))
     1371   '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
     1372      (when (and home (not (string= home "")))
     1373        (merge-pathnames "site-systems/" (truename home))))
    11631374   *central-registry*)
    1164  
     1375
    11651376  (pushnew
    11661377   '(merge-pathnames ".sbcl/systems/"
    11671378     (user-homedir-pathname))
    11681379   *central-registry*)
    1169  
     1380
    11701381  (pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
    11711382  (pushnew 'contrib-sysdef-search *system-definition-search-functions*))
Note: See TracChangeset for help on using the changeset viewer.