Ignore:
Timestamp:
Feb 2, 2013, 1:34:47 AM (7 years ago)
Author:
rme
Message:

Merge ASDF 2.28 from trunk.

Location:
release/1.9/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/1.9/source

  • release/1.9/source/tools/asdf.lisp

    r15496 r15634  
    1 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
    2 ;;; This is ASDF 2.26: Another System Definition Facility.
     1;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
     2;;; This is ASDF 2.28: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    4848#+xcvb (module ())
    4949
    50 (cl:in-package :common-lisp-user)
    51 #+genera (in-package :future-common-lisp-user)
     50(in-package :cl-user)
     51
     52#+cmu
     53(eval-when (:load-toplevel :compile-toplevel :execute)
     54  (declaim (optimize (speed 1) (safety 3) (debug 3)))
     55  (setf ext:*gc-verbose* nil))
     56
     57#+(or abcl clisp cmu ecl xcl)
     58(eval-when (:load-toplevel :compile-toplevel :execute)
     59  (unless (member :asdf3 *features*)
     60    (let* ((existing-version
     61             (when (find-package :asdf)
     62               (or (symbol-value (find-symbol (string :*asdf-version*) :asdf))
     63                   (let ((ver (symbol-value (find-symbol (string :*asdf-revision*) :asdf))))
     64                     (etypecase ver
     65                       (string ver)
     66                       (cons (format nil "~{~D~^.~}" ver))
     67                       (null "1.0"))))))
     68           (first-dot (when existing-version (position #\. existing-version)))
     69           (second-dot (when first-dot (position #\. existing-version :start (1+ first-dot))))
     70           (existing-major-minor (subseq existing-version 0 second-dot))
     71           (existing-version-number (and existing-version (read-from-string existing-major-minor)))
     72           (away (format nil "~A-~A" :asdf existing-version)))
     73      (when (and existing-version (< existing-version-number
     74                                     #+abcl 2.25 #+clisp 2.27 #+cmu 2.018 #+ecl 2.21 #+xcl 2.27))
     75        (rename-package :asdf away)
     76        (when *load-verbose*
     77          (format t "; First thing, renamed package ~A away to ~A~%" :asdf away))))))
     78
     79;;;; ---------------------------------------------------------------------------
     80;;;; Handle ASDF package upgrade, including implementation-dependent magic.
     81;;
     82;; See https://bugs.launchpad.net/asdf/+bug/485687
     83;;
     84;; CAUTION: we must handle the first few packages specially for hot-upgrade.
     85;; asdf/package will be frozen as of ASDF 3
     86;; to forever export the same exact symbols.
     87;; Any other symbol must be import-from'ed
     88;; and reexported in a different package
     89;; (alternatively the package may be dropped & replaced by one with a new name).
     90
     91(defpackage :asdf/package
     92  (:use :common-lisp)
     93  (:export
     94   #:find-package* #:find-symbol* #:symbol-call
     95   #:intern* #:unintern* #:export* #:make-symbol*
     96   #:symbol-shadowing-p #:home-package-p #:rehome-symbol
     97   #:symbol-package-name #:standard-common-lisp-symbol-p
     98   #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
     99   #:nuke-symbol-in-package #:nuke-symbol
     100   #:ensure-package-unused #:delete-package*
     101   #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names
     102   #:package-definition-form #:parse-define-package-form
     103   #:ensure-package #:define-package))
     104
     105(in-package :asdf/package)
     106
     107;;;; General purpose package utilities
     108
     109(eval-when (:load-toplevel :compile-toplevel :execute)
     110  (defun find-package* (package-designator &optional (error t))
     111    (let ((package (find-package package-designator)))
     112      (cond
     113        (package package)
     114        (error (error "No package named ~S" (string package-designator)))
     115        (t nil))))
     116  (defun find-symbol* (name package-designator &optional (error t))
     117    "Find a symbol in a package of given string'ified NAME;
     118unless CL:FIND-SYMBOL, work well with 'modern' case sensitive syntax
     119by letting you supply a symbol or keyword for the name;
     120also works well when the package is not present.
     121If optional ERROR argument is NIL, return NIL instead of an error
     122when the symbol is not found."
     123    (block nil
     124      (let ((package (find-package* package-designator error)))
     125        (when package ;; package error handled by find-package* already
     126          (multiple-value-bind (symbol status) (find-symbol (string name) package)
     127            (cond
     128              (status (return (values symbol status)))
     129              (error (error "There is no symbol ~S in package ~S" name (package-name package))))))
     130        (values nil nil))))
     131  (defun symbol-call (package name &rest args)
     132    "Call a function associated with symbol of given name in given package,
     133with given ARGS. Useful when the call is read before the package is loaded,
     134or when loading the package is optional."
     135    (apply (find-symbol* name package) args))
     136  (defun intern* (name package-designator &optional (error t))
     137    (intern (string name) (find-package* package-designator error)))
     138  (defun export* (name package-designator)
     139    (let* ((package (find-package* package-designator))
     140           (symbol (intern* name package)))
     141      (export (or symbol (list symbol)) package)))
     142  (defun make-symbol* (name)
     143    (etypecase name
     144      (string (make-symbol name))
     145      (symbol (copy-symbol name))))
     146  (defun unintern* (name package-designator &optional (error t))
     147    (block nil
     148      (let ((package (find-package* package-designator error)))
     149        (when package
     150          (multiple-value-bind (symbol status) (find-symbol* name package error)
     151            (cond
     152              (status (unintern symbol package)
     153                      (return (values symbol status)))
     154              (error (error "symbol ~A not present in package ~A"
     155                            (string symbol) (package-name package))))))
     156        (values nil nil))))
     157  (defun symbol-shadowing-p (symbol package)
     158    (and (member symbol (package-shadowing-symbols package)) t))
     159  (defun home-package-p (symbol package)
     160    (and package (let ((sp (symbol-package symbol)))
     161                   (and sp (let ((pp (find-package* package)))
     162                             (and pp (eq sp pp))))))))
     163
     164
     165(eval-when (:load-toplevel :compile-toplevel :execute)
     166  (defun symbol-package-name (symbol)
     167    (let ((package (symbol-package symbol)))
     168      (and package (package-name package))))
     169  (defun standard-common-lisp-symbol-p (symbol)
     170    (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
     171      (and (eq sym symbol) (eq status :external))))
     172  (defun reify-package (package &optional package-context)
     173    (if (eq package package-context) t
     174        (etypecase package
     175          (null nil)
     176          ((eql (find-package :cl)) :cl)
     177          (package (package-name package)))))
     178  (defun unreify-package (package &optional package-context)
     179    (etypecase package
     180      (null nil)
     181      ((eql t) package-context)
     182      ((or symbol string) (find-package package))))
     183  (defun reify-symbol (symbol &optional package-context)
     184    (etypecase symbol
     185      ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
     186      (symbol (vector (symbol-name symbol)
     187                      (reify-package (symbol-package symbol) package-context)))))
     188  (defun unreify-symbol (symbol &optional package-context)
     189    (etypecase symbol
     190      (symbol symbol)
     191      ((simple-vector 2)
     192       (let* ((symbol-name (svref symbol 0))
     193              (package-foo (svref symbol 1))
     194              (package (unreify-package package-foo package-context)))
     195         (if package (intern* symbol-name package)
     196             (make-symbol* symbol-name)))))))
     197
     198(eval-when (:load-toplevel :compile-toplevel :execute)
     199  (defvar *all-package-happiness* '())
     200  (defvar *all-package-fishiness* (list t))
     201  (defun record-fishy (info)
     202    ;;(format t "~&FISHY: ~S~%" info)
     203    (push info *all-package-fishiness*))
     204  (defmacro when-package-fishiness (&body body)
     205    `(when *all-package-fishiness* ,@body))
     206  (defmacro note-package-fishiness (&rest info)
     207    `(when-package-fishiness (record-fishy (list ,@info)))))
     208
     209(eval-when (:load-toplevel :compile-toplevel :execute)
     210  #+(or clisp clozure)
     211  (defun get-setf-function-symbol (symbol)
     212    #+clisp (let ((sym (get symbol 'system::setf-function)))
     213              (if sym (values sym :setf-function)
     214                  (let ((sym (get symbol 'system::setf-expander)))
     215                    (if sym (values sym :setf-expander)
     216                        (values nil nil)))))
     217    #+clozure (gethash symbol ccl::%setf-function-names%))
     218  #+(or clisp clozure)
     219  (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind)
     220    #+clisp (assert (member kind '(:setf-function :setf-expander)))
     221    #+clozure (assert (eq kind t))
     222    #+clisp
     223    (cond
     224      ((null new-setf-symbol)
     225       (remprop symbol 'system::setf-function)
     226       (remprop symbol 'system::setf-expander))
     227      ((eq kind :setf-function)
     228       (setf (get symbol 'system::setf-function) new-setf-symbol))
     229      ((eq kind :setf-expander)
     230       (setf (get symbol 'system::setf-expander) new-setf-symbol))
     231      (t (error "invalid kind of setf-function ~S for ~S to be set to ~S"
     232                kind symbol new-setf-symbol)))
     233    #+clozure
     234    (progn
     235      (gethash symbol ccl::%setf-function-names%) new-setf-symbol
     236      (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol))
     237  #+(or clisp clozure)
     238  (defun create-setf-function-symbol (symbol)
     239    #+clisp (system::setf-symbol symbol)
     240    #+clozure (ccl::construct-setf-function-name symbol))
     241  (defun set-dummy-symbol (symbol reason other-symbol)
     242    (setf (get symbol 'dummy-symbol) (cons reason other-symbol)))
     243  (defun make-dummy-symbol (symbol)
     244    (let ((dummy (copy-symbol symbol)))
     245      (set-dummy-symbol dummy 'replacing symbol)
     246      (set-dummy-symbol symbol 'replaced-by dummy)
     247      dummy))
     248  (defun dummy-symbol (symbol)
     249    (get symbol 'dummy-symbol))
     250  (defun get-dummy-symbol (symbol)
     251    (let ((existing (dummy-symbol symbol)))
     252      (if existing (values (cdr existing) (car existing))
     253          (make-dummy-symbol symbol))))
     254  (defun nuke-symbol-in-package (symbol package-designator)
     255    (let ((package (find-package* package-designator))
     256          (name (symbol-name symbol)))
     257      (multiple-value-bind (sym stat) (find-symbol name package)
     258        (when (and (member stat '(:internal :external)) (eq symbol sym))
     259          (if (symbol-shadowing-p symbol package)
     260              (shadowing-import (get-dummy-symbol symbol) package)
     261              (unintern symbol package))))))
     262  (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
     263    #+(or clisp clozure)
     264    (multiple-value-bind (setf-symbol kind)
     265        (get-setf-function-symbol symbol)
     266      (when kind (nuke-symbol setf-symbol)))
     267    (loop :for p :in packages :do (nuke-symbol-in-package symbol p)))
     268  (defun rehome-symbol (symbol package-designator)
     269    "Changes the home package of a symbol, also leaving it present in its old home if any"
     270    (let* ((name (symbol-name symbol))
     271           (package (find-package* package-designator))
     272           (old-package (symbol-package symbol))
     273           (old-status (and old-package (nth-value 1 (find-symbol name old-package))))
     274           (shadowing (and old-package (symbol-shadowing-p symbol old-package) (make-symbol name))))
     275      (multiple-value-bind (overwritten-symbol overwritten-symbol-status) (find-symbol name package)
     276        (unless (eq package old-package)
     277          (let ((overwritten-symbol-shadowing-p
     278                  (and overwritten-symbol-status
     279                       (symbol-shadowing-p overwritten-symbol package))))
     280            (note-package-fishiness
     281             :rehome-symbol name
     282             (when old-package (package-name old-package)) old-status (and shadowing t)
     283             (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
     284            (when old-package
     285              (if shadowing
     286                  (shadowing-import shadowing old-package))
     287              (unintern symbol old-package))
     288            (cond
     289              (overwritten-symbol-shadowing-p
     290               (shadowing-import symbol package))
     291              (t
     292               (when overwritten-symbol-status
     293                 (unintern overwritten-symbol package))
     294               (import symbol package)))
     295            (if shadowing
     296                (shadowing-import symbol old-package)
     297                (import symbol old-package))
     298            #+(or clisp clozure)
     299            (multiple-value-bind (setf-symbol kind)
     300                (get-setf-function-symbol symbol)
     301              (when kind
     302                (let* ((setf-function (fdefinition setf-symbol))
     303                       (new-setf-symbol (create-setf-function-symbol symbol)))
     304                  (note-package-fishiness
     305                   :setf-function
     306                   name (package-name package)
     307                   (symbol-name setf-symbol) (symbol-package-name setf-symbol)
     308                   (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
     309                  (when (symbol-package setf-symbol)
     310                    (unintern setf-symbol (symbol-package setf-symbol)))
     311                  (setf (fdefinition new-setf-symbol) setf-function)
     312                  (set-setf-function-symbol new-setf-symbol symbol kind))))
     313            #+(or clisp clozure)
     314            (multiple-value-bind (overwritten-setf foundp)
     315                (get-setf-function-symbol overwritten-symbol)
     316              (when foundp
     317                (unintern overwritten-setf)))
     318            (when (eq old-status :external)
     319              (export* symbol old-package))
     320            (when (eq overwritten-symbol-status :external)
     321              (export* symbol package))))
     322        (values overwritten-symbol overwritten-symbol-status))))
     323  (defun ensure-package-unused (package)
     324    (loop :for p :in (package-used-by-list package) :do
     325      (unuse-package package p)))
     326  (defun delete-package* (package &key nuke)
     327    (let ((p (find-package package)))
     328      (when p
     329        (when nuke (do-symbols (s p) (when (home-package-p s p) (nuke-symbol s))))
     330        (ensure-package-unused p)
     331        (delete-package package))))
     332  (defun package-names (package)
     333    (cons (package-name package) (package-nicknames package)))
     334  (defun packages-from-names (names)
     335    (remove-duplicates (remove nil (mapcar #'find-package names)) :from-end t))
     336  (defun fresh-package-name (&key (prefix :%TO-BE-DELETED)
     337                               separator
     338                               (index (random most-positive-fixnum)))
     339    (loop :for i :from index
     340          :for n = (format nil "~A~@[~A~D~]" prefix (and (plusp i) (or separator "")) i)
     341          :thereis (and (not (find-package n)) n)))
     342  (defun rename-package-away (p &rest keys &key prefix &allow-other-keys)
     343    (let ((new-name
     344            (apply 'fresh-package-name
     345                   :prefix (or prefix (format nil "__~A__" (package-name p))) keys)))
     346      (record-fishy (list :rename-away (package-names p) new-name))
     347      (rename-package p new-name))))
     348
     349
     350;;; Communicable representation of symbol and package information
     351
     352(eval-when (:load-toplevel :compile-toplevel :execute)
     353  (defun package-definition-form (package-designator
     354                                  &key (nicknamesp t) (usep t)
     355                                    (shadowp t) (shadowing-import-p t)
     356                                    (exportp t) (importp t) internp (error t))
     357    (let* ((package (or (find-package* package-designator error)
     358                        (return-from package-definition-form nil)))
     359           (name (package-name package))
     360           (nicknames (package-nicknames package))
     361           (use (mapcar #'package-name (package-use-list package)))
     362           (shadow ())
     363           (shadowing-import (make-hash-table :test 'equal))
     364           (import (make-hash-table :test 'equal))
     365           (export ())
     366           (intern ()))
     367      (when package
     368        (loop :for sym :being :the :symbols :in package
     369              :for status = (nth-value 1 (find-symbol* sym package)) :do
     370                (ecase status
     371                  ((nil :inherited))
     372                  ((:internal :external)
     373                   (let* ((name (symbol-name sym))
     374                          (external (eq status :external))
     375                          (home (symbol-package sym))
     376                          (home-name (package-name home))
     377                          (imported (not (eq home package)))
     378                          (shadowing (symbol-shadowing-p sym package)))
     379                     (cond
     380                       ((and shadowing imported)
     381                        (push name (gethash home-name shadowing-import)))
     382                       (shadowing
     383                        (push name shadow))
     384                       (imported
     385                        (push name (gethash home-name import))))
     386                     (cond
     387                       (external
     388                        (push name export))
     389                       (imported)
     390                       (t (push name intern)))))))
     391        (labels ((sort-names (names)
     392                   (sort names #'string<))
     393                 (table-keys (table)
     394                   (loop :for k :being :the :hash-keys :of table :collect k))
     395                 (when-relevant (key value)
     396                   (when value (list (cons key value))))
     397                 (import-options (key table)
     398                   (loop :for i :in (sort-names (table-keys table))
     399                         :collect `(,key ,i ,@(sort-names (gethash i table))))))
     400          `(defpackage ,name
     401             ,@(when-relevant :nicknames (and nicknamesp (sort-names nicknames)))
     402             (:use ,@(and usep (sort-names use)))
     403             ,@(when-relevant :shadow (and shadowp (sort-names shadow)))
     404             ,@(import-options :shadowing-import-from (and shadowing-import-p shadowing-import))
     405             ,@(import-options :import-from (and importp import))
     406             ,@(when-relevant :export (and exportp (sort-names export)))
     407             ,@(when-relevant :intern (and internp (sort-names intern)))))))))
     408
     409
     410;;; ensure-package, define-package
     411(eval-when (:load-toplevel :compile-toplevel :execute)
     412  (defun ensure-shadowing-import (name to-package from-package shadowed imported)
     413    (check-type name string)
     414    (check-type to-package package)
     415    (check-type from-package package)
     416    (check-type shadowed hash-table)
     417    (check-type imported hash-table)
     418    (let ((import-me (find-symbol* name from-package)))
     419      (multiple-value-bind (existing status) (find-symbol name to-package)
     420        (cond
     421          ((gethash name shadowed)
     422           (unless (eq import-me existing)
     423             (error "Conflicting shadowings for ~A" name)))
     424          (t
     425           (setf (gethash name shadowed) t)
     426           (setf (gethash name imported) t)
     427           (unless (or (null status)
     428                       (and (member status '(:internal :external))
     429                            (eq existing import-me)
     430                            (symbol-shadowing-p existing to-package)))
     431             (note-package-fishiness
     432              :shadowing-import name
     433              (package-name from-package)
     434              (or (home-package-p import-me from-package) (symbol-package-name import-me))
     435              (package-name to-package) status
     436              (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
     437           (shadowing-import import-me to-package))))))
     438  (defun ensure-import (name to-package from-package shadowed imported)
     439    (check-type name string)
     440    (check-type to-package package)
     441    (check-type from-package package)
     442    (check-type shadowed hash-table)
     443    (check-type imported hash-table)
     444    (multiple-value-bind (import-me import-status) (find-symbol name from-package)
     445      (when (null import-status)
     446        (note-package-fishiness
     447         :import-uninterned name (package-name from-package) (package-name to-package))
     448        (setf import-me (intern name from-package)))
     449      (multiple-value-bind (existing status) (find-symbol name to-package)
     450        (cond
     451          ((gethash name imported)
     452           (unless (eq import-me existing)
     453             (error "Can't import ~S from both ~S and ~S"
     454                    name (package-name (symbol-package existing)) (package-name from-package))))
     455          ((gethash name shadowed)
     456           (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
     457          (t
     458           (setf (gethash name imported) t)
     459           (unless (and status (eq import-me existing))
     460             (when status
     461               (note-package-fishiness
     462                :import name
     463                (package-name from-package)
     464                (or (home-package-p import-me from-package) (symbol-package-name import-me))
     465                (package-name to-package) status
     466                (and status (or (home-package-p existing to-package) (symbol-package-name existing))))
     467               (unintern* existing to-package))
     468             (import import-me to-package)))))))
     469  (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
     470    (check-type name string)
     471    (check-type symbol symbol)
     472    (check-type to-package package)
     473    (check-type from-package package)
     474    (check-type mixp (member nil t)) ; no cl:boolean on Genera
     475    (check-type shadowed hash-table)
     476    (check-type imported hash-table)
     477    (check-type inherited hash-table)
     478    (multiple-value-bind (existing status) (find-symbol name to-package)
     479      (let* ((sp (symbol-package symbol))
     480             (in (gethash name inherited))
     481             (xp (and status (symbol-package existing))))
     482        (when (null sp)
     483          (note-package-fishiness
     484           :import-uninterned name
     485           (package-name from-package) (package-name to-package) mixp)
     486          (import symbol from-package)
     487          (setf sp (package-name from-package)))
     488        (cond
     489          ((gethash name shadowed))
     490          (in
     491           (unless (equal sp (first in))
     492             (if mixp
     493                 (ensure-shadowing-import name to-package (second in) shadowed imported)
     494                 (error "Can't inherit ~S from ~S, it is inherited from ~S"
     495                        name (package-name sp) (package-name (first in))))))
     496          ((gethash name imported)
     497           (unless (eq symbol existing)
     498             (error "Can't inherit ~S from ~S, it is imported from ~S"
     499                    name (package-name sp) (package-name xp))))
     500          (t
     501           (setf (gethash name inherited) (list sp from-package))
     502           (when (and status (not (eq sp xp)))
     503             (let ((shadowing (symbol-shadowing-p existing to-package)))
     504               (note-package-fishiness
     505                :inherited name
     506                (package-name from-package)
     507                (or (home-package-p symbol from-package) (symbol-package-name symbol))
     508                (package-name to-package)
     509                (or (home-package-p existing to-package) (symbol-package-name existing)))
     510               (if shadowing (ensure-shadowing-import name to-package from-package shadowed imported)
     511                   (unintern* existing to-package)))))))))
     512  (defun ensure-mix (name symbol to-package from-package shadowed imported inherited)
     513    (check-type name string)
     514    (check-type symbol symbol)
     515    (check-type to-package package)
     516    (check-type from-package package)
     517    (check-type shadowed hash-table)
     518    (check-type imported hash-table)
     519    (check-type inherited hash-table)
     520    (unless (gethash name shadowed)
     521      (multiple-value-bind (existing status) (find-symbol name to-package)
     522        (let* ((sp (symbol-package symbol))
     523               (im (gethash name imported))
     524               (in (gethash name inherited)))
     525          (cond
     526            ((or (null status)
     527                 (and status (eq symbol existing))
     528                 (and in (eq sp (first in))))
     529             (ensure-inherited name symbol to-package from-package t shadowed imported inherited))
     530            (in
     531             (remhash name inherited)
     532             (ensure-shadowing-import name to-package (second in) shadowed imported))
     533            (im
     534             (error "Symbol ~S import from ~S~:[~; actually ~:[uninterned~;~:*from ~S~]~] conflicts with existing symbol in ~S~:[~; actually ~:[uninterned~;from ~:*~S~]~]"
     535                    name (package-name from-package)
     536                    (home-package-p symbol from-package) (symbol-package-name symbol)
     537                    (package-name to-package)
     538                    (home-package-p existing to-package) (symbol-package-name existing)))
     539            (t
     540             (ensure-inherited name symbol to-package from-package t shadowed imported inherited)))))))
     541  (defun recycle-symbol (name recycle exported)
     542    (check-type name string)
     543    (check-type recycle list)
     544    (check-type exported hash-table)
     545    (when (gethash name exported) ;; don't bother recycling private symbols
     546      (let (recycled foundp)
     547        (dolist (r recycle (values recycled foundp))
     548          (multiple-value-bind (symbol status) (find-symbol name r)
     549            (when (and status (home-package-p symbol r))
     550              (cond
     551                (foundp
     552                 ;; (nuke-symbol symbol)) -- even simple variable names like O or C will do that.
     553                 (note-package-fishiness :recycled-duplicate name (package-name foundp) (package-name r)))
     554                (t
     555                 (setf recycled symbol foundp r)))))))))
     556  (defun symbol-recycled-p (sym recycle)
     557    (check-type sym symbol)
     558    (check-type recycle list)
     559    (member (symbol-package sym) recycle))
     560  (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
     561    (check-type name string)
     562    (check-type package package)
     563    (check-type intern (member nil t)) ; no cl:boolean on Genera
     564    (check-type shadowed hash-table)
     565    (check-type imported hash-table)
     566    (check-type inherited hash-table)
     567    (unless (or (gethash name shadowed)
     568                (gethash name imported)
     569                (gethash name inherited))
     570      (multiple-value-bind (existing status)
     571          (find-symbol name package)
     572        (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
     573          (cond
     574            ((and status (eq existing recycled) (eq previous package)))
     575            (previous
     576             (rehome-symbol recycled package))
     577            ((and status (eq package (symbol-package existing))))
     578            (t
     579             (when status
     580               (note-package-fishiness
     581                :ensure-symbol name
     582                (reify-package (symbol-package existing) package)
     583                status intern)
     584               (unintern existing))
     585             (when intern
     586               (intern* name package))))))))
     587  (declaim (ftype function ensure-exported))
     588  (defun ensure-exported-to-user (name symbol to-package &optional recycle)
     589    (check-type name string)
     590    (check-type symbol symbol)
     591    (check-type to-package package)
     592    (check-type recycle list)
     593    (multiple-value-bind (existing status) (find-symbol name to-package)
     594      (unless (and status (eq symbol existing))
     595        (let ((accessible
     596                (or (null status)
     597                    (let ((shadowing (symbol-shadowing-p existing to-package))
     598                          (recycled (symbol-recycled-p existing recycle)))
     599                      (unless (and shadowing (not recycled))
     600                        (note-package-fishiness
     601                         :ensure-export name (symbol-package-name symbol)
     602                         (package-name to-package)
     603                         (or (home-package-p existing to-package) (symbol-package-name existing))
     604                         status shadowing)
     605                        (if (or (eq status :inherited) shadowing)
     606                            (shadowing-import symbol to-package)
     607                            (unintern existing to-package))
     608                        t)))))
     609          (when (and accessible (eq status :external))
     610            (ensure-exported name symbol to-package recycle))))))
     611  (defun ensure-exported (name symbol from-package &optional recycle)
     612    (dolist (to-package (package-used-by-list from-package))
     613      (ensure-exported-to-user name symbol to-package recycle))
     614    (import symbol from-package)
     615    (export* name from-package))
     616  (defun ensure-export (name from-package &optional recycle)
     617    (multiple-value-bind (symbol status) (find-symbol* name from-package)
     618      (unless (eq status :external)
     619        (ensure-exported name symbol from-package recycle))))
     620  (defun ensure-package (name &key
     621                                nicknames documentation use
     622                                shadow shadowing-import-from
     623                                import-from export intern
     624                                recycle mix reexport
     625                                unintern)
     626    #+(or gcl2.6 genera) (declare (ignore documentation))
     627    (let* ((package-name (string name))
     628           (nicknames (mapcar #'string nicknames))
     629           (names (cons package-name nicknames))
     630           (previous (packages-from-names names))
     631           (discarded (cdr previous))
     632           (to-delete ())
     633           (package (or (first previous) (make-package package-name :nicknames nicknames)))
     634           (recycle (packages-from-names recycle))
     635           (use (mapcar 'find-package* use))
     636           (mix (mapcar 'find-package* mix))
     637           (reexport (mapcar 'find-package* reexport))
     638           (shadow (mapcar 'string shadow))
     639           (export (mapcar 'string export))
     640           (intern (mapcar 'string intern))
     641           (unintern (mapcar 'string unintern))
     642           (shadowed (make-hash-table :test 'equal)) ; string to bool
     643           (imported (make-hash-table :test 'equal)) ; string to bool
     644           (exported (make-hash-table :test 'equal)) ; string to bool
     645           ;; string to list home package and use package:
     646           (inherited (make-hash-table :test 'equal)))
     647      (when-package-fishiness (record-fishy package-name))
     648      #-(or gcl2.6 genera)
     649      (when documentation (setf (documentation package t) documentation))
     650      (loop :for p :in (set-difference (package-use-list package) (append mix use))
     651            :do (note-package-fishiness :over-use name (package-names p))
     652                (unuse-package p package))
     653      (loop :for p :in discarded
     654            :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
     655                                (package-names p))
     656            :do (note-package-fishiness :nickname name (package-names p))
     657                (cond (n (rename-package p (first n) (rest n)))
     658                      (t (rename-package-away p)
     659                         (push p to-delete))))
     660      (rename-package package package-name nicknames)
     661      (dolist (name unintern)
     662        (multiple-value-bind (existing status) (find-symbol name package)
     663          (when status
     664            (unless (eq status :inherited)
     665              (note-package-fishiness
     666               :unintern (package-name package) name (symbol-package-name existing) status)
     667              (unintern* name package nil)))))
     668      (dolist (name export)
     669        (setf (gethash name exported) t))
     670      (dolist (p reexport)
     671        (do-external-symbols (sym p)
     672          (setf (gethash (string sym) exported) t)))
     673      (do-external-symbols (sym package)
     674        (let ((name (symbol-name sym)))
     675          (unless (gethash name exported)
     676            (note-package-fishiness
     677             :over-export (package-name package) name
     678             (or (home-package-p sym package) (symbol-package-name sym)))
     679            (unexport sym package))))
     680      (dolist (name shadow)
     681        (setf (gethash name shadowed) t)
     682        (multiple-value-bind (existing status) (find-symbol name package)
     683          (multiple-value-bind (recycled previous) (recycle-symbol name recycle exported)
     684            (let ((shadowing (and status (symbol-shadowing-p existing package))))
     685              (cond
     686                ((eq previous package))
     687                (previous
     688                 (rehome-symbol recycled package))
     689                ((or (member status '(nil :inherited))
     690                     (home-package-p existing package)))
     691                (t
     692                 (let ((dummy (make-symbol name)))
     693                   (note-package-fishiness
     694                    :shadow-imported (package-name package) name
     695                    (symbol-package-name existing) status shadowing)
     696                   (shadowing-import dummy package)
     697                   (import dummy package)))))))
     698        (shadow name package))
     699      (loop :for (p . syms) :in shadowing-import-from
     700            :for pp = (find-package* p) :do
     701              (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
     702      (loop :for p :in mix
     703            :for pp = (find-package* p) :do
     704              (do-external-symbols (sym pp) (ensure-mix (symbol-name sym) sym package pp shadowed imported inherited)))
     705      (loop :for (p . syms) :in import-from
     706            :for pp = (find-package p) :do
     707              (dolist (sym syms) (ensure-import (symbol-name sym) package pp shadowed imported)))
     708      (dolist (p (append use mix))
     709        (do-external-symbols (sym p) (ensure-inherited (string sym) sym package p nil shadowed imported inherited))
     710        (use-package p package))
     711      (loop :for name :being :the :hash-keys :of exported :do
     712        (ensure-symbol name package t recycle shadowed imported inherited exported)
     713        (ensure-export name package recycle))
     714      (dolist (name intern)
     715        (ensure-symbol name package t recycle shadowed imported inherited exported))
     716      (do-symbols (sym package)
     717        (ensure-symbol (symbol-name sym) package nil recycle shadowed imported inherited exported))
     718      (map () 'delete-package* to-delete)
     719      package)))
     720
     721(eval-when (:load-toplevel :compile-toplevel :execute)
     722  (defun parse-define-package-form (package clauses)
     723    (loop
     724      :with use-p = nil :with recycle-p = nil
     725      :with documentation = nil
     726      :for (kw . args) :in clauses
     727      :when (eq kw :nicknames) :append args :into nicknames :else
     728        :when (eq kw :documentation)
     729          :do (cond
     730                (documentation (error "define-package: can't define documentation twice"))
     731                ((or (atom args) (cdr args)) (error "define-package: bad documentation"))
     732                (t (setf documentation (car args)))) :else
     733      :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else
     734        :when (eq kw :shadow) :append args :into shadow :else
     735          :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else
     736            :when (eq kw :import-from) :collect args :into import-from :else
     737              :when (eq kw :export) :append args :into export :else
     738                :when (eq kw :intern) :append args :into intern :else
     739                  :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else
     740                    :when (eq kw :mix) :append args :into mix :else
     741                      :when (eq kw :reexport) :append args :into reexport :else
     742                        :when (eq kw :unintern) :append args :into unintern :else
     743                          :do (error "unrecognized define-package keyword ~S" kw)
     744      :finally (return `(,package
     745                         :nicknames ,nicknames :documentation ,documentation
     746                         :use ,(if use-p use '(:common-lisp))
     747                         :shadow ,shadow :shadowing-import-from ,shadowing-import-from
     748                         :import-from ,import-from :export ,export :intern ,intern
     749                         :recycle ,(if recycle-p recycle (cons package nicknames))
     750                         :mix ,mix :reexport ,reexport :unintern ,unintern)))))
     751
     752(defmacro define-package (package &rest clauses)
     753  (let ((ensure-form
     754          `(apply 'ensure-package ',(parse-define-package-form package clauses))))
     755    `(progn
     756       #+clisp
     757       (eval-when (:compile-toplevel :load-toplevel :execute)
     758         ,ensure-form)
     759       #+(or clisp ecl gcl) (defpackage ,package (:use))
     760       (eval-when (:compile-toplevel :load-toplevel :execute)
     761         ,ensure-form))))
     762
     763;;;; Final tricks to keep various implementations happy.
     764;; We want most such tricks in common-lisp.lisp,
     765;; but these need to be done before the define-package form there,
     766;; that we nevertheless want to be the very first form.
     767(eval-when (:load-toplevel :compile-toplevel :execute)
     768  #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF.
     769  (setf excl::*autoload-package-name-alist*
     770        (remove "asdf" excl::*autoload-package-name-alist*
     771                :test 'equalp :key 'car))
     772  #+gcl
     773  ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff,
     774  ;; but can run ASDF 2.011. GCL 2.6 has even more issues.
     775  (cond
     776    ((or (< system::*gcl-major-version* 2)
     777         (and (= system::*gcl-major-version* 2)
     778              (< system::*gcl-minor-version* 6)))
     779     (error "GCL 2.6 or later required to use ASDF"))
     780    ((and (= system::*gcl-major-version* 2)
     781          (= system::*gcl-minor-version* 6))
     782     (pushnew 'ignorable pcl::*variable-declarations-without-argument*)
     783     (pushnew :gcl2.6 *features*))
     784    (t
     785     (pushnew :gcl2.7 *features*))))
     786;;;; -------------------------------------------------------------------------
     787;;;; Handle compatibility with multiple implementations.
     788;;; This file is for papering over the deficiencies and peculiarities
     789;;; of various Common Lisp implementations.
     790;;; For implementation-specific access to the system, see os.lisp instead.
     791;;; A few functions are defined here, but actually exported from utility;
     792;;; from this package only common-lisp symbols are exported.
     793
     794(asdf/package:define-package :asdf/common-lisp
     795  (:nicknames :asdf/cl)
     796  (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package)
     797  (:reexport :common-lisp)
     798  (:recycle :asdf/common-lisp :asdf)
     799  #+allegro (:intern #:*acl-warn-save*)
     800  #+cormanlisp (:shadow #:user-homedir-pathname)
     801  #+cormanlisp
     802  (:export
     803   #:logical-pathname #:translate-logical-pathname
     804   #:make-broadcast-stream #:file-namestring)
     805  #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!)
     806  #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*)
     807  #+genera (:shadowing-import-from :scl #:boolean)
     808  #+genera (:export #:boolean #:ensure-directories-exist)
     809  #+mcl (:shadow #:user-homedir-pathname))
     810(in-package :asdf/common-lisp)
    52811
    53812#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    54813(error "ASDF is not supported on your implementation. Please help us port it.")
    55814
    56 ;;;; Create and setup packages in a way that is compatible with hot-upgrade.
    57 ;;;; See https://bugs.launchpad.net/asdf/+bug/485687
    58 ;;;; See these two eval-when forms, and more near the end of the file.
    59 
    60 #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
    61 
     815;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults.
     816
     817
     818;;;; Early meta-level tweaks
     819
     820#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
     821      clozure lispworks (and sbcl sb-unicode) scl)
    62822(eval-when (:load-toplevel :compile-toplevel :execute)
    63   ;;; Before we do anything, some implementation-dependent tweaks
    64   ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
    65   #+allegro
    66   (setf excl::*autoload-package-name-alist*
    67         (remove "asdf" excl::*autoload-package-name-alist*
    68                 :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
    69   #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
    70   (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
    71             (and (= system::*gcl-major-version* 2)
    72                  (< system::*gcl-minor-version* 7)))
    73     (pushnew :gcl-pre2.7 *features*))
    74   #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
    75         clozure lispworks (and sbcl sb-unicode) scl)
    76   (pushnew :asdf-unicode *features*)
    77   ;;; make package if it doesn't exist yet.
    78   ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
    79   (unless (find-package :asdf)
    80     (make-package :asdf :use '(:common-lisp))))
    81 
    82 (in-package :asdf)
    83 
     823  (pushnew :asdf-unicode *features*))
     824
     825#+allegro
    84826(eval-when (:load-toplevel :compile-toplevel :execute)
    85   ;;; This would belong amongst implementation-dependent tweaks above,
    86   ;;; except that the defun has to be in package asdf.
    87   #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
    88   #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
    89   #+mkcl (require :cmp)
    90   #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics
    91 
    92   ;;; Package setup, step 2.
    93   (defvar *asdf-version* nil)
    94   (defvar *upgraded-p* nil)
    95   (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
    96   (defun find-symbol* (s p)
    97     (find-symbol (string s) p))
    98   ;; Strip out formatting that is not supported on Genera.
    99   ;; Has to be inside the eval-when to make Lispworks happy (!)
    100   (defun strcat (&rest strings)
    101     (apply 'concatenate 'string strings))
    102   (defmacro compatfmt (format)
    103     #-(or gcl genera) format
    104     #+(or gcl genera)
    105     (loop :for (unsupported . replacement) :in
    106       (append
    107        '(("~3i~_" . ""))
    108        #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
    109       (loop :for found = (search unsupported format) :while found :do
    110         (setf format (strcat (subseq format 0 found) replacement
    111                              (subseq format (+ found (length unsupported)))))))
    112     format)
    113   (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
    114          ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
    115          ;; can help you do these changes in synch (look at the source for documentation).
    116          ;; Relying on its automation, the version is now redundantly present on top of this file.
    117          ;; "2.345" would be an official release
    118          ;; "2.345.6" would be a development version in the official upstream
    119          ;; "2.345.0.7" would be your seventh local modification of official release 2.345
    120          ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
    121          (asdf-version "2.26")
    122          (existing-asdf (find-class 'component nil))
    123          (existing-version *asdf-version*)
    124          (already-there (equal asdf-version existing-version)))
    125     (unless (and existing-asdf already-there)
    126       (when (and existing-asdf *asdf-verbose*)
    127         (format *trace-output*
    128                 (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
    129                 existing-version asdf-version))
    130       (labels
    131           ((present-symbol-p (symbol package)
    132              (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
    133            (present-symbols (package)
    134              ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
    135              (let (l)
    136                (do-symbols (s package)
    137                  (when (present-symbol-p s package) (push s l)))
    138                (reverse l)))
    139            (unlink-package (package)
    140              (let ((u (find-package package)))
    141                (when u
    142                  (ensure-unintern u (present-symbols u))
    143                  (loop :for p :in (package-used-by-list u) :do
    144                    (unuse-package u p))
    145                  (delete-package u))))
    146            (ensure-exists (name nicknames use)
    147              (let ((previous
    148                     (remove-duplicates
    149                      (mapcar #'find-package (cons name nicknames))
    150                      :from-end t)))
    151                ;; do away with packages with conflicting (nick)names
    152                (map () #'unlink-package (cdr previous))
    153                ;; reuse previous package with same name
    154                (let ((p (car previous)))
    155                  (cond
    156                    (p
    157                     (rename-package p name nicknames)
    158                     (ensure-use p use)
    159                     p)
    160                    (t
    161                     (make-package name :nicknames nicknames :use use))))))
    162            (intern* (symbol package)
    163              (intern (string symbol) package))
    164            (remove-symbol (symbol package)
    165              (let ((sym (find-symbol* symbol package)))
    166                (when sym
    167                  #-cormanlisp (unexport sym package)
    168                  (unintern sym package)
    169                  sym)))
    170            (ensure-unintern (package symbols)
    171              (loop :with packages = (list-all-packages)
    172                :for sym :in symbols
    173                :for removed = (remove-symbol sym package)
    174                :when removed :do
    175                (loop :for p :in packages :do
    176                  (when (eq removed (find-symbol* sym p))
    177                    (unintern removed p)))))
    178            (ensure-shadow (package symbols)
    179              (shadow symbols package))
    180            (ensure-use (package use)
    181              (dolist (used (package-use-list package))
    182                (unless (member (package-name used) use :test 'string=)
    183                  (unuse-package used)
    184                  (do-external-symbols (sym used)
    185                    (when (eq sym (find-symbol* sym package))
    186                      (remove-symbol sym package)))))
    187              (dolist (used (reverse use))
    188                (do-external-symbols (sym used)
    189                  (unless (eq sym (find-symbol* sym package))
    190                    (remove-symbol sym package)))
    191                (use-package used package)))
    192            (ensure-fmakunbound (package symbols)
    193              (loop :for name :in symbols
    194                :for sym = (find-symbol* name package)
    195                :when sym :do (fmakunbound sym)))
    196            (ensure-export (package export)
    197              (let ((formerly-exported-symbols nil)
    198                    (bothly-exported-symbols nil)
    199                    (newly-exported-symbols nil))
    200                (do-external-symbols (sym package)
    201                  (if (member sym export :test 'string-equal)
    202                      (push sym bothly-exported-symbols)
    203                      (push sym formerly-exported-symbols)))
    204                (loop :for sym :in export :do
    205                  (unless (member sym bothly-exported-symbols :test 'equal)
    206                    (push sym newly-exported-symbols)))
    207                (loop :for user :in (package-used-by-list package)
    208                  :for shadowing = (package-shadowing-symbols user) :do
    209                  (loop :for new :in newly-exported-symbols
    210                    :for old = (find-symbol* new user)
    211                    :when (and old (not (member old shadowing)))
    212                    :do (unintern old user)))
    213                (loop :for x :in newly-exported-symbols :do
    214                  (export (intern* x package)))))
    215            (ensure-package (name &key nicknames use unintern
    216                                  shadow export redefined-functions)
    217              (let* ((p (ensure-exists name nicknames use)))
    218                (ensure-unintern p (append unintern #+cmu redefined-functions))
    219                (ensure-shadow p shadow)
    220                (ensure-export p export)
    221                #-cmu (ensure-fmakunbound p redefined-functions)
    222                p)))
    223         (macrolet
    224             ((pkgdcl (name &key nicknames use export
    225                            redefined-functions unintern shadow)
    226                  `(ensure-package
    227                    ',name :nicknames ',nicknames :use ',use :export ',export
    228                    :shadow ',shadow
    229                    :unintern ',unintern
    230                    :redefined-functions ',redefined-functions)))
    231           (pkgdcl
    232            :asdf
    233            :use (:common-lisp)
    234            :redefined-functions
    235            (#:perform #:explain #:output-files #:operation-done-p
    236             #:perform-with-restarts #:component-relative-pathname
    237             #:system-source-file #:operate #:find-component #:find-system
    238             #:apply-output-translations #:translate-pathname* #:resolve-location
    239             #:system-relative-pathname
    240             #:inherit-source-registry #:process-source-registry
    241             #:process-source-registry-directive
    242             #:compile-file* #:source-file-type)
    243            :unintern
    244            (#:*asdf-revision* #:around #:asdf-method-combination
    245             #:split #:make-collector #:do-dep #:do-one-dep
    246             #:resolve-relative-location-component #:resolve-absolute-location-component
    247             #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
    248            :export
    249            (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
    250             #:system-definition-pathname #:with-system-definitions
    251             #:search-for-system-definition #:find-component #:component-find-path
    252             #:compile-system #:load-system #:load-systems
    253             #:require-system #:test-system #:clear-system
    254             #:operation #:compile-op #:load-op #:load-source-op #:test-op
    255             #:feature #:version #:version-satisfies
    256             #:upgrade-asdf
    257             #:implementation-identifier #:implementation-type #:hostname
    258             #:input-files #:output-files #:output-file #:perform
    259             #:operation-done-p #:explain
    260 
    261             #:component #:source-file
    262             #:c-source-file #:cl-source-file #:java-source-file
    263             #:cl-source-file.cl #:cl-source-file.lsp
    264             #:static-file
    265             #:doc-file
    266             #:html-file
    267             #:text-file
    268             #:source-file-type
    269             #:module                     ; components
    270             #:system
    271             #:unix-dso
    272 
    273             #:module-components          ; component accessors
    274             #:module-components-by-name
    275             #:component-pathname
    276             #:component-relative-pathname
    277             #:component-name
    278             #:component-version
    279             #:component-parent
    280             #:component-property
    281             #:component-system
    282             #:component-depends-on
    283             #:component-encoding
    284             #:component-external-format
    285 
    286             #:system-description
    287             #:system-long-description
    288             #:system-author
    289             #:system-maintainer
    290             #:system-license
    291             #:system-licence
    292             #:system-source-file
    293             #:system-source-directory
    294             #:system-relative-pathname
    295             #:map-systems
    296 
    297             #:operation-description
    298             #:operation-on-warnings
    299             #:operation-on-failure
    300             #:component-visited-p
    301 
    302             #:*system-definition-search-functions*   ; variables
    303             #:*central-registry*
    304             #:*compile-file-warnings-behaviour*
    305             #:*compile-file-failure-behaviour*
    306             #:*resolve-symlinks*
    307             #:*load-system-operation*
    308             #:*asdf-verbose*
    309             #:*verbose-out*
    310 
    311             #:asdf-version
    312 
    313             #:operation-error #:compile-failed #:compile-warned #:compile-error
    314             #:error-name
    315             #:error-pathname
    316             #:load-system-definition-error
    317             #:error-component #:error-operation
    318             #:system-definition-error
    319             #:missing-component
    320             #:missing-component-of-version
    321             #:missing-dependency
    322             #:missing-dependency-of-version
    323             #:circular-dependency        ; errors
    324             #:duplicate-names
    325 
    326             #:try-recompiling
    327             #:retry
    328             #:accept                     ; restarts
    329             #:coerce-entry-to-directory
    330             #:remove-entry-from-registry
    331 
    332             #:*encoding-detection-hook*
    333             #:*encoding-external-format-hook*
    334             #:*default-encoding*
    335             #:*utf-8-external-format*
    336 
    337             #:clear-configuration
    338             #:*output-translations-parameter*
    339             #:initialize-output-translations
    340             #:disable-output-translations
    341             #:clear-output-translations
    342             #:ensure-output-translations
    343             #:apply-output-translations
    344             #:compile-file*
    345             #:compile-file-pathname*
    346             #:enable-asdf-binary-locations-compatibility
    347             #:*default-source-registries*
    348             #:*source-registry-parameter*
    349             #:initialize-source-registry
    350             #:compute-source-registry
    351             #:clear-source-registry
    352             #:ensure-source-registry
    353             #:process-source-registry
    354             #:system-registered-p #:registered-systems #:loaded-systems
    355             #:resolve-location
    356             #:asdf-message
    357             #:user-output-translations-pathname
    358             #:system-output-translations-pathname
    359             #:user-output-translations-directory-pathname
    360             #:system-output-translations-directory-pathname
    361             #:user-source-registry
    362             #:system-source-registry
    363             #:user-source-registry-directory
    364             #:system-source-registry-directory
    365 
    366             ;; Utilities: please use asdf-utils instead
    367             #|
    368             ;; #:aif #:it
    369             ;; #:appendf #:orf
    370             #:length=n-p
    371             #:remove-keys #:remove-keyword
    372             #:first-char #:last-char #:string-suffix-p
    373             #:coerce-name
    374             #:directory-pathname-p #:ensure-directory-pathname
    375             #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root
    376             #:getenv #:getenv-pathname #:getenv-pathnames
    377             #:getenv-absolute-directory #:getenv-absolute-directories
    378             #:probe-file*
    379             #:find-symbol* #:strcat
    380             #:make-pathname-component-logical #:make-pathname-logical
    381             #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname*
    382             #:pathname-directory-pathname #:pathname-parent-directory-pathname
    383             #:read-file-forms
    384             #:resolve-symlinks #:truenamize
    385             #:split-string
    386             #:component-name-to-pathname-components
    387             #:split-name-type
    388             #:subdirectories #:directory-files
    389             #:while-collecting
    390             #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
    391             #:*wild-path* #:wilden
    392             #:directorize-pathname-host-device|#
    393             )))
    394         #+genera (import 'scl:boolean :asdf)
    395         (setf *asdf-version* asdf-version
    396               *upgraded-p* (if existing-version
    397                                (cons existing-version *upgraded-p*)
    398                                *upgraded-p*))))))
    399 
    400 ;;;; -------------------------------------------------------------------------
    401 ;;;; User-visible parameters
    402 ;;;;
    403 (defvar *resolve-symlinks* t
    404   "Determine whether or not ASDF resolves symlinks when defining systems.
    405 
    406 Defaults to T.")
    407 
    408 (defvar *compile-file-warnings-behaviour*
    409   (or #+clisp :ignore :warn)
    410   "How should ASDF react if it encounters a warning when compiling a file?
    411 Valid values are :error, :warn, and :ignore.")
    412 
    413 (defvar *compile-file-failure-behaviour*
    414   (or #+sbcl :error #+clisp :ignore :warn)
    415   "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
    416 when compiling a file?  Valid values are :error, :warn, and :ignore.
    417 Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")
    418 
    419 (defvar *verbose-out* nil)
    420 
    421 (defparameter +asdf-methods+
    422   '(perform-with-restarts perform explain output-files operation-done-p))
    423 
    424 (defvar *load-system-operation* 'load-op
    425   "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
    426 You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
    427 or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
    428 
    429 (defvar *compile-op-compile-file-function* 'compile-file*
    430   "Function used to compile lisp files.")
    431 
    432 
    433 
    434 #+allegro
    435 (eval-when (:compile-toplevel :execute)
    436827  (defparameter *acl-warn-save*
    437                 (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
    438                   excl:*warn-on-nested-reader-conditionals*))
     828    (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
     829      excl:*warn-on-nested-reader-conditionals*))
    439830  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
    440     (setf excl:*warn-on-nested-reader-conditionals* nil)))
    441 
    442 ;;;; -------------------------------------------------------------------------
    443 ;;;; Resolve forward references
    444 
    445 (declaim (ftype (function (t) t)
    446                 format-arguments format-control
    447                 error-name error-pathname error-condition
    448                 duplicate-names-name
    449                 error-component error-operation
    450                 module-components module-components-by-name
    451                 circular-dependency-components
    452                 condition-arguments condition-form
    453                 condition-format condition-location
    454                 coerce-name)
    455          (ftype (function (&optional t) (values)) initialize-source-registry)
    456          #-(or cormanlisp gcl-pre2.7)
    457          (ftype (function (t t) t) (setf module-components-by-name)))
    458 
    459 ;;;; -------------------------------------------------------------------------
    460 ;;;; Compatibility various implementations
     831    (setf excl:*warn-on-nested-reader-conditionals* nil))
     832  (setf *print-readably* nil))
     833
    461834#+cormanlisp
    462835(progn
     
    464837  (defun make-broadcast-stream () *error-output*)
    465838  (defun translate-logical-pathname (x) x)
     839  (defun user-homedir-pathname (&optional host)
     840    (declare (ignore host))
     841    (parse-namestring (format nil "~A\\" (cl:user-homedir-pathname))))
    466842  (defun file-namestring (p)
    467843    (setf p (pathname p))
    468844    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
     845
     846#+ecl
     847(eval-when (:load-toplevel :compile-toplevel :execute)
     848  (setf *load-verbose* nil)
     849  (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
     850  (unless (use-ecl-byte-compiler-p) (require :cmp)))
     851
     852#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
     853(eval-when (:load-toplevel :compile-toplevel :execute)
     854  (unless (member :ansi-cl *features*)
     855    (error "ASDF only supports GCL in ANSI mode. Aborting.~%"))
     856  (setf compiler::*compiler-default-type* (pathname "")
     857        compiler::*lsp-ext* ""))
     858
     859#+gcl2.6
     860(eval-when (:compile-toplevel :load-toplevel :execute)
     861  (shadow 'type-of :asdf/common-lisp)
     862  (shadowing-import 'system:*load-pathname* :asdf/common-lisp))
     863
     864#+gcl2.6
     865(eval-when (:compile-toplevel :load-toplevel :execute)
     866  (export 'type-of :asdf/common-lisp)
     867  (export 'system:*load-pathname* :asdf/common-lisp))
     868
     869#+gcl2.6
     870(progn ;; Doesn't support either logical-pathnames or output-translations.
     871  (defvar *gcl2.6* t)
     872  (deftype logical-pathname () nil)
     873  (defun type-of (x) (class-name (class-of x)))
     874  (defun wild-pathname-p (path) (declare (ignore path)) nil)
     875  (defun translate-logical-pathname (x) x)
     876  (defvar *compile-file-pathname* nil)
     877  (defun pathname-match-p (in-pathname wild-pathname)
     878    (declare (ignore in-wildname wild-wildname)) nil)
     879  (defun translate-pathname (source from-wildname to-wildname &key)
     880    (declare (ignore from-wildname to-wildname)) source)
     881  (defun %print-unreadable-object (object stream type identity thunk)
     882    (format stream "#<~@[~S ~]" (when type (type-of object)))
     883    (funcall thunk)
     884    (format stream "~@[ ~X~]>" (when identity (system:address object))))
     885  (defmacro with-standard-io-syntax (&body body)
     886    `(progn ,@body))
     887  (defmacro with-compilation-unit (options &body body)
     888    (declare (ignore options)) `(progn ,@body))
     889  (defmacro print-unreadable-object ((object stream &key type identity) &body body)
     890    `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body)))
     891  (defun ensure-directories-exist (path)
     892    (lisp:system (format nil "mkdir -p ~S"
     893                         (namestring (make-pathname :name nil :type nil :version nil :defaults path))))))
     894
     895#+genera
     896(unless (fboundp 'ensure-directories-exist)
     897  (defun ensure-directories-exist (path)
     898    (fs:create-directories-recursively (pathname path))))
    469899
    470900#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
     
    477907          ;; MCL by default provides the directory from which MCL was started.
    478908          ;; See http://code.google.com/p/mcl/wiki/Portability
    479           (defun current-user-homedir-pathname ()
     909          (defun user-homedir-pathname ()
    480910            (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
    481911          (defun probe-posix (posix-namestring)
     
    487917                  (ccl::%path-from-fsref fsref is-dir))))))"))
    488918
     919#+mkcl
     920(eval-when (:load-toplevel :compile-toplevel :execute)
     921  (require :cmp)
     922  (setq clos::*redefine-class-in-place* t)) ;; Make sure we have strict ANSI class redefinition semantics
     923
     924
     925;;;; Looping
     926(defmacro loop* (&rest rest)
     927  #-genera `(loop ,@rest)
     928  #+genera `(lisp:loop ,@rest)) ;; In genera, CL:LOOP can't destructure, so we use LOOP*. Sigh.
     929
     930
     931;;;; compatfmt: avoid fancy format directives when unsupported
     932(eval-when (:load-toplevel :compile-toplevel :execute)
     933  (defun remove-substrings (substrings string)
     934    (let ((length (length string)) (stream nil))
     935      (labels ((emit (start end)
     936                 (when (and (zerop start) (= end length))
     937                   (return-from remove-substrings string))
     938                 (when (< start end)
     939                   (unless stream (setf stream (make-string-output-stream)))
     940                   (write-string string stream :start start :end end)))
     941               (recurse (substrings start end)
     942                 (cond
     943                   ((>= start end))
     944                   ((null substrings) (emit start end))
     945                   (t (let* ((sub (first substrings))
     946                             (found (search sub string :start2 start :end2 end))
     947                             (more (rest substrings)))
     948                        (cond
     949                          (found
     950                           (recurse more start found)
     951                           (recurse substrings (+ found (length sub)) end))
     952                          (t
     953                           (recurse more start end))))))))
     954        (recurse substrings 0 length))
     955      (if stream (get-output-stream-string stream) ""))))
     956
     957(defmacro compatfmt (format)
     958  #+(or gcl genera)
     959  (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format)
     960  #-(or gcl genera) format)
     961
     962
    489963;;;; -------------------------------------------------------------------------
    490 ;;;; General Purpose Utilities
    491 
    492 (macrolet
    493     ((defdef (def* def)
    494        `(defmacro ,def* (name formals &rest rest)
    495           `(progn
    496              #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
    497              #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
    498              ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
    499                 `(declaim (notinline ,name)))
    500              (,',def ,name ,formals ,@rest)))))
    501   (defdef defgeneric* defgeneric)
    502   (defdef defun* defun))
    503 
     964;;;; General Purpose Utilities for ASDF
     965
     966(asdf/package:define-package :asdf/utility
     967  (:recycle :asdf/utility :asdf)
     968  (:use :asdf/common-lisp :asdf/package)
     969  ;; import and reexport a few things defined in :asdf/common-lisp
     970  (:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings
     971   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
     972  (:export #:compatfmt #:loop* #:remove-substrings #:compatfmt
     973   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
     974  (:export
     975   ;; magic helper to define debugging functions:
     976   #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
     977   #:undefine-function #:undefine-functions #:defun* #:defgeneric* ;; (un)defining functions
     978   #:if-let ;; basic flow control
     979   #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
     980   #:emptyp ;; sequences
     981   #:strcat #:first-char #:last-char #:split-string ;; strings
     982   #:string-prefix-p #:string-enclosed-p #:string-suffix-p
     983   #:find-class* ;; CLOS
     984   #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
     985   #:earlier-stamp #:stamps-earliest #:earliest-stamp
     986   #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f
     987   #:list-to-hash-set ;; hash-table
     988   #:ensure-function #:access-at #:access-at-count ;; functions
     989   #:call-function #:call-functions #:register-hook-function
     990   #:match-condition-p #:match-any-condition-p ;; conditions
     991   #:call-with-muffled-conditions #:with-muffled-conditions
     992   #:load-string #:load-stream
     993   #:lexicographic< #:lexicographic<=
     994   #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
     995(in-package :asdf/utility)
     996
     997;;;; Defining functions in a way compatible with hot-upgrade:
     998;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition,
     999;; thus replacing the function without warning or error
     1000;; even if the signature and/or generic-ness of the function has changed.
     1001;; For a generic function, this invalidates any previous DEFMETHOD.
     1002(eval-when (:load-toplevel :compile-toplevel :execute)
     1003  (defun undefine-function (function-spec)
     1004    (cond
     1005      ((symbolp function-spec)
     1006       #+clisp
     1007       (let ((f (and (fboundp function-spec) (fdefinition function-spec))))
     1008         (when (typep f 'clos:standard-generic-function)
     1009           (loop :for m :in (clos:generic-function-methods f)
     1010                 :do (remove-method f m))))
     1011       (fmakunbound function-spec))
     1012      ((and (consp function-spec) (eq (car function-spec) 'setf)
     1013            (consp (cdr function-spec)) (null (cddr function-spec)))
     1014       #-gcl2.6 (fmakunbound function-spec))
     1015      (t (error "bad function spec ~S" function-spec))))
     1016  (defun undefine-functions (function-spec-list)
     1017    (map () 'undefine-function function-spec-list))
     1018  (macrolet
     1019      ((defdef (def* def)
     1020         `(defmacro ,def* (name formals &rest rest)
     1021            (destructuring-bind (name &key (supersede t))
     1022                (if (or (atom name) (eq (car name) 'setf))
     1023                    (list name :supersede nil)
     1024                    name)
     1025              (declare (ignorable supersede))
     1026              `(progn
     1027                 ;; undefining the previous function is the portable way
     1028                 ;; of overriding any incompatible previous gf, except on CLISP.
     1029                 ;; We usually try to do it only for the functions that need it,
     1030                 ;; which happens in asdf/upgrade - however, for ECL, we need this hammer,
     1031                 ;; (which causes issues in clisp)
     1032                 ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX
     1033                     `((undefine-function ',name)))
     1034                 #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
     1035                 ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
     1036                     `((declaim (notinline ,name))))
     1037                 (,',def ,name ,formals ,@rest))))))
     1038    (defdef defgeneric* defgeneric)
     1039    (defdef defun* defun)))
     1040
     1041
     1042;;; Magic debugging help. See contrib/debug.lisp
     1043(defvar *asdf-debug-utility*
     1044  '(or (ignore-errors
     1045        (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib/debug.lisp"))
     1046    (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
     1047  "form that evaluates to the pathname to your favorite debugging utilities")
     1048
     1049(defmacro asdf-debug (&rest keys)
     1050  `(eval-when (:compile-toplevel :load-toplevel :execute)
     1051     (load-asdf-debug-utility ,@keys)))
     1052
     1053(defun* load-asdf-debug-utility (&key package utility-file)
     1054  (let* ((*package* (if package (find-package package) *package*))
     1055         (keyword (read-from-string
     1056                   (format nil ":DBG-~:@(~A~)" (package-name *package*)))))
     1057    (unless (member keyword *features*)
     1058      (let* ((utility-file (or utility-file *asdf-debug-utility*))
     1059             (file (ignore-errors (probe-file (eval utility-file)))))
     1060        (if file (load file)
     1061            (error "Failed to locate debug utility file: ~S" utility-file))))))
     1062
     1063
     1064;;; Flow control
     1065(defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria
     1066  ;; bindings can be (var form) or ((var1 form1) ...)
     1067  (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings)))
     1068                           (list bindings)
     1069                           bindings))
     1070         (variables (mapcar #'car binding-list)))
     1071    `(let ,binding-list
     1072       (if (and ,@variables)
     1073           ,then-form
     1074           ,else-form))))
     1075
     1076;;; List manipulation
    5041077(defmacro while-collecting ((&rest collectors) &body body)
    5051078  "COLLECTORS should be a list of names for collections.  A collector
     
    5201093         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
    5211094
    522 (defmacro aif (test then &optional else)
    523   "Anaphoric version of IF, On Lisp style"
    524   `(let ((it ,test)) (if it ,then ,else)))
    525 
    526 (defun* pathname-directory-pathname (pathname)
    527   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    528 and NIL NAME, TYPE and VERSION components"
    529   (when pathname
    530     (make-pathname :name nil :type nil :version nil :defaults pathname)))
    531 
    532 (defun* normalize-pathname-directory-component (directory)
    533   "Given a pathname directory component, return an equivalent form that is a list"
    534   (cond
    535     #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
    536     ((stringp directory) `(:absolute ,directory) directory)
    537     #+gcl
    538     ((and (consp directory) (stringp (first directory)))
    539      `(:absolute ,@directory))
    540     ((or (null directory)
    541          (and (consp directory) (member (first directory) '(:absolute :relative))))
    542      directory)
    543     (t
    544      (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
    545 
    546 (defun* merge-pathname-directory-components (specified defaults)
    547   ;; Helper for merge-pathnames* that handles directory components.
    548   (let ((directory (normalize-pathname-directory-component specified)))
    549     (ecase (first directory)
    550       ((nil) defaults)
    551       (:absolute specified)
    552       (:relative
    553        (let ((defdir (normalize-pathname-directory-component defaults))
    554              (reldir (cdr directory)))
    555          (cond
    556            ((null defdir)
    557             directory)
    558            ((not (eq :back (first reldir)))
    559             (append defdir reldir))
    560            (t
    561             (loop :with defabs = (first defdir)
    562               :with defrev = (reverse (rest defdir))
    563               :while (and (eq :back (car reldir))
    564                           (or (and (eq :absolute defabs) (null defrev))
    565                               (stringp (car defrev))))
    566               :do (pop reldir) (pop defrev)
    567               :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
    568 
    569 (defun* make-pathname-component-logical (x)
    570   "Make a pathname component suitable for use in a logical-pathname"
    571   (typecase x
    572     ((eql :unspecific) nil)
    573     #+clisp (string (string-upcase x))
    574     #+clisp (cons (mapcar 'make-pathname-component-logical x))
    575     (t x)))
    576 
    577 (defun* make-pathname-logical (pathname host)
    578   "Take a PATHNAME's directory, name, type and version components,
    579 and make a new pathname with corresponding components and specified logical HOST"
    580   (make-pathname
    581    :host host
    582    :directory (make-pathname-component-logical (pathname-directory pathname))
    583    :name (make-pathname-component-logical (pathname-name pathname))
    584    :type (make-pathname-component-logical (pathname-type pathname))
    585    :version (make-pathname-component-logical (pathname-version pathname))))
    586 
    587 (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
    588   "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
    589 if the SPECIFIED pathname does not have an absolute directory,
    590 then the HOST and DEVICE both come from the DEFAULTS, whereas
    591 if the SPECIFIED pathname does have an absolute directory,
    592 then the HOST and DEVICE both come from the SPECIFIED.
    593 Also, if either argument is NIL, then the other argument is returned unmodified."
    594   (when (null specified) (return-from merge-pathnames* defaults))
    595   (when (null defaults) (return-from merge-pathnames* specified))
    596   #+scl
    597   (ext:resolve-pathname specified defaults)
    598   #-scl
    599   (let* ((specified (pathname specified))
    600          (defaults (pathname defaults))
    601          (directory (normalize-pathname-directory-component (pathname-directory specified)))
    602          (name (or (pathname-name specified) (pathname-name defaults)))
    603          (type (or (pathname-type specified) (pathname-type defaults)))
    604          (version (or (pathname-version specified) (pathname-version defaults))))
    605     (labels ((unspecific-handler (p)
    606                (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
    607       (multiple-value-bind (host device directory unspecific-handler)
    608           (ecase (first directory)
    609             ((:absolute)
    610              (values (pathname-host specified)
    611                      (pathname-device specified)
    612                      directory
    613                      (unspecific-handler specified)))
    614             ((nil :relative)
    615              (values (pathname-host defaults)
    616                      (pathname-device defaults)
    617                      (merge-pathname-directory-components directory (pathname-directory defaults))
    618                      (unspecific-handler defaults))))
    619         (make-pathname :host host :device device :directory directory
    620                        :name (funcall unspecific-handler name)
    621                        :type (funcall unspecific-handler type)
    622                        :version (funcall unspecific-handler version))))))
    623 
    624 (defun* pathname-parent-directory-pathname (pathname)
    625   "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
    626 and NIL NAME, TYPE and VERSION components"
    627   (when pathname
    628     (make-pathname :name nil :type nil :version nil
    629                    :directory (merge-pathname-directory-components
    630                                '(:relative :back) (pathname-directory pathname))
    631                    :defaults pathname)))
    632 
    6331095(define-modify-macro appendf (&rest args)
    6341096  append "Append onto list") ;; only to be used on short lists.
    6351097
    636 (define-modify-macro orf (&rest args)
    637   or "or a flag")
     1098(defun* length=n-p (x n) ;is it that (= (length x) n) ?
     1099  (check-type n (integer 0 *))
     1100  (loop
     1101    :for l = x :then (cdr l)
     1102    :for i :downfrom n :do
     1103    (cond
     1104      ((zerop i) (return (null l)))
     1105      ((not (consp l)) (return nil)))))
     1106
     1107;;; remove a key from a plist, i.e. for keyword argument cleanup
     1108(defun* remove-plist-key (key plist)
     1109  "Remove a single key from a plist"
     1110  (loop* :for (k v) :on plist :by #'cddr
     1111    :unless (eq k key)
     1112    :append (list k v)))
     1113
     1114(defun* remove-plist-keys (keys plist)
     1115  "Remove a list of keys from a plist"
     1116  (loop* :for (k v) :on plist :by #'cddr
     1117    :unless (member k keys)
     1118    :append (list k v)))
     1119
     1120
     1121;;; Sequences
     1122(defun* emptyp (x)
     1123  "Predicate that is true for an empty sequence"
     1124  (or (null x) (and (vectorp x) (zerop (length x)))))
     1125
     1126
     1127;;; Strings
     1128(defun* strcat (&rest strings)
     1129  (apply 'concatenate 'string strings))
    6381130
    6391131(defun* first-char (s)
     
    6421134(defun* last-char (s)
    6431135  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))
    644 
    645 
    646 (defun* asdf-message (format-string &rest format-args)
    647   (declare (dynamic-extent format-args))
    648   (apply 'format *verbose-out* format-string format-args))
    6491136
    6501137(defun* split-string (string &key max (separator '(#\Space #\Tab)))
     
    6541141starting the separation from the end, e.g. when called with arguments
    6551142 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
    656   (catch nil
     1143  (block ()
    6571144    (let ((list nil) (words 0) (end (length string)))
    6581145      (flet ((separatorp (char) (find char separator))
    659              (done () (throw nil (cons (subseq string 0 end) list))))
     1146             (done () (return (cons (subseq string 0 end) list))))
    6601147        (loop
    6611148          :for start = (if (and max (>= words (1- max)))
     
    6681155          (setf end start))))))
    6691156
    670 (defun* split-name-type (filename)
    671   (let ((unspecific
    672          ;; Giving :unspecific as argument to make-pathname is not portable.
    673          ;; See CLHS make-pathname and 19.2.2.2.3.
    674          ;; We only use it on implementations that support it,
    675          #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
    676          #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil))
    677     (destructuring-bind (name &optional (type unspecific))
    678         (split-string filename :max 2 :separator ".")
    679       (if (equal name "")
    680           (values filename unspecific)
    681           (values name type)))))
    682 
    683 (defun* component-name-to-pathname-components (s &key force-directory force-relative)
    684   "Splits the path string S, returning three values:
    685 A flag that is either :absolute or :relative, indicating
    686    how the rest of the values are to be interpreted.
    687 A directory path --- a list of strings, suitable for
    688    use with MAKE-PATHNAME when prepended with the flag
    689    value.
    690 A filename with type extension, possibly NIL in the
    691    case of a directory pathname.
    692 FORCE-DIRECTORY forces S to be interpreted as a directory
    693 pathname \(third return value will be NIL, final component
    694 of S will be treated as part of the directory path.
    695 
    696 The intention of this function is to support structured component names,
    697 e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
    698 pathnames."
    699   (check-type s string)
    700   (when (find #\: s)
    701     (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
    702   (let* ((components (split-string s :separator "/"))
    703          (last-comp (car (last components))))
    704     (multiple-value-bind (relative components)
    705         (if (equal (first components) "")
    706             (if (equal (first-char s) #\/)
    707                 (progn
    708                   (when force-relative
    709                     (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
    710                   (values :absolute (cdr components)))
    711                 (values :relative nil))
    712           (values :relative components))
    713       (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
    714       (setf components (substitute :back ".." components :test #'equal))
     1157(defun* string-prefix-p (prefix string)
     1158  "Does STRING begin with PREFIX?"
     1159  (let* ((x (string prefix))
     1160         (y (string string))
     1161         (lx (length x))
     1162         (ly (length y)))
     1163    (and (<= lx ly) (string= x y :end2 lx))))
     1164
     1165(defun* string-suffix-p (string suffix)
     1166  "Does STRING end with SUFFIX?"
     1167  (let* ((x (string string))
     1168         (y (string suffix))
     1169         (lx (length x))
     1170         (ly (length y)))
     1171    (and (<= ly lx) (string= x y :start1 (- lx ly)))))
     1172
     1173(defun* string-enclosed-p (prefix string suffix)
     1174  "Does STRING begin with PREFIX and end with SUFFIX?"
     1175  (and (string-prefix-p prefix string)
     1176       (string-suffix-p string suffix)))
     1177
     1178
     1179;;; CLOS
     1180(defun* find-class* (x &optional (errorp t) environment)
     1181  (etypecase x
     1182    ((or standard-class built-in-class) x)
     1183    #+gcl2.6 (keyword nil)
     1184    (symbol (find-class x errorp environment))))
     1185
     1186
     1187;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity
     1188(deftype stamp () '(or real boolean))
     1189(defun* stamp< (x y)
     1190  (etypecase x
     1191    (null (and y t))
     1192    ((eql t) nil)
     1193    (real (etypecase y
     1194            (null nil)
     1195            ((eql t) t)
     1196            (real (< x y))))))
     1197(defun* stamps< (list) (loop :for y :in list :for x = nil :then y :always (stamp< x y)))
     1198(defun* stamp*< (&rest list) (stamps< list))
     1199(defun* stamp<= (x y) (not (stamp< y x)))
     1200(defun* earlier-stamp (x y) (if (stamp< x y) x y))
     1201(defun* stamps-earliest (list) (reduce 'earlier-stamp list :initial-value t))
     1202(defun* earliest-stamp (&rest list) (stamps-earliest list))
     1203(defun* later-stamp (x y) (if (stamp< x y) y x))
     1204(defun* stamps-latest (list) (reduce 'later-stamp list :initial-value nil))
     1205(defun* latest-stamp (&rest list) (stamps-latest list))
     1206(define-modify-macro latest-stamp-f (&rest stamps) latest-stamp)
     1207
     1208
     1209;;; Hash-tables
     1210(defun* list-to-hash-set (list &aux (h (make-hash-table :test 'equal)))
     1211  (dolist (x list h) (setf (gethash x h) t)))
     1212
     1213
     1214;;; Function designators
     1215(defun* ensure-function (fun &key (package :cl))
     1216  "Coerce the object FUN into a function.
     1217
     1218If FUN is a FUNCTION, return it.
     1219If the FUN is a non-sequence literal constant, return constantly that,
     1220i.e. for a boolean keyword character number or pathname.
     1221Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION.
     1222If FUN is a CONS, return the function that applies its CAR
     1223to the appended list of the rest of its CDR and the arguments.
     1224If FUN is a string, READ a form from it in the specified PACKAGE (default: CL)
     1225and EVAL that in a (FUNCTION ...) context."
     1226  (etypecase fun
     1227    (function fun)
     1228    ((or boolean keyword character number pathname) (constantly fun))
     1229    ((or function symbol) fun)
     1230    (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))
     1231    (string (eval `(function ,(with-standard-io-syntax
     1232                                (let ((*package* (find-package package)))
     1233                                  (read-from-string fun))))))))
     1234
     1235(defun* access-at (object at)
     1236  "Given an OBJECT and an AT specifier, list of successive accessors,
     1237call each accessor on the result of the previous calls.
     1238An accessor may be an integer, meaning a call to ELT,
     1239a keyword, meaning a call to GETF,
     1240NIL, meaning identity,
     1241a function or other symbol, meaning itself,
     1242or a list of a function designator and arguments, interpreted as per ENSURE-FUNCTION.
     1243As a degenerate case, the AT specifier may be an atom of a single such accessor
     1244instead of a list."
     1245  (flet ((access (object accessor)
     1246           (etypecase accessor
     1247             (function (funcall accessor object))
     1248             (integer (elt object accessor))
     1249             (keyword (getf object accessor))
     1250             (null object)
     1251             (symbol (funcall accessor object))
     1252             (cons (funcall (ensure-function accessor) object)))))
     1253    (if (listp at)
     1254        (dolist (accessor at object)
     1255          (setf object (access object accessor)))
     1256        (access object at))))
     1257
     1258(defun* access-at-count (at)
     1259  "From an AT specification, extract a COUNT of maximum number
     1260   of sub-objects to read as per ACCESS-AT"
     1261  (cond
     1262    ((integerp at)
     1263     (1+ at))
     1264    ((and (consp at) (integerp (first at)))
     1265     (1+ (first at)))))
     1266
     1267(defun* call-function (function-spec &rest arguments)
     1268  (apply (ensure-function function-spec) arguments))
     1269
     1270(defun* call-functions (function-specs)
     1271  (map () 'call-function function-specs))
     1272
     1273(defun* register-hook-function (variable hook &optional call-now-p)
     1274  (pushnew hook (symbol-value variable))
     1275  (when call-now-p (call-function hook)))
     1276
     1277
     1278;;; Version handling
     1279(eval-when (:compile-toplevel :load-toplevel :execute)
     1280(defun* unparse-version (version-list)
     1281  (format nil "~{~D~^.~}" version-list))
     1282
     1283(defun* parse-version (version-string &optional on-error)
     1284  "Parse a VERSION-STRING as a series of natural integers separated by dots.
     1285Return a (non-null) list of integers if the string is valid;
     1286otherwise return NIL.
     1287
     1288When invalid, ON-ERROR is called as per CALL-FUNCTION before to return NIL,
     1289with format arguments explaining why the version is invalid.
     1290ON-ERROR is also called if the version is not canonical
     1291in that it doesn't print back to itself, but the list is returned anyway."
     1292  (block nil
     1293   (unless (stringp version-string)
     1294     (call-function on-error "~S: ~S is not a string" 'parse-version version-string)
     1295     (return))
     1296   (unless (loop :for prev = nil :then c :for c :across version-string
     1297                 :always (or (digit-char-p c)
     1298                             (and (eql c #\.) prev (not (eql prev #\.))))
     1299                 :finally (return (and c (digit-char-p c))))
     1300     (call-function on-error "~S: ~S doesn't follow asdf version numbering convention"
     1301                    'parse-version version-string)
     1302     (return))
     1303   (let* ((version-list
     1304            (mapcar #'parse-integer (split-string version-string :separator ".")))
     1305          (normalized-version (unparse-version version-list)))
     1306     (unless (equal version-string normalized-version)
     1307       (call-function on-error "~S: ~S contains leading zeros" 'parse-version version-string))
     1308     version-list)))
     1309
     1310(defun* lexicographic< (< x y)
     1311  (cond ((null y) nil)
     1312        ((null x) t)
     1313        ((funcall < (car x) (car y)) t)
     1314        ((funcall < (car y) (car x)) nil)
     1315        (t (lexicographic< < (cdr x) (cdr y)))))
     1316
     1317(defun* lexicographic<= (< x y)
     1318  (not (lexicographic< < y x)))
     1319
     1320(defun* version< (version1 version2)
     1321  (let ((v1 (parse-version version1 nil))
     1322        (v2 (parse-version version2 nil)))
     1323    (lexicographic< '< v1 v2)))
     1324
     1325(defun* version<= (version1 version2)
     1326  (not (version< version2 version1)))
     1327
     1328(defun* version-compatible-p (provided-version required-version)
     1329  "Is the provided version a compatible substitution for the required-version?
     1330If major versions differ, it's not compatible.
     1331If they are equal, then any later version is compatible,
     1332with later being determined by a lexicographical comparison of minor numbers."
     1333  (let ((x (parse-version provided-version nil))
     1334        (y (parse-version required-version nil)))
     1335    (and x y (= (car x) (car y)) (lexicographic<= '< (cdr y) (cdr x)))))
     1336); eval-when for version support
     1337
     1338
     1339;;; Condition control
     1340
     1341(defvar *uninteresting-conditions* nil
     1342  "Uninteresting conditions, as per MATCH-CONDITION-P")
     1343
     1344(defparameter +simple-condition-format-control-slot+
     1345  #+abcl 'system::format-control
     1346  #+allegro 'excl::format-control
     1347  #+clisp 'system::$format-control
     1348  #+clozure 'ccl::format-control
     1349  #+(or cmu scl) 'conditions::format-control
     1350  #+ecl 'si::format-control
     1351  #+(or gcl lispworks) 'conditions::format-string
     1352  #+sbcl 'sb-kernel:format-control
     1353  #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil
     1354  "Name of the slot for FORMAT-CONTROL in simple-condition")
     1355
     1356(defun* match-condition-p (x condition)
     1357  "Compare received CONDITION to some pattern X:
     1358a symbol naming a condition class,
     1359a simple vector of length 2, arguments to find-symbol* with result as above,
     1360or a string describing the format-control of a simple-condition."
     1361  (etypecase x
     1362    (symbol (typep condition x))
     1363    ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
     1364    (function (funcall x condition))
     1365    (string (and (typep condition 'simple-condition)
     1366                 ;; On SBCL, it's always set and the check triggers a warning
     1367                 #+(or allegro clozure cmu lispworks scl)
     1368                 (slot-boundp condition +simple-condition-format-control-slot+)
     1369                 (ignore-errors (equal (simple-condition-format-control condition) x))))))
     1370
     1371(defun* match-any-condition-p (condition conditions)
     1372  "match CONDITION against any of the patterns of CONDITIONS supplied"
     1373  (loop :for x :in conditions :thereis (match-condition-p x condition)))
     1374
     1375(defun* call-with-muffled-conditions (thunk conditions)
     1376  (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions)
     1377                                    (muffle-warning c)))))
     1378    (funcall thunk)))
     1379
     1380(defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
     1381  `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions))
     1382
     1383
     1384;;;; ---------------------------------------------------------------------------
     1385;;;; Access to the Operating System
     1386
     1387(asdf/package:define-package :asdf/os
     1388  (:recycle :asdf/os :asdf)
     1389  (:use :asdf/common-lisp :asdf/package :asdf/utility)
     1390  (:export
     1391   #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features
     1392   #:getenv #:getenvp ;; environment variables
     1393   #:implementation-identifier ;; implementation identifier
     1394   #:implementation-type #:*implementation-type*
     1395   #:operating-system #:architecture #:lisp-version-string
     1396   #:hostname #:getcwd #:chdir
     1397   ;; Windows shortcut support
     1398   #:read-null-terminated-string #:read-little-endian
     1399   #:parse-file-location-info #:parse-windows-shortcut))
     1400(in-package :asdf/os)
     1401
     1402;;; Features
     1403(eval-when (:compile-toplevel :load-toplevel :execute)
     1404  (defun* featurep (x &optional (*features* *features*))
     1405    (cond
     1406      ((atom x) (and (member x *features*) t))
     1407      ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x))))
     1408      ((eq :or (car x)) (some #'featurep (cdr x)))
     1409      ((eq :and (car x)) (every #'featurep (cdr x)))
     1410      (t (error "Malformed feature specification ~S" x))))
     1411
     1412  (defun* os-unix-p ()
     1413    (or #+abcl (featurep :unix)
     1414        #+(and (not abcl) (or unix cygwin darwin)) t))
     1415
     1416  (defun* os-windows-p ()
     1417    (or #+abcl (featurep :windows)
     1418        #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
     1419
     1420  (defun* os-genera-p ()
     1421    (or #+genera t))
     1422
     1423  (defun* detect-os ()
     1424    (flet ((yes (yes) (pushnew yes *features*))
     1425           (no (no) (setf *features* (remove no *features*))))
    7151426      (cond
    716         ((equal last-comp "")
    717          (values relative components nil)) ; "" already removed
    718         (force-directory
    719          (values relative components nil))
    720         (t
    721          (values relative (butlast components) last-comp))))))
    722 
    723 (defun* remove-keys (key-names args)
    724   (loop :for (name val) :on args :by #'cddr
    725     :unless (member (symbol-name name) key-names
    726                     :key #'symbol-name :test 'equal)
    727     :append (list name val)))
    728 
    729 (defun* remove-keyword (key args)
    730   (loop :for (k v) :on args :by #'cddr
    731     :unless (eq k key)
    732     :append (list k v)))
     1427        ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
     1428        ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
     1429        ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
     1430        (t (error "Congratulations for trying XCVB on an operating system~%~
     1431that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
     1432
     1433  (detect-os))
     1434
     1435;;;; Environment variables: getting them, and parsing them.
    7331436
    7341437(defun* getenv (x)
     
    7551458            (unless (ccl:%null-ptr-p value)
    7561459              (ccl:%get-cstring value))))
    757   #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x)
     1460  #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x)
    7581461  #+sbcl (sb-ext:posix-getenv x)
    7591462  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
    7601463  (error "~S is not supported on your implementation" 'getenv))
    7611464
    762 (defun* directory-pathname-p (pathname)
    763   "Does PATHNAME represent a directory?
    764 
    765 A directory-pathname is a pathname _without_ a filename. The three
    766 ways that the filename components can be missing are for it to be NIL,
    767 :UNSPECIFIC or the empty string.
    768 
    769 Note that this does _not_ check to see that PATHNAME points to an
    770 actually-existing directory."
    771   (when pathname
    772     (let ((pathname (pathname pathname)))
    773       (flet ((check-one (x)
    774                (member x '(nil :unspecific "") :test 'equal)))
    775         (and (not (wild-pathname-p pathname))
    776              (check-one (pathname-name pathname))
    777              (check-one (pathname-type pathname))
    778              t)))))
    779 
    780 (defun* ensure-directory-pathname (pathspec)
    781   "Converts the non-wild pathname designator PATHSPEC to directory form."
    782   (cond
    783    ((stringp pathspec)
    784     (ensure-directory-pathname (pathname pathspec)))
    785    ((not (pathnamep pathspec))
    786     (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
    787    ((wild-pathname-p pathspec)
    788     (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
    789    ((directory-pathname-p pathspec)
    790     pathspec)
    791    (t
    792     (make-pathname :directory (append (or (pathname-directory pathspec)
    793                                           (list :relative))
    794                                       (list (file-namestring pathspec)))
    795                    :name nil :type nil :version nil
    796                    :defaults pathspec))))
    797 
    798 #+genera
    799 (unless (fboundp 'ensure-directories-exist)
    800   (defun* ensure-directories-exist (path)
    801     (fs:create-directories-recursively (pathname path))))
    802 
    803 (defun* absolute-pathname-p (pathspec)
    804   (and (typep pathspec '(or pathname string))
    805        (eq :absolute (car (pathname-directory (pathname pathspec))))))
    806 
    807 (defun* coerce-pathname (name &key type defaults)
    808   "coerce NAME into a PATHNAME.
    809 When given a string, portably decompose it into a relative pathname:
    810 #\\/ separates subdirectories. The last #\\/-separated string is as follows:
    811 if TYPE is NIL, its last #\\. if any separates name and type from from type;
    812 if TYPE is a string, it is the type, and the whole string is the name;
    813 if TYPE is :DIRECTORY, the string is a directory component;
    814 if the string is empty, it's a directory.
    815 Any directory named .. is read as :BACK.
    816 Host, device and version components are taken from DEFAULTS."
    817   ;; The defaults are required notably because they provide the default host
    818   ;; to the below make-pathname, which may crucially matter to people using
    819   ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
    820   ;; NOTE that the host and device slots will be taken from the defaults,
    821   ;; but that should only matter if you later merge relative pathnames with
    822   ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
    823   (etypecase name
    824     ((or null pathname)
    825      name)
    826     (symbol
    827      (coerce-pathname (string-downcase name) :type type :defaults defaults))
    828     (string
    829      (multiple-value-bind (relative path filename)
    830          (component-name-to-pathname-components name :force-directory (eq type :directory)
    831                                                 :force-relative t)
    832        (multiple-value-bind (name type)
    833            (cond
    834              ((or (eq type :directory) (null filename))
    835               (values nil nil))
    836              (type
    837               (values filename type))
    838              (t
    839               (split-name-type filename)))
    840          (apply 'make-pathname :directory (cons relative path) :name name :type type
    841                 (when defaults `(:defaults ,defaults))))))))
    842 
    843 (defun* merge-component-name-type (name &key type defaults)
    844   ;; For backwards compatibility only, for people using internals.
    845   ;; Will be removed in a future release, e.g. 2.016.
    846   (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
    847   (coerce-pathname name :type type :defaults defaults))
    848 
    849 (defun* subpathname (pathname subpath &key type)
    850   (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
    851                                   (pathname-directory-pathname pathname))))
    852 
    853 (defun subpathname* (pathname subpath &key type)
    854   (and pathname
    855        (subpathname (ensure-directory-pathname pathname) subpath :type type)))
    856 
    857 (defun* length=n-p (x n) ;is it that (= (length x) n) ?
    858   (check-type n (integer 0 *))
    859   (loop
    860     :for l = x :then (cdr l)
    861     :for i :downfrom n :do
    862     (cond
    863       ((zerop i) (return (null l)))
    864       ((not (consp l)) (return nil)))))
    865 
    866 (defun* string-suffix-p (s suffix)
    867   (check-type s string)
    868   (check-type suffix string)
    869   (let ((start (- (length s) (length suffix))))
    870     (and (<= 0 start)
    871          (string-equal s suffix :start1 start))))
    872 
    873 (defun* read-file-forms (file)
    874   (with-open-file (in file)
    875     (loop :with eof = (list nil)
    876      :for form = (read in nil eof)
    877      :until (eq form eof)
    878      :collect form)))
    879 
    880 (defun* pathname-root (pathname)
    881   (make-pathname :directory '(:absolute)
    882                  :name nil :type nil :version nil
    883                  :defaults pathname ;; host device, and on scl, *some*
    884                  ;; scheme-specific parts: port username password, not others:
    885                  . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
    886 
    887 (defun* probe-file* (p)
    888   "when given a pathname P, probes the filesystem for a file or directory
    889 with given pathname and if it exists return its truename."
    890   (etypecase p
    891     (null nil)
    892     (string (probe-file* (parse-namestring p)))
    893     (pathname (unless (wild-pathname-p p)
    894                 #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl)
    895                       '(probe-file p)
    896                       #+clisp (aif (find-symbol* '#:probe-pathname :ext)
    897                                    `(ignore-errors (,it p)))
    898                       '(ignore-errors (truename p)))))))
    899 
    900 (defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
    901   "Resolve as much of a pathname as possible"
    902   (block nil
    903     (when (typep pathname '(or null logical-pathname)) (return pathname))
    904     (let ((p (merge-pathnames* pathname defaults)))
    905       (when (typep p 'logical-pathname) (return p))
    906       (let ((found (probe-file* p)))
    907         (when found (return found)))
    908       (unless (absolute-pathname-p p)
    909         (let ((true-defaults (ignore-errors (truename defaults))))
    910           (when true-defaults
    911             (setf p (merge-pathnames pathname true-defaults)))))
    912       (unless (absolute-pathname-p p) (return p))
    913       (let ((sofar (probe-file* (pathname-root p))))
    914         (unless sofar (return p))
    915         (flet ((solution (directories)
    916                  (merge-pathnames*
    917                   (make-pathname :host nil :device nil
    918                                  :directory `(:relative ,@directories)
    919                                  :name (pathname-name p)
    920                                  :type (pathname-type p)
    921                                  :version (pathname-version p))
    922                   sofar)))
    923           (loop :with directory = (normalize-pathname-directory-component
    924                                    (pathname-directory p))
    925             :for component :in (cdr directory)
    926             :for rest :on (cdr directory)
    927             :for more = (probe-file*
    928                          (merge-pathnames*
    929                           (make-pathname :directory `(:relative ,component))
    930                           sofar)) :do
    931             (if more
    932                 (setf sofar more)
    933                 (return (solution rest)))
    934             :finally
    935             (return (solution nil))))))))
    936 
    937 (defun* resolve-symlinks (path)
    938   #-allegro (truenamize path)
    939   #+allegro (if (typep path 'logical-pathname)
    940                 path
    941                 (excl:pathname-resolve-symbolic-links path)))
    942 
    943 (defun* resolve-symlinks* (path)
    944   (if *resolve-symlinks*
    945       (and path (resolve-symlinks path))
    946       path))
    947 
    948 (defun* ensure-pathname-absolute (path)
    949   (cond
    950     ((absolute-pathname-p path) path)
    951     ((stringp path) (ensure-pathname-absolute (pathname path)))
    952     ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
    953     (t (let ((resolved (resolve-symlinks path)))
    954          (assert (absolute-pathname-p resolved))
    955          resolved))))
    956 
    957 (defun* default-directory ()
    958   (truenamize (pathname-directory-pathname *default-pathname-defaults*)))
    959 
    960 (defun* lispize-pathname (input-file)
    961   (make-pathname :type "lisp" :defaults input-file))
    962 
    963 (defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
    964 (defparameter *wild-file*
    965   (make-pathname :name *wild* :type *wild*
    966                  :version (or #-(or abcl xcl) *wild*) :directory nil))
    967 (defparameter *wild-directory*
    968   (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
    969 (defparameter *wild-inferiors*
    970   (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
    971 (defparameter *wild-path*
    972   (merge-pathnames *wild-file* *wild-inferiors*))
    973 
    974 (defun* wilden (path)
    975   (merge-pathnames* *wild-path* path))
    976 
    977 #-scl
    978 (defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
    979   (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
    980     (last-char (namestring foo))))
    981 
    982 #-scl
    983 (defun* directorize-pathname-host-device (pathname)
    984   (let* ((root (pathname-root pathname))
    985          (wild-root (wilden root))
    986          (absolute-pathname (merge-pathnames* pathname root))
    987          (separator (directory-separator-for-host root))
    988          (root-namestring (namestring root))
    989          (root-string
    990           (substitute-if #\/
    991                          #'(lambda (x) (or (eql x #\:)
    992                                            (eql x separator)))
    993                          root-namestring)))
    994     (multiple-value-bind (relative path filename)
    995         (component-name-to-pathname-components root-string :force-directory t)
    996       (declare (ignore relative filename))
    997       (let ((new-base
    998              (make-pathname :defaults root
    999                             :directory `(:absolute ,@path))))
    1000         (translate-pathname absolute-pathname wild-root (wilden new-base))))))
    1001 
    1002 #+scl
    1003 (defun* directorize-pathname-host-device (pathname)
    1004   (let ((scheme (ext:pathname-scheme pathname))
    1005         (host (pathname-host pathname))
    1006         (port (ext:pathname-port pathname))
    1007         (directory (pathname-directory pathname)))
    1008     (flet ((specificp (x) (and x (not (eq x :unspecific)))))
    1009       (if (or (specificp port)
    1010               (and (specificp host) (plusp (length host)))
    1011               (specificp scheme))
    1012         (let ((prefix ""))
    1013           (when (specificp port)
    1014             (setf prefix (format nil ":~D" port)))
    1015           (when (and (specificp host) (plusp (length host)))
    1016             (setf prefix (strcat host prefix)))
    1017           (setf prefix (strcat ":" prefix))
    1018           (when (specificp scheme)
    1019             (setf prefix (strcat scheme prefix)))
    1020           (assert (and directory (eq (first directory) :absolute)))
    1021           (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
    1022                          :defaults pathname)))
    1023     pathname)))
    1024 
    1025 ;;;; -------------------------------------------------------------------------
    1026 ;;;; ASDF Interface, in terms of generic functions.
    1027 (defgeneric* find-system (system &optional error-p))
    1028 (defgeneric* perform-with-restarts (operation component))
    1029 (defgeneric* perform (operation component))
    1030 (defgeneric* operation-done-p (operation component))
    1031 (defgeneric* mark-operation-done (operation component))
    1032 (defgeneric* explain (operation component))
    1033 (defgeneric* output-files (operation component))
    1034 (defgeneric* input-files (operation component))
    1035 (defgeneric* component-operation-time (operation component))
    1036 (defgeneric* operation-description (operation component)
    1037   (:documentation "returns a phrase that describes performing this operation
    1038 on this component, e.g. \"loading /a/b/c\".
    1039 You can put together sentences using this phrase."))
    1040 
    1041 (defgeneric* system-source-file (system)
    1042   (:documentation "Return the source file in which system is defined."))
    1043 
    1044 (defgeneric* component-system (component)
    1045   (:documentation "Find the top-level system containing COMPONENT"))
    1046 
    1047 (defgeneric* component-pathname (component)
    1048   (:documentation "Extracts the pathname applicable for a particular component."))
    1049 
    1050 (defgeneric* component-relative-pathname (component)
    1051   (:documentation "Returns a pathname for the component argument intended to be
    1052 interpreted relative to the pathname of that component's parent.
    1053 Despite the function's name, the return value may be an absolute
    1054 pathname, because an absolute pathname may be interpreted relative to
    1055 another pathname in a degenerate way."))
    1056 
    1057 (defgeneric* component-property (component property))
    1058 
    1059 (defgeneric* (setf component-property) (new-value component property))
    1060 
    1061 (defgeneric* component-external-format (component))
    1062 
    1063 (defgeneric* component-encoding (component))
    1064 
    1065 (eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
    1066   (defgeneric* (setf module-components-by-name) (new-value module)))
    1067 
    1068 (defgeneric* version-satisfies (component version))
    1069 
    1070 (defgeneric* find-component (base path)
    1071   (:documentation "Finds the component with PATH starting from BASE module;
    1072 if BASE is nil, then the component is assumed to be a system."))
    1073 
    1074 (defgeneric* source-file-type (component system))
    1075 
    1076 (defgeneric* operation-ancestor (operation)
    1077   (:documentation
    1078    "Recursively chase the operation's parent pointer until we get to
    1079 the head of the tree"))
    1080 
    1081 (defgeneric* component-visited-p (operation component)
    1082   (:documentation "Returns the value stored by a call to
    1083 VISIT-COMPONENT, if that has been called, otherwise NIL.
    1084 This value stored will be a cons cell, the first element
    1085 of which is a computed key, so not interesting.  The
    1086 CDR wil be the DATA value stored by VISIT-COMPONENT; recover
    1087 it as (cdr (component-visited-p op c)).
    1088   In the current form of ASDF, the DATA value retrieved is
    1089 effectively a boolean, indicating whether some operations are
    1090 to be performed in order to do OPERATION X COMPONENT.  If the
    1091 data value is NIL, the combination had been explored, but no
    1092 operations needed to be performed."))
    1093 
    1094 (defgeneric* visit-component (operation component data)
    1095   (:documentation "Record DATA as being associated with OPERATION
    1096 and COMPONENT.  This is a side-effecting function:  the association
    1097 will be recorded on the ROOT OPERATION \(OPERATION-ANCESTOR of the
    1098 OPERATION\).
    1099   No evidence that DATA is ever interesting, beyond just being
    1100 non-NIL.  Using the data field is probably very risky; if there is
    1101 already a record for OPERATION X COMPONENT, DATA will be quietly
    1102 discarded instead of recorded.
    1103   Starting with 2.006, TRAVERSE will store an integer in data,
    1104 so that nodes can be sorted in decreasing order of traversal."))
    1105 
    1106 
    1107 (defgeneric* (setf visiting-component) (new-value operation component))
    1108 
    1109 (defgeneric* component-visiting-p (operation component))
    1110 
    1111 (defgeneric* component-depends-on (operation component)
    1112   (:documentation
    1113    "Returns a list of dependencies needed by the component to perform
    1114     the operation.  A dependency has one of the following forms:
    1115 
    1116       (<operation> <component>*), where <operation> is a class
    1117         designator and each <component> is a component
    1118         designator, which means that the component depends on
    1119         <operation> having been performed on each <component>; or
    1120 
    1121       (FEATURE <feature>), which means that the component depends
    1122         on <feature>'s presence in *FEATURES*.
    1123 
    1124     Methods specialized on subclasses of existing component types
    1125     should usually append the results of CALL-NEXT-METHOD to the
    1126     list."))
    1127 
    1128 (defgeneric* component-self-dependencies (operation component))
    1129 
    1130 (defgeneric* traverse (operation component)
    1131   (:documentation
    1132 "Generate and return a plan for performing OPERATION on COMPONENT.
    1133 
    1134 The plan returned is a list of dotted-pairs. Each pair is the CONS
    1135 of ASDF operation object and a COMPONENT object. The pairs will be
    1136 processed in order by OPERATE."))
    1137 
    1138 
    1139 ;;;; -------------------------------------------------------------------------
    1140 ;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
    1141 (when *upgraded-p*
    1142   (when (find-class 'module nil)
    1143     (eval
    1144      '(defmethod update-instance-for-redefined-class :after
    1145           ((m module) added deleted plist &key)
    1146         (declare (ignorable deleted plist))
    1147         (when *asdf-verbose*
    1148           (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
    1149                         m (asdf-version)))
    1150         (when (member 'components-by-name added)
    1151           (compute-module-components-by-name m))
    1152         (when (typep m 'system)
    1153           (when (member 'source-file added)
    1154             (%set-system-source-file
    1155              (probe-asd (component-name m) (component-pathname m)) m)
    1156            (when (equal (component-name m) "asdf")
    1157              (setf (component-version m) *asdf-version*))))))))
    1158 
    1159 ;;;; -------------------------------------------------------------------------
    1160 ;;;; Classes, Conditions
    1161 
    1162 (define-condition system-definition-error (error) ()
    1163   ;; [this use of :report should be redundant, but unfortunately it's not.
    1164   ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function
    1165   ;; over print-object; this is always conditions::%print-condition for
    1166   ;; condition objects, which in turn does inheritance of :report options at
    1167   ;; run-time.  fortunately, inheritance means we only need this kludge here in
    1168   ;; order to fix all conditions that build on it.  -- rgr, 28-Jul-02.]
    1169   #+cmu (:report print-object))
    1170 
    1171 (define-condition formatted-system-definition-error (system-definition-error)
    1172   ((format-control :initarg :format-control :reader format-control)
    1173    (format-arguments :initarg :format-arguments :reader format-arguments))
    1174   (:report (lambda (c s)
    1175                (apply 'format s (format-control c) (format-arguments c)))))
    1176 
    1177 (define-condition load-system-definition-error (system-definition-error)
    1178   ((name :initarg :name :reader error-name)
    1179    (pathname :initarg :pathname :reader error-pathname)
    1180    (condition :initarg :condition :reader error-condition))
    1181   (:report (lambda (c s)
    1182              (format s (compatfmt "~@<Error while trying to load definition for system ~A from pathname ~A: ~3i~_~A~@:>")
    1183                      (error-name c) (error-pathname c) (error-condition c)))))
    1184 
    1185 (define-condition circular-dependency (system-definition-error)
    1186   ((components :initarg :components :reader circular-dependency-components))
    1187   (:report (lambda (c s)
    1188              (format s (compatfmt "~@<Circular dependency: ~3i~_~S~@:>")
    1189                      (circular-dependency-components c)))))
    1190 
    1191 (define-condition duplicate-names (system-definition-error)
    1192   ((name :initarg :name :reader duplicate-names-name))
    1193   (:report (lambda (c s)
    1194              (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
    1195                      (duplicate-names-name c)))))
    1196 
    1197 (define-condition missing-component (system-definition-error)
    1198   ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires)
    1199    (parent :initform nil :reader missing-parent :initarg :parent)))
    1200 
    1201 (define-condition missing-component-of-version (missing-component)
    1202   ((version :initform nil :reader missing-version :initarg :version)))
    1203 
    1204 (define-condition missing-dependency (missing-component)
    1205   ((required-by :initarg :required-by :reader missing-required-by)))
    1206 
    1207 (define-condition missing-dependency-of-version (missing-dependency
    1208                                                  missing-component-of-version)
    1209   ())
    1210 
    1211 (define-condition operation-error (error)
    1212   ((component :reader error-component :initarg :component)
    1213    (operation :reader error-operation :initarg :operation))
    1214   (:report (lambda (c s)
    1215                (format s (compatfmt "~@<Error while invoking ~A on ~A~@:>")
    1216                        (error-operation c) (error-component c)))))
    1217 (define-condition compile-error (operation-error) ())
    1218 (define-condition compile-failed (compile-error) ())
    1219 (define-condition compile-warned (compile-error) ())
    1220 
    1221 (define-condition invalid-configuration ()
    1222   ((form :reader condition-form :initarg :form)
    1223    (location :reader condition-location :initarg :location)
    1224    (format :reader condition-format :initarg :format)
    1225    (arguments :reader condition-arguments :initarg :arguments :initform nil))
    1226   (:report (lambda (c s)
    1227                (format s (compatfmt "~@<~? (will be skipped)~@:>")
    1228                        (condition-format c)
    1229                        (list* (condition-form c) (condition-location c)
    1230                               (condition-arguments c))))))
    1231 (define-condition invalid-source-registry (invalid-configuration warning)
    1232   ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    1233 (define-condition invalid-output-translation (invalid-configuration warning)
    1234   ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
    1235 
    1236 (defclass component ()
    1237   ((name :accessor component-name :initarg :name :type string :documentation
    1238          "Component name: designator for a string composed of portable pathname characters")
    1239    ;; We might want to constrain version with
    1240    ;; :type (and string (satisfies parse-version))
    1241    ;; but we cannot until we fix all systems that don't use it correctly!
    1242    (version :accessor component-version :initarg :version)
    1243    (description :accessor component-description :initarg :description)
    1244    (long-description :accessor component-long-description :initarg :long-description)
    1245    ;; This one below is used by POIU - http://www.cliki.net/poiu
    1246    ;; a parallelizing extension of ASDF that compiles in multiple parallel
    1247    ;; slave processes (forked on demand) and loads in the master process.
    1248    ;; Maybe in the future ASDF may use it internally instead of in-order-to.
    1249    (load-dependencies :accessor component-load-dependencies :initform nil)
    1250    ;; In the ASDF object model, dependencies exist between *actions*
    1251    ;; (an action is a pair of operation and component). They are represented
    1252    ;; alists of operations to dependencies (other actions) in each component.
    1253    ;; There are two kinds of dependencies, each stored in its own slot:
    1254    ;; in-order-to and do-first dependencies. These two kinds are related to
    1255    ;; the fact that some actions modify the filesystem,
    1256    ;; whereas other actions modify the current image, and
    1257    ;; this implies a difference in how to interpret timestamps.
    1258    ;; in-order-to dependencies will trigger re-performing the action
    1259    ;; when the timestamp of some dependency
    1260    ;; makes the timestamp of current action out-of-date;
    1261    ;; do-first dependencies do not trigger such re-performing.
    1262    ;; Therefore, a FASL must be recompiled if it is obsoleted
    1263    ;; by any of its FASL dependencies (in-order-to); but
    1264    ;; it needn't be recompiled just because one of these dependencies
    1265    ;; hasn't yet been loaded in the current image (do-first).
    1266    ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
    1267    ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
    1268    ;; Maybe rename the slots in ASDF? But that's not very backwards compatible.
    1269    ;; See our ASDF 2 paper for more complete explanations.
    1270    (in-order-to :initform nil :initarg :in-order-to
    1271                 :accessor component-in-order-to)
    1272    (do-first :initform nil :initarg :do-first
    1273              :accessor component-do-first)
    1274    ;; methods defined using the "inline" style inside a defsystem form:
    1275    ;; need to store them somewhere so we can delete them when the system
    1276    ;; is re-evaluated
    1277    (inline-methods :accessor component-inline-methods :initform nil)
    1278    (parent :initarg :parent :initform nil :reader component-parent)
    1279    ;; no direct accessor for pathname, we do this as a method to allow
    1280    ;; it to default in funky ways if not supplied
    1281    (relative-pathname :initarg :pathname)
    1282    ;; the absolute-pathname is computed based on relative-pathname...
    1283    (absolute-pathname)
    1284    (operation-times :initform (make-hash-table)
    1285                     :accessor component-operation-times)
    1286    (around-compile :initarg :around-compile)
    1287    (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
    1288    ;; XXX we should provide some atomic interface for updating the
    1289    ;; component properties
    1290    (properties :accessor component-properties :initarg :properties
    1291                :initform nil)))
    1292 
    1293 (defun* component-find-path (component)
    1294   (reverse
    1295    (loop :for c = component :then (component-parent c)
    1296      :while c :collect (component-name c))))
    1297 
    1298 (defmethod print-object ((c component) stream)
    1299   (print-unreadable-object (c stream :type t :identity nil)
    1300     (format stream "~{~S~^ ~}" (component-find-path c))))
    1301 
    1302 
    1303 ;;;; methods: conditions
    1304 
    1305 (defmethod print-object ((c missing-dependency) s)
    1306   (format s (compatfmt "~@<~A, required by ~A~@:>")
    1307           (call-next-method c nil) (missing-required-by c)))
    1308 
    1309 (defun* sysdef-error (format &rest arguments)
    1310   (error 'formatted-system-definition-error :format-control
    1311          format :format-arguments arguments))
    1312 
    1313 ;;;; methods: components
    1314 
    1315 (defmethod print-object ((c missing-component) s)
    1316   (format s (compatfmt "~@<Component ~S not found~@[ in ~A~]~@:>")
    1317           (missing-requires c)
    1318           (when (missing-parent c)
    1319             (coerce-name (missing-parent c)))))
    1320 
    1321 (defmethod print-object ((c missing-component-of-version) s)
    1322   (format s (compatfmt "~@<Component ~S does not match version ~A~@[ in ~A~]~@:>")
    1323           (missing-requires c)
    1324           (missing-version c)
    1325           (when (missing-parent c)
    1326             (coerce-name (missing-parent c)))))
    1327 
    1328 (defmethod component-system ((component component))
    1329   (aif (component-parent component)
    1330        (component-system it)
    1331        component))
    1332 
    1333 (defvar *default-component-class* 'cl-source-file)
    1334 
    1335 (defun* compute-module-components-by-name (module)
    1336   (let ((hash (make-hash-table :test 'equal)))
    1337     (setf (module-components-by-name module) hash)
    1338     (loop :for c :in (module-components module)
    1339       :for name = (component-name c)
    1340       :for previous = (gethash name (module-components-by-name module))
    1341       :do
    1342       (when previous
    1343         (error 'duplicate-names :name name))
    1344       :do (setf (gethash name (module-components-by-name module)) c))
    1345     hash))
    1346 
    1347 (defclass module (component)
    1348   ((components
    1349     :initform nil
    1350     :initarg :components
    1351     :accessor module-components)
    1352    (components-by-name
    1353     :accessor module-components-by-name)
    1354    ;; What to do if we can't satisfy a dependency of one of this module's
    1355    ;; components.  This allows a limited form of conditional processing.
    1356    (if-component-dep-fails
    1357     :initform :fail
    1358     :initarg :if-component-dep-fails
    1359     :accessor module-if-component-dep-fails)
    1360    (default-component-class
    1361     :initform nil
    1362     :initarg :default-component-class
    1363     :accessor module-default-component-class)))
    1364 
    1365 (defun* component-parent-pathname (component)
    1366   ;; No default anymore (in particular, no *default-pathname-defaults*).
    1367   ;; If you force component to have a NULL pathname, you better arrange
    1368   ;; for any of its children to explicitly provide a proper absolute pathname
    1369   ;; wherever a pathname is actually wanted.
    1370   (let ((parent (component-parent component)))
    1371     (when parent
    1372       (component-pathname parent))))
    1373 
    1374 (defmethod component-pathname ((component component))
    1375   (if (slot-boundp component 'absolute-pathname)
    1376       (slot-value component 'absolute-pathname)
    1377       (let ((pathname
    1378              (merge-pathnames*
    1379               (component-relative-pathname component)
    1380               (pathname-directory-pathname (component-parent-pathname component)))))
    1381         (unless (or (null pathname) (absolute-pathname-p pathname))
    1382           (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
    1383                  pathname (component-find-path component)))
    1384         (setf (slot-value component 'absolute-pathname) pathname)
    1385         pathname)))
    1386 
    1387 (defmethod component-property ((c component) property)
    1388   (cdr (assoc property (slot-value c 'properties) :test #'equal)))
    1389 
    1390 (defmethod (setf component-property) (new-value (c component) property)
    1391   (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
    1392     (if a
    1393         (setf (cdr a) new-value)
    1394         (setf (slot-value c 'properties)
    1395               (acons property new-value (slot-value c 'properties)))))
    1396   new-value)
    1397 
    1398 (defvar *default-encoding* :default
    1399   "Default encoding for source files.
    1400 The default value :default preserves the legacy behavior.
    1401 A future default might be :utf-8 or :autodetect
    1402 reading emacs-style -*- coding: utf-8 -*- specifications,
    1403 and falling back to utf-8 or latin1 if nothing is specified.")
    1404 
    1405 (defparameter *utf-8-external-format*
    1406   #+(and asdf-unicode (not clisp)) :utf-8
    1407   #+(and asdf-unicode clisp) charset:utf-8
    1408   #-asdf-unicode :default
    1409   "Default :external-format argument to pass to CL:OPEN and also
    1410 CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
    1411 On modern implementations, this will decode UTF-8 code points as CL characters.
    1412 On legacy implementations, it may fall back on some 8-bit encoding,
    1413 with non-ASCII code points being read as several CL characters;
    1414 hopefully, if done consistently, that won't affect program behavior too much.")
    1415 
    1416 (defun* always-default-encoding (pathname)
    1417   (declare (ignore pathname))
    1418   *default-encoding*)
    1419 
    1420 (defvar *encoding-detection-hook* #'always-default-encoding
    1421   "Hook for an extension to define a function to automatically detect a file's encoding")
    1422 
    1423 (defun* detect-encoding (pathname)
    1424   (funcall *encoding-detection-hook* pathname))
    1425 
    1426 (defmethod component-encoding ((c component))
    1427   (or (loop :for x = c :then (component-parent x)
    1428         :while x :thereis (%component-encoding x))
    1429       (detect-encoding (component-pathname c))))
    1430 
    1431 (defun* default-encoding-external-format (encoding)
    1432   (case encoding
    1433     (:default :default) ;; for backwards compatibility only. Explicit usage discouraged.
    1434     (:utf-8 *utf-8-external-format*)
    1435     (otherwise
    1436      (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
    1437      :default)))
    1438 
    1439 (defvar *encoding-external-format-hook*
    1440   #'default-encoding-external-format
    1441   "Hook for an extension to define a mapping between non-default encodings
    1442 and implementation-defined external-format's")
    1443 
    1444 (defun encoding-external-format (encoding)
    1445   (funcall *encoding-external-format-hook* encoding))
    1446 
    1447 (defmethod component-external-format ((c component))
    1448   (encoding-external-format (component-encoding c)))
    1449 
    1450 (defclass proto-system () ; slots to keep when resetting a system
    1451   ;; To preserve identity for all objects, we'd need keep the components slots
    1452   ;; but also to modify parse-component-form to reset the recycled objects.
    1453   ((name) #|(components) (components-by-names)|#))
    1454 
    1455 (defclass system (module proto-system)
    1456   (;; description and long-description are now available for all component's,
    1457    ;; but now also inherited from component, but we add the legacy accessor
    1458    (description :accessor system-description :initarg :description)
    1459    (long-description :accessor system-long-description :initarg :long-description)
    1460    (author :accessor system-author :initarg :author)
    1461    (maintainer :accessor system-maintainer :initarg :maintainer)
    1462    (licence :accessor system-licence :initarg :licence
    1463             :accessor system-license :initarg :license)
    1464    (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
    1465                 :writer %set-system-source-file)
    1466    (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
    1467 
    1468 ;;;; -------------------------------------------------------------------------
    1469 ;;;; version-satisfies
    1470 
    1471 (defmethod version-satisfies ((c component) version)
    1472   (unless (and version (slot-boundp c 'version))
    1473     (when version
    1474       (warn "Requested version ~S but component ~S has no version" version c))
    1475     (return-from version-satisfies t))
    1476   (version-satisfies (component-version c) version))
    1477 
    1478 (defun* asdf-version ()
    1479   "Exported interface to the version of ASDF currently installed. A string.
    1480 You can compare this string with e.g.:
    1481 (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
    1482   *asdf-version*)
    1483 
    1484 (defun* parse-version (string &optional on-error)
    1485   "Parse a version string as a series of natural integers separated by dots.
    1486 Return a (non-null) list of integers if the string is valid, NIL otherwise.
    1487 If on-error is error, warn, or designates a function of compatible signature,
    1488 the function is called with an explanation of what is wrong with the argument.
    1489 NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3"
    1490   (and
    1491    (or (stringp string)
    1492        (when on-error
    1493          (funcall on-error "~S: ~S is not a string"
    1494                   'parse-version string)) nil)
    1495    (or (loop :for prev = nil :then c :for c :across string
    1496          :always (or (digit-char-p c)
    1497                      (and (eql c #\.) prev (not (eql prev #\.))))
    1498          :finally (return (and c (digit-char-p c))))
    1499        (when on-error
    1500          (funcall on-error "~S: ~S doesn't follow asdf version numbering convention"
    1501                   'parse-version string)) nil)
    1502    (mapcar #'parse-integer (split-string string :separator "."))))
    1503 
    1504 (defmethod version-satisfies ((cver string) version)
    1505   (let ((x (parse-version cver 'warn))
    1506         (y (parse-version version 'warn)))
    1507     (labels ((bigger (x y)
    1508                (cond ((not y) t)
    1509                      ((not x) nil)
    1510                      ((> (car x) (car y)) t)
    1511                      ((= (car x) (car y))
    1512                       (bigger (cdr x) (cdr y))))))
    1513       (and x y (= (car x) (car y))
    1514            (or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
     1465(defun* getenvp (x)
     1466  "Predicate that is true if the named variable is present in the libc environment,
     1467then returning the non-empty string value of the variable"
     1468  (let ((g (getenv x))) (and (not (emptyp g)) g)))
     1469
     1470
     1471;;;; implementation-identifier
     1472;;
     1473;; produce a string to identify current implementation.
     1474;; Initially stolen from SLIME's SWANK, completely rewritten since.
     1475;; We're back to runtime checking, for the sake of e.g. ABCL.
     1476
     1477(defun* first-feature (feature-sets)
     1478  (dolist (x feature-sets)
     1479    (multiple-value-bind (short long feature-expr)
     1480        (if (consp x)
     1481            (values (first x) (second x) (cons :or (rest x)))
     1482            (values x x x))
     1483      (when (featurep feature-expr)
     1484        (return (values short long))))))
     1485
     1486(defun* implementation-type ()
     1487  (first-feature
     1488   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp)
     1489     (:cmu :cmucl :cmu) :ecl :gcl
     1490     (:lwpe :lispworks-personal-edition) (:lw :lispworks)
     1491     :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl)))
     1492
     1493(defvar *implementation-type* (implementation-type))
     1494
     1495(defun* operating-system ()
     1496  (first-feature
     1497   '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
     1498     (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
     1499     (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
     1500     (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
     1501     :genera)))
     1502
     1503(defun* architecture ()
     1504  (first-feature
     1505   '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386))
     1506     (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
     1507     (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
     1508     :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
     1509     :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
     1510     ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
     1511     ;; we may have to segregate the code still by architecture.
     1512     (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
     1513
     1514#+clozure
     1515(defun* ccl-fasl-version ()
     1516  ;; the fasl version is target-dependent from CCL 1.8 on.
     1517  (or (let ((s 'ccl::target-fasl-version))
     1518        (and (fboundp s) (funcall s)))
     1519      (and (boundp 'ccl::fasl-version)
     1520           (symbol-value 'ccl::fasl-version))
     1521      (error "Can't determine fasl version.")))
     1522
     1523(defun* lisp-version-string ()
     1524  (let ((s (lisp-implementation-version)))
     1525    (car ; as opposed to OR, this idiom prevents some unreachable code warning
     1526     (list
     1527      #+allegro
     1528      (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
     1529              excl::*common-lisp-version-number*
     1530              ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
     1531              (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
     1532              ;; Note if not using International ACL
     1533              ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
     1534              (excl:ics-target-case (:-ics "8"))
     1535              (and (member :smp *features*) "S"))
     1536      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
     1537      #+clisp
     1538      (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
     1539      #+clozure
     1540      (format nil "~d.~d-f~d" ; shorten for windows
     1541              ccl::*openmcl-major-version*
     1542              ccl::*openmcl-minor-version*
     1543              (logand (ccl-fasl-version) #xFF))
     1544      #+cmu (substitute #\- #\/ s)
     1545      #+scl (format nil "~A~A" s
     1546                    ;; ANSI upper case vs lower case.
     1547                    (ecase ext:*case-mode* (:upper "") (:lower "l")))
     1548      #+ecl (format nil "~A~@[-~A~]" s
     1549                    (let ((vcs-id (ext:lisp-implementation-vcs-id)))
     1550                      (subseq vcs-id 0 (min (length vcs-id) 8))))
     1551      #+gcl (subseq s (1+ (position #\space s)))
     1552      #+genera
     1553      (multiple-value-bind (major minor) (sct:get-system-version "System")
     1554        (format nil "~D.~D" major minor))
     1555      #+mcl (subseq s 8) ; strip the leading "Version "
     1556      s))))
     1557
     1558(defun* implementation-identifier ()
     1559  (substitute-if
     1560   #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
     1561   (format nil "~(~a~@{~@[-~a~]~}~)"
     1562           (or (implementation-type) (lisp-implementation-type))
     1563           (or (lisp-version-string) (lisp-implementation-version))
     1564           (or (operating-system) (software-type))
     1565           (or (architecture) (machine-type)))))
     1566
     1567
     1568;;;; Other system information
     1569
     1570(defun* hostname ()
     1571  ;; Note: untested on RMCL
     1572  #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
     1573  #+cormanlisp "localhost" ;; is there a better way? Does it matter?
     1574  #+allegro (symbol-call :excl.osi :gethostname)
     1575  #+clisp (first (split-string (machine-instance) :separator " "))
     1576  #+gcl (system:gethostname))
     1577
     1578
     1579;;; Current directory
     1580#+cmu
     1581(defun* parse-unix-namestring* (unix-namestring)
     1582  (multiple-value-bind (host device directory name type version)
     1583      (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring))
     1584    (make-pathname :host (or host lisp::*unix-host*) :device device
     1585                   :directory directory :name name :type type :version version)))
     1586
     1587(defun* getcwd ()
     1588  "Get the current working directory as per POSIX getcwd(3), as a pathname object"
     1589  (or #+abcl (parse-namestring
     1590              (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t)
     1591      #+allegro (excl::current-directory)
     1592      #+clisp (ext:default-directory)
     1593      #+clozure (ccl:current-directory)
     1594      #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring
     1595                      (strcat (nth-value 1 (unix:unix-current-directory)) "/"))
     1596      #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
     1597      #+ecl (ext:getcwd)
     1598      #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
     1599             (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines)))
     1600      #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
     1601      #+lispworks (system:current-directory)
     1602      #+mkcl (mk-ext:getcwd)
     1603      #+sbcl (sb-ext:parse-native-namestring (sb-unix:posix-getcwd/))
     1604      #+xcl (extensions:current-directory)
     1605      (error "getcwd not supported on your implementation")))
     1606
     1607(defun* chdir (x)
     1608  "Change current directory, as per POSIX chdir(2), to a given pathname object"
     1609  (if-let (x (pathname x))
     1610    (or #+abcl (java:jstatic "setProperty" "java.lang.System" "user.dir" (namestring x))
     1611        #+allegro (excl:chdir x)
     1612        #+clisp (ext:cd x)
     1613        #+clozure (setf (ccl:current-directory) x)
     1614        #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x))
     1615        #+cormanlisp (unless (zerop (win32::_chdir (namestring x)))
     1616                       (error "Could not set current directory to ~A" x))
     1617        #+ecl (ext:chdir x)
     1618        #+genera (setf *default-pathname-defaults* x)
     1619        #+lispworks (hcl:change-directory x)
     1620        #+mkcl (mk-ext:chdir x)
     1621        #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))
     1622        (error "chdir not supported on your implementation"))))
     1623
    15151624
    15161625;;;; -----------------------------------------------------------------
     
    15851694                    (read-sequence buffer s)
    15861695                    (map 'string #'code-char buffer)))))))
    1587       (end-of-file ()
     1696      (end-of-file (c)
     1697        (declare (ignore c))
    15881698        nil)))))
    15891699
     1700
    15901701;;;; -------------------------------------------------------------------------
    1591 ;;;; Finding systems
    1592 
    1593 (defun* make-defined-systems-table ()
    1594   (make-hash-table :test 'equal))
    1595 
    1596 (defvar *defined-systems* (make-defined-systems-table)
    1597   "This is a hash table whose keys are strings, being the
    1598 names of the systems, and whose values are pairs, the first
    1599 element of which is a universal-time indicating when the
    1600 system definition was last updated, and the second element
    1601 of which is a system object.")
    1602 
    1603 (defun* coerce-name (name)
    1604   (typecase name
    1605     (component (component-name name))
    1606     (symbol (string-downcase (symbol-name name)))
    1607     (string name)
    1608     (t (sysdef-error (compatfmt "~@<Invalid component designator: ~3i~_~A~@:>") name))))
    1609 
    1610 (defun* system-registered-p (name)
    1611   (gethash (coerce-name name) *defined-systems*))
    1612 
    1613 (defun* registered-systems ()
    1614   (loop :for (() . system) :being :the :hash-values :of *defined-systems*
    1615     :collect (coerce-name system)))
    1616 
    1617 (defun* register-system (system)
    1618   (check-type system system)
    1619   (let ((name (component-name system)))
    1620     (check-type name string)
    1621     (asdf-message (compatfmt "~&~@<; ~@;Registering ~3i~_~A~@:>~%") system)
    1622     (unless (eq system (cdr (gethash name *defined-systems*)))
    1623       (setf (gethash name *defined-systems*)
    1624             (cons (get-universal-time) system)))))
    1625 
    1626 (defun* clear-system (name)
    1627   "Clear the entry for a system in the database of systems previously loaded.
    1628 Note that this does NOT in any way cause the code of the system to be unloaded."
    1629   ;; There is no "unload" operation in Common Lisp, and
    1630   ;; a general such operation cannot be portably written,
    1631   ;; considering how much CL relies on side-effects to global data structures.
    1632   (remhash (coerce-name name) *defined-systems*))
    1633 
    1634 (defun* map-systems (fn)
    1635   "Apply FN to each defined system.
    1636 
    1637 FN should be a function of one argument. It will be
    1638 called with an object of type asdf:system."
    1639   (maphash #'(lambda (_ datum)
    1640                (declare (ignore _))
    1641                (destructuring-bind (_ . def) datum
    1642                  (declare (ignore _))
    1643                  (funcall fn def)))
    1644            *defined-systems*))
    1645 
    1646 ;;; for the sake of keeping things reasonably neat, we adopt a
    1647 ;;; convention that functions in this list are prefixed SYSDEF-
    1648 
    1649 (defvar *system-definition-search-functions* '())
    1650 
    1651 (setf *system-definition-search-functions*
    1652       (append
    1653        ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
    1654        (remove 'contrib-sysdef-search *system-definition-search-functions*)
    1655        ;; Tuck our defaults at the end of the list if they were absent.
    1656        ;; This is imperfect, in case they were removed on purpose,
    1657        ;; but then it will be the responsibility of whoever does that
    1658        ;; to upgrade asdf before he does such a thing rather than after.
    1659        (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
    1660                   '(sysdef-central-registry-search
    1661                     sysdef-source-registry-search
    1662                     sysdef-find-asdf))))
    1663 
    1664 (defun* search-for-system-definition (system)
    1665   (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
    1666         (cons 'find-system-if-being-defined
    1667               *system-definition-search-functions*)))
    1668 
    1669 (defvar *central-registry* nil
    1670 "A list of 'system directory designators' ASDF uses to find systems.
    1671 
    1672 A 'system directory designator' is a pathname or an expression
    1673 which evaluates to a pathname. For example:
    1674 
    1675     (setf asdf:*central-registry*
    1676           (list '*default-pathname-defaults*
    1677                 #p\"/home/me/cl/systems/\"
    1678                 #p\"/usr/share/common-lisp/systems/\"))
    1679 
    1680 This is for backward compatibilily.
    1681 Going forward, we recommend new users should be using the source-registry.
    1682 ")
    1683 
    1684 (defun* featurep (x &optional (features *features*))
     1702;;;; Portability layer around Common Lisp pathnames
     1703;; This layer allows for portable manipulation of pathname objects themselves,
     1704;; which all is necessary prior to any access the filesystem or environment.
     1705
     1706(asdf/package:define-package :asdf/pathname
     1707  (:recycle :asdf/pathname :asdf)
     1708  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os)
     1709  (:export
     1710   ;; Making and merging pathnames, portably
     1711   #:normalize-pathname-directory-component #:denormalize-pathname-directory-component
     1712   #:merge-pathname-directory-components #:*unspecific-pathname-type* #:make-pathname*
     1713   #:make-pathname-component-logical #:make-pathname-logical
     1714   #:merge-pathnames*
     1715   #:nil-pathname #:*nil-pathname* #:with-pathname-defaults
     1716   ;; Predicates
     1717   #:pathname-equal #:logical-pathname-p #:physical-pathname-p
     1718   #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p
     1719   ;; Directories
     1720   #:pathname-directory-pathname #:pathname-parent-directory-pathname
     1721   #:directory-pathname-p #:ensure-directory-pathname
     1722   ;; Parsing filenames
     1723   #:component-name-to-pathname-components
     1724   #:split-name-type #:parse-unix-namestring #:unix-namestring
     1725   #:split-unix-namestring-directory-components
     1726   ;; Absolute and relative pathnames
     1727   #:subpathname #:subpathname*
     1728   #:ensure-absolute-pathname
     1729   #:pathname-root #:pathname-host-pathname
     1730   #:subpathp
     1731   ;; Checking constraints
     1732   #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints
     1733   ;; Wildcard pathnames
     1734   #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* #:*wild-path* #:wilden
     1735   ;; Translate a pathname
     1736   #:relativize-directory-component #:relativize-pathname-directory
     1737   #:directory-separator-for-host #:directorize-pathname-host-device
     1738   #:translate-pathname*
     1739   #:*output-translation-function*))
     1740(in-package :asdf/pathname)
     1741
     1742;;; Normalizing pathnames across implementations
     1743
     1744(defun* normalize-pathname-directory-component (directory)
     1745  "Given a pathname directory component, return an equivalent form that is a list"
     1746  #+gcl2.6 (setf directory (substitute :back :parent directory))
    16851747  (cond
    1686     ((atom x)
    1687      (and (member x features) t))
    1688     ((eq :not (car x))
    1689      (assert (null (cddr x)))
    1690      (not (featurep (cadr x) features)))
    1691     ((eq :or (car x))
    1692      (some #'(lambda (x) (featurep x features)) (cdr x)))
    1693     ((eq :and (car x))
    1694      (every #'(lambda (x) (featurep x features)) (cdr x)))
     1748    #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
     1749    ((stringp directory) `(:absolute ,directory))
     1750    #+gcl2.6
     1751    ((and (consp directory) (eq :root (first directory)))
     1752     `(:absolute ,@(rest directory)))
     1753    ((or (null directory)
     1754         (and (consp directory) (member (first directory) '(:absolute :relative))))
     1755     directory)
     1756    #+gcl2.6
     1757    ((consp directory)
     1758     `(:relative ,@directory))
    16951759    (t
    1696      (error "Malformed feature specification ~S" x))))
    1697 
    1698 (defun* os-unix-p ()
    1699   (featurep '(:or :unix :cygwin :darwin)))
    1700 
    1701 (defun* os-windows-p ()
    1702   (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
    1703 
    1704 (defun* probe-asd (name defaults)
     1760     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
     1761
     1762(defun* denormalize-pathname-directory-component (directory-component)
     1763  #-gcl2.6 directory-component
     1764  #+gcl2.6
     1765  (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
     1766                          directory-component)))
     1767    (cond
     1768      ((and (consp d) (eq :relative (first d))) (rest d))
     1769      ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
     1770      (t d))))
     1771
     1772(defun* merge-pathname-directory-components (specified defaults)
     1773  ;; Helper for merge-pathnames* that handles directory components.
     1774  (let ((directory (normalize-pathname-directory-component specified)))
     1775    (ecase (first directory)
     1776      ((nil) defaults)
     1777      (:absolute specified)
     1778      (:relative
     1779       (let ((defdir (normalize-pathname-directory-component defaults))
     1780             (reldir (cdr directory)))
     1781         (cond
     1782           ((null defdir)
     1783            directory)
     1784           ((not (eq :back (first reldir)))
     1785            (append defdir reldir))
     1786           (t
     1787            (loop :with defabs = (first defdir)
     1788              :with defrev = (reverse (rest defdir))
     1789              :while (and (eq :back (car reldir))
     1790                          (or (and (eq :absolute defabs) (null defrev))
     1791                              (stringp (car defrev))))
     1792              :do (pop reldir) (pop defrev)
     1793              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
     1794
     1795;; Giving :unspecific as :type argument to make-pathname is not portable.
     1796;; See CLHS make-pathname and 19.2.2.2.3.
     1797;; This will be :unspecific if supported, or NIL if not.
     1798(defparameter *unspecific-pathname-type*
     1799  #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
     1800  #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)
     1801
     1802(defun* make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp)
     1803                              host (device () #+allegro devicep) name type version defaults
     1804                              #+scl &allow-other-keys)
     1805  "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
     1806   tries hard to make a pathname that will actually behave as documented,
     1807   despite the peculiarities of each implementation"
     1808  (declare (ignorable host device directory name type version defaults))
     1809  (apply 'make-pathname
     1810         (append
     1811          #+allegro (when (and devicep (null device)) `(:device :unspecific))
     1812          #+gcl2.6
     1813          (when directoryp
     1814            `(:directory ,(denormalize-pathname-directory-component directory)))
     1815          keys)))
     1816
     1817(defun* make-pathname-component-logical (x)
     1818  "Make a pathname component suitable for use in a logical-pathname"
     1819  (typecase x
     1820    ((eql :unspecific) nil)
     1821    #+clisp (string (string-upcase x))
     1822    #+clisp (cons (mapcar 'make-pathname-component-logical x))
     1823    (t x)))
     1824
     1825(defun* make-pathname-logical (pathname host)
     1826  "Take a PATHNAME's directory, name, type and version components,
     1827and make a new pathname with corresponding components and specified logical HOST"
     1828  (make-pathname*
     1829   :host host
     1830   :directory (make-pathname-component-logical (pathname-directory pathname))
     1831   :name (make-pathname-component-logical (pathname-name pathname))
     1832   :type (make-pathname-component-logical (pathname-type pathname))
     1833   :version (make-pathname-component-logical (pathname-version pathname))))
     1834
     1835(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
     1836  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
     1837if the SPECIFIED pathname does not have an absolute directory,
     1838then the HOST and DEVICE both come from the DEFAULTS, whereas
     1839if the SPECIFIED pathname does have an absolute directory,
     1840then the HOST and DEVICE both come from the SPECIFIED.
     1841This is what users want on a modern Unix or Windows operating system,
     1842unlike the MERGE-PATHNAME behavior.
     1843Also, if either argument is NIL, then the other argument is returned unmodified;
     1844this is unlike MERGE-PATHNAME which always merges with a pathname,
     1845by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL."
     1846  (when (null specified) (return-from merge-pathnames* defaults))
     1847  (when (null defaults) (return-from merge-pathnames* specified))
     1848  #+scl
     1849  (ext:resolve-pathname specified defaults)
     1850  #-scl
     1851  (let* ((specified (pathname specified))
     1852         (defaults (pathname defaults))
     1853         (directory (normalize-pathname-directory-component (pathname-directory specified)))
     1854         (name (or (pathname-name specified) (pathname-name defaults)))
     1855         (type (or (pathname-type specified) (pathname-type defaults)))
     1856         (version (or (pathname-version specified) (pathname-version defaults))))
     1857    (labels ((unspecific-handler (p)
     1858               (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
     1859      (multiple-value-bind (host device directory unspecific-handler)
     1860          (ecase (first directory)
     1861            ((:absolute)
     1862             (values (pathname-host specified)
     1863                     (pathname-device specified)
     1864                     directory
     1865                     (unspecific-handler specified)))
     1866            ((nil :relative)
     1867             (values (pathname-host defaults)
     1868                     (pathname-device defaults)
     1869                     (merge-pathname-directory-components directory (pathname-directory defaults))
     1870                     (unspecific-handler defaults))))
     1871        (make-pathname* :host host :device device :directory directory
     1872                        :name (funcall unspecific-handler name)
     1873                        :type (funcall unspecific-handler type)
     1874                        :version (funcall unspecific-handler version))))))
     1875
     1876(defun* nil-pathname (&optional (defaults *default-pathname-defaults*))
     1877  "A pathname that is as neutral as possible for use as defaults
     1878   when merging, making or parsing pathnames"
     1879  ;; 19.2.2.2.1 says a NIL host can mean a default host;
     1880  ;; see also "valid physical pathname host" in the CLHS glossary, that suggests
     1881  ;; strings and lists of strings or :unspecific
     1882  ;; But CMUCL decides to die on NIL.
     1883  #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
     1884                     :host (or #+cmu lisp::*unix-host*)
     1885                     #+scl ,@'(:scheme nil :scheme-specific-part nil
     1886                               :username nil :password nil :parameters nil :query nil :fragment nil)
     1887                     ;; the default shouldn't matter, but we really want something physical
     1888                     :defaults defaults))
     1889
     1890(defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
     1891
     1892(defmacro with-pathname-defaults ((&optional defaults) &body body)
     1893  `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body))
     1894
     1895
     1896;;; Some pathname predicates
     1897
     1898(defun* pathname-equal (p1 p2)
     1899  (when (stringp p1) (setf p1 (pathname p1)))
     1900  (when (stringp p2) (setf p2 (pathname p2)))
     1901  (flet ((normalize-component (x)
     1902           (unless (member x '(nil :unspecific :newest (:relative)) :test 'equal)
     1903             x)))
     1904    (macrolet ((=? (&rest accessors)
     1905                 (flet ((frob (x)
     1906                          (reduce 'list (cons 'normalize-component accessors)
     1907                                  :initial-value x :from-end t)))
     1908                   `(equal ,(frob 'p1) ,(frob 'p2)))))
     1909      (or (and (null p1) (null p2))
     1910          (and (pathnamep p1) (pathnamep p2)
     1911               (and (=? pathname-host)
     1912                    (=? pathname-device)
     1913                    (=? normalize-pathname-directory-component pathname-directory)
     1914                    (=? pathname-name)
     1915                    (=? pathname-type)
     1916                    (=? pathname-version)))))))
     1917
     1918(defun* logical-pathname-p (x)
     1919  (typep x 'logical-pathname))
     1920
     1921(defun* physical-pathname-p (x)
     1922  (and (pathnamep x) (not (logical-pathname-p x))))
     1923
     1924(defun* absolute-pathname-p (pathspec)
     1925  "If PATHSPEC is a pathname or namestring object that parses as a pathname
     1926possessing an :ABSOLUTE directory component, return the (parsed) pathname.
     1927Otherwise return NIL"
     1928  (and pathspec
     1929       (typep pathspec '(or null pathname string))
     1930       (let ((pathname (pathname pathspec)))
     1931         (and (eq :absolute (car (normalize-pathname-directory-component
     1932                                  (pathname-directory pathname))))
     1933              pathname))))
     1934
     1935(defun* relative-pathname-p (pathspec)
     1936  "If PATHSPEC is a pathname or namestring object that parses as a pathname
     1937possessing a :RELATIVE or NIL directory component, return the (parsed) pathname.
     1938Otherwise return NIL"
     1939  (and pathspec
     1940       (typep pathspec '(or null pathname string))
     1941       (let* ((pathname (pathname pathspec))
     1942              (directory (normalize-pathname-directory-component
     1943                          (pathname-directory pathname))))
     1944         (when (or (null directory) (eq :relative (car directory)))
     1945           pathname))))
     1946
     1947(defun* hidden-pathname-p (pathname)
     1948  "Return a boolean that is true if the pathname is hidden as per Unix style,
     1949i.e. its name starts with a dot."
     1950  (and pathname (equal (first-char (pathname-name pathname)) #\.)))
     1951
     1952(defun* file-pathname-p (pathname)
     1953  "Does PATHNAME represent a file, i.e. has a non-null NAME component?
     1954
     1955Accepts NIL, a string (converted through PARSE-NAMESTRING) or a PATHNAME.
     1956
     1957Note that this does _not_ check to see that PATHNAME points to an
     1958actually-existing file.
     1959
     1960Returns the (parsed) PATHNAME when true"
     1961  (when pathname
     1962    (let* ((pathname (pathname pathname))
     1963           (name (pathname-name pathname)))
     1964      (when (not (member name '(nil :unspecific "") :test 'equal))
     1965        pathname))))
     1966
     1967
     1968;;; Directory pathnames
     1969(defun* pathname-directory-pathname (pathname)
     1970  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
     1971and NIL NAME, TYPE and VERSION components"
     1972  (when pathname
     1973    (make-pathname :name nil :type nil :version nil :defaults pathname)))
     1974
     1975(defun* pathname-parent-directory-pathname (pathname)
     1976  "Returns a new pathname that corresponds to the parent of the current pathname's directory,
     1977i.e. removing one level of depth in the DIRECTORY component. e.g. if pathname is
     1978Unix pathname /foo/bar/baz/file.type then return /foo/bar/"
     1979  (when pathname
     1980    (make-pathname* :name nil :type nil :version nil
     1981                    :directory (merge-pathname-directory-components
     1982                                '(:relative :back) (pathname-directory pathname))
     1983                    :defaults pathname)))
     1984
     1985(defun* directory-pathname-p (pathname)
     1986  "Does PATHNAME represent a directory?
     1987
     1988A directory-pathname is a pathname _without_ a filename. The three
     1989ways that the filename components can be missing are for it to be NIL,
     1990:UNSPECIFIC or the empty string.
     1991
     1992Note that this does _not_ check to see that PATHNAME points to an
     1993actually-existing directory."
     1994  (when pathname
     1995    (let ((pathname (pathname pathname)))
     1996      (flet ((check-one (x)
     1997               (member x '(nil :unspecific "") :test 'equal)))
     1998        (and (not (wild-pathname-p pathname))
     1999             (check-one (pathname-name pathname))
     2000             (check-one (pathname-type pathname))
     2001             t)))))
     2002
     2003(defun* ensure-directory-pathname (pathspec &optional (on-error 'error))
     2004  "Converts the non-wild pathname designator PATHSPEC to directory form."
     2005  (cond
     2006   ((stringp pathspec)
     2007    (ensure-directory-pathname (pathname pathspec)))
     2008   ((not (pathnamep pathspec))
     2009    (call-function on-error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
     2010   ((wild-pathname-p pathspec)
     2011    (call-function on-error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
     2012   ((directory-pathname-p pathspec)
     2013    pathspec)
     2014   (t
     2015    (make-pathname* :directory (append (or (normalize-pathname-directory-component
     2016                                            (pathname-directory pathspec))
     2017                                           (list :relative))
     2018                                       (list (file-namestring pathspec)))
     2019                    :name nil :type nil :version nil :defaults pathspec))))
     2020
     2021
     2022;;; Parsing filenames
     2023(defun* split-unix-namestring-directory-components
     2024    (unix-namestring &key ensure-directory dot-dot)
     2025  "Splits the path string UNIX-NAMESTRING, returning four values:
     2026A flag that is either :absolute or :relative, indicating
     2027   how the rest of the values are to be interpreted.
     2028A directory path --- a list of strings and keywords, suitable for
     2029   use with MAKE-PATHNAME when prepended with the flag value.
     2030   Directory components with an empty name or the name . are removed.
     2031   Any directory named .. is read as DOT-DOT, or :BACK if it's NIL (not :UP).
     2032A last-component, either a file-namestring including type extension,
     2033   or NIL in the case of a directory pathname.
     2034A flag that is true iff the unix-style-pathname was just
     2035   a file-namestring without / path specification.
     2036ENSURE-DIRECTORY forces the namestring to be interpreted as a directory pathname:
     2037the third return value will be NIL, and final component of the namestring
     2038will be treated as part of the directory path.
     2039
     2040An empty string is thus read as meaning a pathname object with all fields nil.
     2041
     2042Note that : characters will NOT be interpreted as host specification.
     2043Absolute pathnames are only appropriate on Unix-style systems.
     2044
     2045The intention of this function is to support structured component names,
     2046e.g., \(:file \"foo/bar\"\), which will be unpacked to relative pathnames."
     2047  (check-type unix-namestring string)
     2048  (check-type dot-dot (member nil :back :up))
     2049  (if (and (not (find #\/ unix-namestring)) (not ensure-directory)
     2050           (plusp (length unix-namestring)))
     2051      (values :relative () unix-namestring t)
     2052      (let* ((components (split-string unix-namestring :separator "/"))
     2053             (last-comp (car (last components))))
     2054        (multiple-value-bind (relative components)
     2055            (if (equal (first components) "")
     2056                (if (equal (first-char unix-namestring) #\/)
     2057                    (values :absolute (cdr components))
     2058                    (values :relative nil))
     2059                (values :relative components))
     2060          (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal))
     2061                                      components))
     2062          (setf components (substitute (or dot-dot :back) ".." components :test #'equal))
     2063          (cond
     2064            ((equal last-comp "")
     2065             (values relative components nil nil)) ; "" already removed from components
     2066            (ensure-directory
     2067             (values relative components nil nil))
     2068            (t
     2069             (values relative (butlast components) last-comp nil)))))))
     2070
     2071(defun* split-name-type (filename)
     2072  "Split a filename into two values NAME and TYPE that are returned.
     2073We assume filename has no directory component.
     2074The last . if any separates name and type from from type,
     2075except that if there is only one . and it is in first position,
     2076the whole filename is the NAME with an empty type.
     2077NAME is always a string.
     2078For an empty type, *UNSPECIFIC-PATHNAME-TYPE* is returned."
     2079  (check-type filename string)
     2080  (assert (plusp (length filename)))
     2081  (destructuring-bind (name &optional (type *unspecific-pathname-type*))
     2082      (split-string filename :max 2 :separator ".")
     2083    (if (equal name "")
     2084        (values filename *unspecific-pathname-type*)
     2085        (values name type))))
     2086
     2087(defun* parse-unix-namestring (name &rest keys &key type defaults dot-dot ensure-directory
     2088                                    &allow-other-keys)
     2089  "Coerce NAME into a PATHNAME using standard Unix syntax.
     2090
     2091Unix syntax is used whether or not the underlying system is Unix;
     2092on such non-Unix systems it is only usable but for relative pathnames;
     2093but especially to manipulate relative pathnames portably, it is of crucial
     2094to possess a portable pathname syntax independent of the underlying OS.
     2095This is what PARSE-UNIX-NAMESTRING provides, and why we use it in ASDF.
     2096
     2097When given a PATHNAME object, just return it untouched.
     2098When given NIL, just return NIL.
     2099When given a non-null SYMBOL, first downcase its name and treat it as a string.
     2100When given a STRING, portably decompose it into a pathname as below.
     2101
     2102#\\/ separates directory components.
     2103
     2104The last #\\/-separated substring is interpreted as follows:
     21051- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true,
     2106 the string is made the last directory component, and NAME and TYPE are NIL.
     2107 if the string is empty, it's the empty pathname with all slots NIL.
     21082- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE
     2109 are separated by SPLIT-NAME-TYPE.
     21103- If TYPE is a string, it is the given TYPE, and the whole string is the NAME.
     2111
     2112Directory components with an empty name the name . are removed.
     2113Any directory named .. is read as DOT-DOT,
     2114which must be one of :BACK or :UP and defaults to :BACK.
     2115
     2116HOST, DEVICE and VERSION components are taken from DEFAULTS,
     2117which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL.
     2118No host or device can be specified in the string itself,
     2119which makes it unsuitable for absolute pathnames outside Unix.
     2120
     2121For relative pathnames, these components (and hence the defaults) won't matter
     2122if you use MERGE-PATHNAMES* but will matter if you use MERGE-PATHNAMES,
     2123which is an important reason to always use MERGE-PATHNAMES*.
     2124
     2125Arbitrary keys are accepted, and the parse result is passed to ENSURE-PATHNAME
     2126with those keys, removing TYPE DEFAULTS and DOT-DOT.
     2127When you're manipulating pathnames that are supposed to make sense portably
     2128even though the OS may not be Unixish, we recommend you use :WANT-RELATIVE T
     2129to throw an error if the pathname is absolute"
    17052130  (block nil
    1706     (when (directory-pathname-p defaults)
    1707       (let* ((file (probe-file* (subpathname defaults (strcat name ".asd")))))
    1708         (when file
    1709           (return file)))
    1710       #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
    1711       (when (os-windows-p)
    1712         (let ((shortcut
    1713                (make-pathname
    1714                 :defaults defaults :version :newest :case :local
    1715                 :name (strcat name ".asd")
    1716                 :type "lnk")))
    1717           (when (probe-file* shortcut)
    1718             (let ((target (parse-windows-shortcut shortcut)))
    1719               (when target
    1720                 (return (pathname target))))))))))
    1721 
    1722 (defun* sysdef-central-registry-search (system)
    1723   (let ((name (coerce-name system))
    1724         (to-remove nil)
    1725         (to-replace nil))
    1726     (block nil
    1727       (unwind-protect
    1728            (dolist (dir *central-registry*)
    1729              (let ((defaults (eval dir)))
    1730                (when defaults
    1731                  (cond ((directory-pathname-p defaults)
    1732                         (let ((file (probe-asd name defaults)))
    1733                           (when file
    1734                             (return file))))
    1735                        (t
    1736                         (restart-case
    1737                             (let* ((*print-circle* nil)
    1738                                    (message
    1739                                     (format nil
    1740                                             (compatfmt "~@<While searching for system ~S: ~3i~_~S evaluated to ~S which is not a directory.~@:>")
    1741                                             system dir defaults)))
    1742                               (error message))
    1743                           (remove-entry-from-registry ()
    1744                             :report "Remove entry from *central-registry* and continue"
    1745                             (push dir to-remove))
    1746                           (coerce-entry-to-directory ()
    1747                             :report (lambda (s)
    1748                                       (format s (compatfmt "~@<Coerce entry to ~a, replace ~a and continue.~@:>")
    1749                                               (ensure-directory-pathname defaults) dir))
    1750                             (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
    1751         ;; cleanup
    1752         (dolist (dir to-remove)
    1753           (setf *central-registry* (remove dir *central-registry*)))
    1754         (dolist (pair to-replace)
    1755           (let* ((current (car pair))
    1756                  (new (cdr pair))
    1757                  (position (position current *central-registry*)))
    1758             (setf *central-registry*
    1759                   (append (subseq *central-registry* 0 position)
    1760                           (list new)
    1761                           (subseq *central-registry* (1+ position))))))))))
    1762 
    1763 (defun* make-temporary-package ()
    1764   (flet ((try (counter)
    1765            (ignore-errors
    1766              (make-package (format nil "~A~D" :asdf counter)
    1767                            :use '(:cl :asdf)))))
    1768     (do* ((counter 0 (+ counter 1))
    1769           (package (try counter) (try counter)))
    1770          (package package))))
     2131    (check-type type (or null string (eql :directory)))
     2132    (when ensure-directory
     2133      (setf type :directory))
     2134    (etypecase name
     2135      ((or null pathname) (return name))
     2136      (symbol
     2137       (setf name (string-downcase name)))
     2138      (string))
     2139    (multiple-value-bind (relative path filename file-only)
     2140        (split-unix-namestring-directory-components
     2141         name :dot-dot dot-dot :ensure-directory (eq type :directory))
     2142      (multiple-value-bind (name type)
     2143          (cond
     2144            ((or (eq type :directory) (null filename))
     2145             (values nil nil))
     2146            (type
     2147             (values filename type))
     2148            (t
     2149             (split-name-type filename)))
     2150        (apply 'ensure-pathname
     2151               (make-pathname*
     2152                :directory (unless file-only (cons relative path))
     2153                :name name :type type
     2154                :defaults (or defaults *nil-pathname*))
     2155               (remove-plist-keys '(:type :dot-dot :defaults) keys))))))
     2156
     2157(defun* unix-namestring (pathname)
     2158  "Given a non-wild PATHNAME, return a Unix-style namestring for it.
     2159If the PATHNAME is NIL or a STRING, return it unchanged.
     2160
     2161This only considers the DIRECTORY, NAME and TYPE components of the pathname.
     2162This is a portable solution for representing relative pathnames,
     2163But unless you are running on a Unix system, it is not a general solution
     2164to representing native pathnames.
     2165
     2166An error is signaled if the argument is not NULL, a STRING or a PATHNAME,
     2167or if it is a PATHNAME but some of its components are not recognized."
     2168  (etypecase pathname
     2169    ((or null string) pathname)
     2170    (pathname
     2171     (with-output-to-string (s)
     2172       (flet ((err () (error "Not a valid unix-namestring ~S" pathname)))
     2173         (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname)))
     2174                (name (pathname-name pathname))
     2175                (type (pathname-type pathname))
     2176                (type (and (not (eq type :unspecific)) type)))
     2177           (cond
     2178             ((eq dir ()))
     2179             ((eq dir '(:relative)) (princ "./" s))
     2180             ((consp dir)
     2181              (destructuring-bind (relabs &rest dirs) dir
     2182                (or (member relabs '(:relative :absolute)) (err))
     2183                (when (eq relabs :absolute) (princ #\/ s))
     2184                (loop :for x :in dirs :do
     2185                  (cond
     2186                    ((member x '(:back :up)) (princ "../" s))
     2187                    ((equal x "") (err))
     2188                    ;;((member x '("." "..") :test 'equal) (err))
     2189                    ((stringp x) (format s "~A/" x))
     2190                    (t (err))))))
     2191             (t (err)))
     2192           (cond
     2193             (name
     2194              (or (and (stringp name) (or (null type) (stringp type))) (err))
     2195              (format s "~A~@[.~A~]" name type))
     2196             (t
     2197              (or (null type) (err))))))))))
     2198
     2199;;; Absolute and relative pathnames
     2200(defun* subpathname (pathname subpath &key type)
     2201  "This function takes a PATHNAME and a SUBPATH and a TYPE.
     2202If SUBPATH is already a PATHNAME object (not namestring),
     2203and is an absolute pathname at that, it is returned unchanged;
     2204otherwise, SUBPATH is turned into a relative pathname with given TYPE
     2205as per PARSE-UNIX-NAMESTRING with :WANT-RELATIVE T :TYPE TYPE,
     2206then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME."
     2207  (or (and (pathnamep subpath) (absolute-pathname-p subpath))
     2208      (merge-pathnames* (parse-unix-namestring subpath :type type :want-relative t)
     2209                        (pathname-directory-pathname pathname))))
     2210
     2211(defun* subpathname* (pathname subpath &key type)
     2212  "returns NIL if the base pathname is NIL, otherwise like SUBPATHNAME."
     2213  (and pathname
     2214       (subpathname (ensure-directory-pathname pathname) subpath :type type)))
     2215
     2216
     2217;;; Pathname host and its root
     2218(defun* pathname-root (pathname)
     2219  (make-pathname* :directory '(:absolute)
     2220                  :name nil :type nil :version nil
     2221                  :defaults pathname ;; host device, and on scl, *some*
     2222                  ;; scheme-specific parts: port username password, not others:
     2223                  . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
     2224
     2225(defun* pathname-host-pathname (pathname)
     2226  (make-pathname* :directory nil
     2227                  :name nil :type nil :version nil :device nil
     2228                  :defaults pathname ;; host device, and on scl, *some*
     2229                  ;; scheme-specific parts: port username password, not others:
     2230                  . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
     2231
     2232(defun* subpathp (maybe-subpath base-pathname)
     2233  (and (pathnamep maybe-subpath) (pathnamep base-pathname)
     2234       (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname)
     2235       (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname))
     2236       (pathname-equal (pathname-root maybe-subpath) (pathname-root base-pathname))
     2237       (with-pathname-defaults ()
     2238         (let ((enough (enough-namestring maybe-subpath base-pathname)))
     2239           (and (relative-pathname-p enough) (pathname enough))))))
     2240
     2241(defun* ensure-absolute-pathname (path &optional defaults (on-error 'error))
     2242  (cond
     2243    ((absolute-pathname-p path))
     2244    ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error))
     2245    ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path))
     2246    ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults))))
     2247       (or (if (absolute-pathname-p default-pathname)
     2248               (absolute-pathname-p (merge-pathnames* path default-pathname))
     2249               (call-function on-error "Default pathname ~S is not an absolute pathname"
     2250                              default-pathname))
     2251           (call-function on-error "Failed to merge ~S with ~S into an absolute pathname"
     2252                          path default-pathname))))
     2253    (t (call-function on-error
     2254                      "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S"
     2255                      path defaults))))
     2256
     2257
     2258;;; Wildcard pathnames
     2259(defparameter *wild* (or #+cormanlisp "*" :wild))
     2260(defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild))
     2261(defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors))
     2262(defparameter *wild-file*
     2263  (make-pathname :directory nil :name *wild* :type *wild*
     2264                 :version (or #-(or allegro abcl xcl) *wild*)))
     2265(defparameter *wild-directory*
     2266  (make-pathname* :directory `(:relative ,*wild-directory-component*)
     2267                  :name nil :type nil :version nil))
     2268(defparameter *wild-inferiors*
     2269  (make-pathname* :directory `(:relative ,*wild-inferiors-component*)
     2270                  :name nil :type nil :version nil))
     2271(defparameter *wild-path*
     2272  (merge-pathnames* *wild-file* *wild-inferiors*))
     2273
     2274(defun* wilden (path)
     2275  (merge-pathnames* *wild-path* path))
     2276
     2277
     2278;;; Translate a pathname
     2279(defun relativize-directory-component (directory-component)
     2280  (let ((directory (normalize-pathname-directory-component directory-component)))
     2281    (cond
     2282      ((stringp directory)
     2283       (list :relative directory))
     2284      ((eq (car directory) :absolute)
     2285       (cons :relative (cdr directory)))
     2286      (t
     2287       directory))))
     2288
     2289(defun* relativize-pathname-directory (pathspec)
     2290  (let ((p (pathname pathspec)))
     2291    (make-pathname*
     2292     :directory (relativize-directory-component (pathname-directory p))
     2293     :defaults p)))
     2294
     2295(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
     2296  (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname)))
     2297    (last-char (namestring foo))))
     2298
     2299#-scl
     2300(defun* directorize-pathname-host-device (pathname)
     2301  #+(or unix abcl)
     2302  (when (and #+abcl (os-unix-p) (physical-pathname-p pathname))
     2303    (return-from directorize-pathname-host-device pathname))
     2304  (let* ((root (pathname-root pathname))
     2305         (wild-root (wilden root))
     2306         (absolute-pathname (merge-pathnames* pathname root))
     2307         (separator (directory-separator-for-host root))
     2308         (root-namestring (namestring root))
     2309         (root-string
     2310          (substitute-if #\/
     2311                         #'(lambda (x) (or (eql x #\:)
     2312                                           (eql x separator)))
     2313                         root-namestring)))
     2314    (multiple-value-bind (relative path filename)
     2315        (split-unix-namestring-directory-components root-string :ensure-directory t)
     2316      (declare (ignore relative filename))
     2317      (let ((new-base
     2318             (make-pathname* :defaults root :directory `(:absolute ,@path))))
     2319        (translate-pathname absolute-pathname wild-root (wilden new-base))))))
     2320
     2321#+scl
     2322(defun* directorize-pathname-host-device (pathname)
     2323  (let ((scheme (ext:pathname-scheme pathname))
     2324        (host (pathname-host pathname))
     2325        (port (ext:pathname-port pathname))
     2326        (directory (pathname-directory pathname)))
     2327    (flet ((specificp (x) (and x (not (eq x :unspecific)))))
     2328      (if (or (specificp port)
     2329              (and (specificp host) (plusp (length host)))
     2330              (specificp scheme))
     2331        (let ((prefix ""))
     2332          (when (specificp port)
     2333            (setf prefix (format nil ":~D" port)))
     2334          (when (and (specificp host) (plusp (length host)))
     2335            (setf prefix (strcat host prefix)))
     2336          (setf prefix (strcat ":" prefix))
     2337          (when (specificp scheme)
     2338            (setf prefix (strcat scheme prefix)))
     2339          (assert (and directory (eq (first directory) :absolute)))
     2340          (make-pathname* :directory `(:absolute ,prefix ,@(rest directory))
     2341                          :defaults pathname)))
     2342    pathname)))
     2343
     2344(defun* (translate-pathname*) (path absolute-source destination &optional root source)
     2345  (declare (ignore source))
     2346  (cond
     2347    ((functionp destination)
     2348     (funcall destination path absolute-source))
     2349    ((eq destination t)
     2350     path)
     2351    ((not (pathnamep destination))
     2352     (error "Invalid destination"))
     2353    ((not (absolute-pathname-p destination))
     2354     (translate-pathname path absolute-source (merge-pathnames* destination root)))
     2355    (root
     2356     (translate-pathname (directorize-pathname-host-device path) absolute-source destination))
     2357    (t
     2358     (translate-pathname path absolute-source destination))))
     2359
     2360(defvar *output-translation-function* 'identity) ; Hook for output translations
     2361
     2362
     2363;;;; -------------------------------------------------------------------------
     2364;;;; Portability layer around Common Lisp filesystem access
     2365
     2366(asdf/package:define-package :asdf/filesystem
     2367  (:recycle :asdf/pathname :asdf)
     2368  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname)
     2369  (:export
     2370   ;; Native namestrings
     2371   #:native-namestring #:parse-native-namestring
     2372   ;; Probing the filesystem
     2373   #:truename* #:safe-file-write-date #:probe-file*
     2374   #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
     2375   #:collect-sub*directories
     2376   ;; Resolving symlinks somewhat
     2377   #:truenamize #:resolve-symlinks #:*resolve-symlinks* #:resolve-symlinks*
     2378   ;; merging with cwd
     2379   #:get-pathname-defaults #:call-with-current-directory #:with-current-directory
     2380   ;; Environment pathnames
     2381   #:inter-directory-separator #:split-native-pathnames-string
     2382   #:getenv-pathname #:getenv-pathnames
     2383   #:getenv-absolute-directory #:getenv-absolute-directories
     2384   #:lisp-implementation-directory #:lisp-implementation-pathname-p
     2385   ;; Simple filesystem operations
     2386   #:ensure-all-directories-exist
     2387   #:rename-file-overwriting-target
     2388   #:delete-file-if-exists))
     2389(in-package :asdf/filesystem)
     2390
     2391;;; Native namestrings, as seen by the operating system calls rather than Lisp
     2392(defun* native-namestring (x)
     2393  "From a non-wildcard CL pathname, a return namestring suitable for passing to the operating system"
     2394  (when x
     2395    (let ((p (pathname x)))
     2396      #+clozure (with-pathname-defaults () (ccl:native-translated-namestring p)) ; see ccl bug 978
     2397      #+(or cmu scl) (ext:unix-namestring p nil)
     2398      #+sbcl (sb-ext:native-namestring p)
     2399      #-(or clozure cmu sbcl scl)
     2400      (if (os-unix-p) (unix-namestring p)
     2401          (namestring p)))))
     2402
     2403(defun* parse-native-namestring (string &rest constraints &key ensure-directory &allow-other-keys)
     2404  "From a native namestring suitable for use by the operating system, return
     2405a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME"
     2406  (check-type string (or string null))
     2407  (let* ((pathname
     2408           (when string
     2409             (with-pathname-defaults ()
     2410               #+clozure (ccl:native-to-pathname string)
     2411               #+sbcl (sb-ext:parse-native-namestring string)
     2412               #-(or clozure sbcl)
     2413               (if (os-unix-p)
     2414                   (parse-unix-namestring string :ensure-directory ensure-directory)
     2415                   (parse-namestring string)))))
     2416         (pathname
     2417           (if ensure-directory
     2418               (and pathname (ensure-directory-pathname pathname))
     2419               pathname)))
     2420    (apply 'ensure-pathname pathname constraints)))
     2421
     2422
     2423;;; Probing the filesystem
     2424(defun* truename* (p)
     2425  ;; avoids both logical-pathname merging and physical resolution issues
     2426  (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil))))
    17712427
    17722428(defun* safe-file-write-date (pathname)
     
    17742430  ;; the user or some other agent has deleted an input file.
    17752431  ;; Also, generated files will not exist at the time planning is done
    1776   ;; and calls operation-done-p which calls safe-file-write-date.
     2432  ;; and calls compute-action-stamp which calls safe-file-write-date.
    17772433  ;; So it is very possible that we can't get a valid file-write-date,
    17782434  ;; and we can survive and we will continue the planning
    17792435  ;; as if the file were very old.
    17802436  ;; (or should we treat the case in a different, special way?)
    1781   (or (and pathname (probe-file* pathname) (ignore-errors (file-write-date pathname)))
    1782       (progn
    1783         (when (and pathname *asdf-verbose*)
    1784           (warn (compatfmt "~@<Missing FILE-WRITE-DATE for ~S, treating it as zero.~@:>")
    1785                 pathname))
    1786         0)))
    1787 
    1788 (defmethod find-system ((name null) &optional (error-p t))
    1789   (declare (ignorable name))
    1790   (when error-p
    1791     (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
    1792 
    1793 (defmethod find-system (name &optional (error-p t))
    1794   (find-system (coerce-name name) error-p))
    1795 
    1796 (defvar *systems-being-defined* nil
    1797   "A hash-table of systems currently being defined keyed by name, or NIL")
    1798 
    1799 (defun* find-system-if-being-defined (name)
    1800   (when *systems-being-defined*
    1801     (gethash (coerce-name name) *systems-being-defined*)))
    1802 
    1803 (defun* call-with-system-definitions (thunk)
    1804   (if *systems-being-defined*
    1805       (funcall thunk)
    1806       (let ((*systems-being-defined* (make-hash-table :test 'equal)))
    1807         (funcall thunk))))
    1808 
    1809 (defmacro with-system-definitions ((&optional) &body body)
    1810   `(call-with-system-definitions #'(lambda () ,@body)))
    1811 
    1812 (defun* load-sysdef (name pathname)
    1813   ;; Tries to load system definition with canonical NAME from PATHNAME.
    1814   (with-system-definitions ()
    1815     (let ((package (make-temporary-package)))
    1816       (unwind-protect
    1817            (handler-bind
    1818                ((error #'(lambda (condition)
    1819                            (error 'load-system-definition-error
    1820                                   :name name :pathname pathname
    1821                                   :condition condition))))
    1822              (let ((*package* package)
    1823                    (*default-pathname-defaults*
    1824                     ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
    1825                     (pathname-directory-pathname (translate-logical-pathname pathname)))
    1826                    (external-format (encoding-external-format (detect-encoding pathname))))
    1827                (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
    1828                              pathname package)
    1829                (load pathname :external-format external-format)))
    1830         (delete-package package)))))
    1831 
    1832 (defun* locate-system (name)
    1833   "Given a system NAME designator, try to locate where to load the system from.
    1834 Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
    1835 FOUNDP is true when a system was found,
    1836 either a new unregistered one or a previously registered one.
    1837 FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
    1838 PATHNAME when not null is a path from where to load the system,
    1839 either associated with FOUND-SYSTEM, or with the PREVIOUS system.
    1840 PREVIOUS when not null is a previously loaded SYSTEM object of same name.
    1841 PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
    1842   (let* ((name (coerce-name name))
    1843          (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
    1844          (previous (cdr in-memory))
    1845          (previous (and (typep previous 'system) previous))
    1846          (previous-time (car in-memory))
    1847          (found (search-for-system-definition name))
    1848          (found-system (and (typep found 'system) found))
    1849          (pathname (or (and (typep found '(or pathname string)) (pathname found))
    1850                        (and found-system (system-source-file found-system))
    1851                        (and previous (system-source-file previous))))
    1852          (foundp (and (or found-system pathname previous) t)))
    1853     (check-type found (or null pathname system))
    1854     (when foundp
    1855       (setf pathname (resolve-symlinks* pathname))
    1856       (when (and pathname (not (absolute-pathname-p pathname)))
    1857         (setf pathname (ensure-pathname-absolute pathname))
    1858         (when found-system
    1859           (%set-system-source-file pathname found-system)))
    1860       (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
    1861                                              (system-source-file previous) pathname)))
    1862         (%set-system-source-file pathname previous)
    1863         (setf previous-time nil))
    1864       (values foundp found-system pathname previous previous-time))))
    1865 
    1866 (defmethod find-system ((name string) &optional (error-p t))
    1867   (with-system-definitions ()
    1868     (loop
    1869       (restart-case
    1870           (multiple-value-bind (foundp found-system pathname previous previous-time)
    1871               (locate-system name)
    1872             (declare (ignore foundp))
    1873             (when (and found-system (not previous))
    1874               (register-system found-system))
    1875             (when (and pathname
    1876                        (or (not previous-time)
    1877                            ;; don't reload if it's already been loaded,
    1878                            ;; or its filestamp is in the future which means some clock is skewed
    1879                            ;; and trying to load might cause an infinite loop.
    1880                            (< previous-time (safe-file-write-date pathname) (get-universal-time))))
    1881               (load-sysdef name pathname))
    1882             (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
    1883               (return
    1884                 (cond
    1885                   (in-memory
    1886                    (when pathname
    1887                      (setf (car in-memory) (safe-file-write-date pathname)))
    1888                    (cdr in-memory))
    1889                   (error-p
    1890                    (error 'missing-component :requires name))))))
    1891         (reinitialize-source-registry-and-retry ()
    1892           :report (lambda (s)
    1893                     (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
    1894           (initialize-source-registry))))))
    1895 
    1896 (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
    1897   (setf fallback (coerce-name fallback)
    1898         requested (coerce-name requested))
    1899   (when (equal requested fallback)
    1900     (let ((registered (cdr (gethash fallback *defined-systems*))))
    1901       (or registered
    1902           (apply 'make-instance 'system
    1903                  :name fallback :source-file source-file keys)))))
    1904 
    1905 (defun* sysdef-find-asdf (name)
    1906   ;; Bug: :version *asdf-version* won't be updated when ASDF is updated.
    1907   (find-system-fallback name "asdf" :version *asdf-version*))
    1908 
    1909 
    1910 ;;;; -------------------------------------------------------------------------
    1911 ;;;; Finding components
    1912 
    1913 (defmethod find-component ((base string) path)
    1914   (let ((s (find-system base nil)))
    1915     (and s (find-component s path))))
    1916 
    1917 (defmethod find-component ((base symbol) path)
    1918   (cond
    1919     (base (find-component (coerce-name base) path))
    1920     (path (find-component path nil))
    1921     (t    nil)))
    1922 
    1923 (defmethod find-component ((base cons) path)
    1924   (find-component (car base) (cons (cdr base) path)))
    1925 
    1926 (defmethod find-component ((module module) (name string))
    1927   (unless (slot-boundp module 'components-by-name) ;; SBCL may miss the u-i-f-r-c method!!!
    1928     (compute-module-components-by-name module))
    1929   (values (gethash name (module-components-by-name module))))
    1930 
    1931 (defmethod find-component ((component component) (name symbol))
    1932   (if name
    1933       (find-component component (coerce-name name))
    1934       component))
    1935 
    1936 (defmethod find-component ((module module) (name cons))
    1937   (find-component (find-component module (car name)) (cdr name)))
    1938 
    1939 
    1940 ;;; component subclasses
    1941 
    1942 (defclass source-file (component)
    1943   ((type :accessor source-file-explicit-type :initarg :type :initform nil)))
    1944 
    1945 (defclass cl-source-file (source-file)
    1946   ((type :initform "lisp")))
    1947 (defclass cl-source-file.cl (cl-source-file)
    1948   ((type :initform "cl")))
    1949 (defclass cl-source-file.lsp (cl-source-file)
    1950   ((type :initform "lsp")))
    1951 (defclass c-source-file (source-file)
    1952   ((type :initform "c")))
    1953 (defclass java-source-file (source-file)
    1954   ((type :initform "java")))
    1955 (defclass static-file (source-file) ())
    1956 (defclass doc-file (static-file) ())
    1957 (defclass html-file (doc-file)
    1958   ((type :initform "html")))
    1959 
    1960 (defmethod source-file-type ((component module) (s module))
    1961   (declare (ignorable component s))
    1962   :directory)
    1963 (defmethod source-file-type ((component source-file) (s module))
    1964   (declare (ignorable s))
    1965   (source-file-explicit-type component))
    1966 
    1967 (defmethod component-relative-pathname ((component component))
    1968   (coerce-pathname
    1969    (or (slot-value component 'relative-pathname)
    1970        (component-name component))
    1971    :type (source-file-type component (component-system component))
    1972    :defaults (component-parent-pathname component)))
    1973 
    1974 ;;;; -------------------------------------------------------------------------
    1975 ;;;; Operations
    1976 
    1977 ;;; one of these is instantiated whenever #'operate is called
    1978 
    1979 (defclass operation ()
    1980   (;; as of danb's 2003-03-16 commit e0d02781, :force can be:
    1981    ;; T to force the inside of the specified system,
    1982    ;;   but not recurse to other systems we depend on.
    1983    ;; :ALL (or any other atom) to force all systems
    1984    ;;   including other systems we depend on.
    1985    ;; (SYSTEM1 SYSTEM2 ... SYSTEMN)
    1986    ;;   to force systems named in a given list
    1987    ;; However, but this feature has only ever worked but starting with ASDF 2.014.5
    1988    (forced :initform nil :initarg :force :accessor operation-forced)
    1989    (forced-not :initform nil :initarg :force-not :accessor operation-forced-not)
    1990    (original-initargs :initform nil :initarg :original-initargs
    1991                       :accessor operation-original-initargs)
    1992    (visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
    1993    (visiting-nodes :initform (make-hash-table :test 'equal) :accessor operation-visiting-nodes)
    1994    (parent :initform nil :initarg :parent :accessor operation-parent)))
    1995 
    1996 (defmethod print-object ((o operation) stream)
    1997   (print-unreadable-object (o stream :type t :identity t)
    1998     (ignore-errors
    1999       (prin1 (operation-original-initargs o) stream))))
    2000 
    2001 (defmethod shared-initialize :after ((operation operation) slot-names
    2002                                      &key force force-not
    2003                                      &allow-other-keys)
    2004   ;; the &allow-other-keys disables initarg validity checking
    2005   (declare (ignorable operation slot-names force force-not))
    2006   (macrolet ((frob (x) ;; normalize forced and forced-not slots
    2007                `(when (consp (,x operation))
    2008                   (setf (,x operation)
    2009                         (mapcar #'coerce-name (,x operation))))))
    2010     (frob operation-forced) (frob operation-forced-not))
    2011   (values))
    2012 
    2013 (defun* node-for (o c)
    2014   (cons (class-name (class-of o)) c))
    2015 
    2016 (defmethod operation-ancestor ((operation operation))
    2017   (aif (operation-parent operation)
    2018        (operation-ancestor it)
    2019        operation))
    2020 
    2021 
    2022 (defun* make-sub-operation (c o dep-c dep-o)
    2023   "C is a component, O is an operation, DEP-C is another
    2024 component, and DEP-O, confusingly enough, is an operation
    2025 class specifier, not an operation."
    2026   (let* ((args (copy-list (operation-original-initargs o)))
    2027          (force-p (getf args :force)))
    2028     ;; note explicit comparison with T: any other non-NIL force value
    2029     ;; (e.g. :recursive) will pass through
    2030     (cond ((and (null (component-parent c))
    2031                 (null (component-parent dep-c))
    2032                 (not (eql c dep-c)))
    2033            (when (eql force-p t)
    2034              (setf (getf args :force) nil))
    2035            (apply 'make-instance dep-o
    2036                   :parent o
    2037                   :original-initargs args args))
    2038           ((subtypep (type-of o) dep-o)
    2039            o)
    2040           (t
    2041            (apply 'make-instance dep-o
    2042                   :parent o :original-initargs args args)))))
    2043 
    2044 
    2045 (defmethod visit-component ((o operation) (c component) data)
    2046   (unless (component-visited-p o c)
    2047     (setf (gethash (node-for o c)
    2048                    (operation-visited-nodes (operation-ancestor o)))
    2049           (cons t data))))
    2050 
    2051 (defmethod component-visited-p ((o operation) (c component))
    2052   (gethash (node-for o c)
    2053            (operation-visited-nodes (operation-ancestor o))))
    2054 
    2055 (defmethod (setf visiting-component) (new-value operation component)
    2056   ;; MCL complains about unused lexical variables
    2057   (declare (ignorable operation component))
    2058   new-value)
    2059 
    2060 (defmethod (setf visiting-component) (new-value (o operation) (c component))
    2061   (let ((node (node-for o c))
    2062         (a (operation-ancestor o)))
    2063     (if new-value
    2064         (setf (gethash node (operation-visiting-nodes a)) t)
    2065         (remhash node (operation-visiting-nodes a)))
    2066     new-value))
    2067 
    2068 (defmethod component-visiting-p ((o operation) (c component))
    2069   (let ((node (node-for o c)))
    2070     (gethash node (operation-visiting-nodes (operation-ancestor o)))))
    2071 
    2072 (defmethod component-depends-on ((op-spec symbol) (c component))
    2073   ;; Note: we go from op-spec to operation via make-instance
    2074   ;; to allow for specialization through defmethod's, even though
    2075   ;; it's a detour in the default case below.
    2076   (component-depends-on (make-instance op-spec) c))
    2077 
    2078 (defmethod component-depends-on ((o operation) (c component))
    2079   (cdr (assoc (type-of o) (component-in-order-to c))))
    2080 
    2081 (defmethod component-self-dependencies ((o operation) (c component))
    2082   (remove-if-not
    2083    #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
    2084    (component-depends-on o c)))
    2085 
    2086 (defmethod input-files ((operation operation) (c component))
    2087   (let ((parent (component-parent c))
    2088         (self-deps (component-self-dependencies operation c)))
    2089     (if self-deps
    2090         (mapcan #'(lambda (dep)
    2091                     (destructuring-bind (op name) dep
    2092                       (output-files (make-instance op)
    2093                                     (find-component parent name))))
    2094                 self-deps)
    2095         ;; no previous operations needed?  I guess we work with the
    2096         ;; original source file, then
    2097         (list (component-pathname c)))))
    2098 
    2099 (defmethod input-files ((operation operation) (c module))
    2100   (declare (ignorable operation c))
    2101   nil)
    2102 
    2103 (defmethod component-operation-time (o c)
    2104   (gethash (type-of o) (component-operation-times c)))
    2105 
    2106 (defmethod operation-done-p ((o operation) (c component))
    2107   (let ((out-files (output-files o c))
    2108         (in-files (input-files o c))
    2109         (op-time (component-operation-time o c)))
    2110     (flet ((earliest-out ()
    2111              (reduce #'min (mapcar #'safe-file-write-date out-files)))
    2112            (latest-in ()
    2113              (reduce #'max (mapcar #'safe-file-write-date in-files))))
    2114       (cond
    2115         ((and (not in-files) (not out-files))
    2116          ;; arbitrary decision: an operation that uses nothing to
    2117          ;; produce nothing probably isn't doing much.
    2118          ;; e.g. operations on systems, modules that have no immediate action,
    2119          ;; but are only meaningful through traversed dependencies
    2120          t)
    2121         ((not out-files)
    2122          ;; an operation without output-files is probably meant
    2123          ;; for its side-effects in the current image,
    2124          ;; assumed to be idem-potent,
    2125          ;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
    2126          (and op-time (>= op-time (latest-in))))
    2127         ((not in-files)
    2128          ;; an operation with output-files and no input-files
    2129          ;; is probably meant for its side-effects on the file-system,
    2130          ;; assumed to have to be done everytime.
    2131          ;; (I don't think there is any such case in ASDF unless extended)
    2132          nil)
    2133         (t
    2134          ;; an operation with both input and output files is assumed
    2135          ;; as computing the latter from the former,
    2136          ;; assumed to have been done if the latter are all older
    2137          ;; than the former.
    2138          ;; e.g. COMPILE-OP of some CL-SOURCE-FILE.
    2139          ;; We use >= instead of > to play nice with generated files.
    2140          ;; This opens a race condition if an input file is changed
    2141          ;; after the output is created but within the same second
    2142          ;; of filesystem time; but the same race condition exists
    2143          ;; whenever the computation from input to output takes more
    2144          ;; than one second of filesystem time (or just crosses the
    2145          ;; second). So that's cool.
    2146          (and
    2147           (every #'probe-file* in-files)
    2148           (every #'probe-file* out-files)
    2149           (>= (earliest-out) (latest-in))))))))
    2150 
    2151 
    2152 
    2153 ;;; For 1.700 I've done my best to refactor TRAVERSE
    2154 ;;; by splitting it up in a bunch of functions,
    2155 ;;; so as to improve the collection and use-detection algorithm. --fare
    2156 ;;; The protocol is as follows: we pass around operation, dependency,
    2157 ;;; bunch of other stuff, and a force argument. Return a force flag.
    2158 ;;; The returned flag is T if anything has changed that requires a rebuild.
    2159 ;;; The force argument is a list of components that will require a rebuild
    2160 ;;; if the flag is T, at which point whoever returns the flag has to
    2161 ;;; mark them all as forced, and whoever recurses again can use a NIL list
    2162 ;;; as a further argument.
    2163 
    2164 (defvar *forcing* nil
    2165   "This dynamically-bound variable is used to force operations in
    2166 recursive calls to traverse.")
    2167 
    2168 (defgeneric* do-traverse (operation component collect))
    2169 
    2170 (defun* resolve-dependency-name (component name &optional version)
    2171   (loop
    2172     (restart-case
    2173         (return
    2174           (let ((comp (find-component (component-parent component) name)))
    2175             (unless comp
    2176               (error 'missing-dependency
    2177                      :required-by component
    2178                      :requires name))
    2179             (when version
    2180               (unless (version-satisfies comp version)
    2181                 (error 'missing-dependency-of-version
    2182                        :required-by component
    2183                        :version version
    2184                        :requires name)))
    2185             comp))
    2186       (retry ()
    2187         :report (lambda (s)
    2188                   (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
    2189         :test
    2190         (lambda (c)
    2191           (or (null c)
    2192               (and (typep c 'missing-dependency)
    2193                    (eq (missing-required-by c) component)
    2194                    (equal (missing-requires c) name))))))))
    2195 
    2196 (defun* resolve-dependency-spec (component dep-spec)
    2197   (cond
    2198     ((atom dep-spec)
    2199      (resolve-dependency-name component dep-spec))
    2200     ;; Structured dependencies --- this parses keywords.
    2201     ;; The keywords could conceivably be broken out and cleanly (extensibly)
    2202     ;; processed by EQL methods. But for now, here's what we've got.
    2203     ((eq :version (first dep-spec))
    2204      ;; https://bugs.launchpad.net/asdf/+bug/527788
    2205      (resolve-dependency-name component (second dep-spec) (third dep-spec)))
    2206     ((eq :feature (first dep-spec))
    2207      ;; This particular subform is not documented and
    2208      ;; has always been broken in the past.
    2209      ;; Therefore no one uses it, and I'm cerroring it out,
    2210      ;; after fixing it
    2211      ;; See https://bugs.launchpad.net/asdf/+bug/518467
    2212      (cerror "Continue nonetheless."
    2213              "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
    2214      (when (find (second dep-spec) *features* :test 'string-equal)
    2215        (resolve-dependency-name component (third dep-spec))))
    2216     (t
    2217      (error (compatfmt "~@<Bad dependency ~s.  Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
    2218 
    2219 (defun* do-one-dep (op c collect dep-op dep-c)
    2220   ;; Collects a partial plan for performing dep-op on dep-c
    2221   ;; as dependencies of a larger plan involving op and c.
    2222   ;; Returns t if this should force recompilation of those who depend on us.
    2223   ;; dep-op is an operation class name (not an operation object),
    2224   ;; whereas dep-c is a component object.n
    2225   (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
    2226 
    2227 (defun* do-dep (op c collect dep-op-spec dep-c-specs)
    2228   ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
    2229   ;; as dependencies of a larger plan involving op and c.
    2230   ;; Returns t if this should force recompilation of those who depend on us.
    2231   ;; dep-op-spec is either an operation class name (not an operation object),
    2232   ;; or the magic symbol asdf:feature.
    2233   ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
    2234   ;; and the plan will succeed if that keyword is present in *feature*,
    2235   ;; or fail if it isn't
    2236   ;; (at which point c's :if-component-dep-fails will kick in).
    2237   ;; If dep-op-spec is an operation class name,
    2238   ;; then dep-c-specs specifies a list of sibling component of c,
    2239   ;; as per resolve-dependency-spec, such that operating op on c
    2240   ;; depends on operating dep-op-spec on each of them.
    2241   (cond ((eq dep-op-spec 'feature)
    2242          (if (member (car dep-c-specs) *features*)
    2243              nil
    2244              (error 'missing-dependency
    2245                     :required-by c
    2246                     :requires (list :feature (car dep-c-specs)))))
    2247         (t
    2248          (let ((flag nil))
    2249            (dolist (d dep-c-specs)
    2250              (when (do-one-dep op c collect dep-op-spec
    2251                                (resolve-dependency-spec c d))
    2252                (setf flag t)))
    2253            flag))))
    2254 
    2255 (defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
    2256 
    2257 (defun* do-collect (collect x)
    2258   (funcall collect x))
    2259 
    2260 (defmethod do-traverse ((operation operation) (c component) collect)
    2261   (let ((*forcing* *forcing*)
    2262         (flag nil)) ;; return value: must we rebuild this and its dependencies?
    2263     (labels
    2264         ((update-flag (x)
    2265            (orf flag x))
    2266          (dep (op comp)
    2267            (update-flag (do-dep operation c collect op comp))))
    2268       ;; Have we been visited yet? If so, just process the result.
    2269       (aif (component-visited-p operation c)
    2270            (progn
    2271              (update-flag (cdr it))
    2272              (return-from do-traverse flag)))
    2273       ;; dependencies
    2274       (when (component-visiting-p operation c)
    2275         (error 'circular-dependency :components (list c)))
    2276       (setf (visiting-component operation c) t)
    2277       (unwind-protect
    2278            (block nil
    2279              (when (typep c 'system) ;; systems can be forced or forced-not
    2280                (let ((ancestor (operation-ancestor operation)))
    2281                  (flet ((match? (f)
    2282                           (and f (or (not (consp f)) ;; T or :ALL
    2283                                      (member (component-name c) f :test #'equal)))))
    2284                    (cond
    2285                      ((match? (operation-forced ancestor))
    2286                       (setf *forcing* t))
    2287                      ((match? (operation-forced-not ancestor))
    2288                       (return))))))
    2289              ;; first we check and do all the dependencies for the module.
    2290              ;; Operations planned in this loop will show up
    2291              ;; in the results, and are consumed below.
    2292              (let ((*forcing* nil))
    2293                ;; upstream dependencies are never forced to happen just because
    2294                ;; the things that depend on them are....
    2295                (loop
    2296                  :for (required-op . deps) :in (component-depends-on operation c)
    2297                  :do (dep required-op deps)))
    2298              ;; constituent bits
    2299              (let ((module-ops
    2300                     (when (typep c 'module)
    2301                       (let ((at-least-one nil)
    2302                             ;; This is set based on the results of the
    2303                             ;; dependencies and whether we are in the
    2304                             ;; context of a *forcing* call...
    2305                             ;; inter-system dependencies do NOT trigger
    2306                             ;; building components
    2307                             (*forcing*
    2308                              (or *forcing*
    2309                                  (and flag (not (typep c 'system)))))
    2310                             (error nil))
    2311                         (while-collecting (internal-collect)
    2312                           (dolist (kid (module-components c))
    2313                             (handler-case
    2314                                 (update-flag
    2315                                  (do-traverse operation kid #'internal-collect))
    2316                               #-genera
    2317                               (missing-dependency (condition)
    2318                                 (when (eq (module-if-component-dep-fails c)
    2319                                           :fail)
    2320                                   (error condition))
    2321                                 (setf error condition))
    2322                               (:no-error (c)
    2323                                 (declare (ignore c))
    2324                                 (setf at-least-one t))))
    2325                           (when (and (eq (module-if-component-dep-fails c)
    2326                                          :try-next)
    2327                                      (not at-least-one))
    2328                             (error error)))))))
    2329                (update-flag (or *forcing* (not (operation-done-p operation c))))
    2330                  ;; For sub-operations, check whether
    2331                  ;; the original ancestor operation was forced,
    2332                  ;; or names us amongst an explicit list of things to force...
    2333                  ;; except that this check doesn't distinguish
    2334                  ;; between all the things with a given name. Sigh.
    2335                  ;; BROKEN!
    2336                (when flag
    2337                  (let ((do-first (cdr (assoc (class-name (class-of operation))
    2338                                              (component-do-first c)))))
    2339                    (loop :for (required-op . deps) :in do-first
    2340                      :do (do-dep operation c collect required-op deps)))
    2341                  (do-collect collect (vector module-ops))
    2342                  (do-collect collect (cons operation c)))))
    2343         (setf (visiting-component operation c) nil)))
    2344     (visit-component operation c (when flag (incf *visit-count*)))
    2345     flag))
    2346 
    2347 (defun* flatten-tree (l)
    2348   ;; You collected things into a list.
    2349   ;; Most elements are just things to collect again.
    2350   ;; A (simple-vector 1) indicate that you should recurse into its contents.
    2351   ;; This way, in two passes (rather than N being the depth of the tree),
    2352   ;; you can collect things with marginally constant-time append,
    2353   ;; achieving linear time collection instead of quadratic time.
    2354   (while-collecting (c)
    2355     (labels ((r (x)
    2356                (if (typep x '(simple-vector 1))
    2357                    (r* (svref x 0))
    2358                    (c x)))
    2359              (r* (l)
    2360                (dolist (x l) (r x))))
    2361       (r* l))))
    2362 
    2363 (defmethod traverse ((operation operation) (c component))
    2364   (flatten-tree
    2365    (while-collecting (collect)
    2366      (let ((*visit-count* 0))
    2367        (do-traverse operation c #'collect)))))
    2368 
    2369 (defmethod perform ((operation operation) (c source-file))
    2370   (sysdef-error
    2371    (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>")
    2372    (class-of operation) (class-of c)))
    2373 
    2374 (defmethod perform ((operation operation) (c module))
    2375   (declare (ignorable operation c))
    2376   nil)
    2377 
    2378 (defmethod mark-operation-done ((operation operation) (c component))
    2379   (setf (gethash (type-of operation) (component-operation-times c))
    2380     (reduce #'max
    2381             (cons (get-universal-time)
    2382                   (mapcar #'safe-file-write-date (input-files operation c))))))
    2383 
    2384 (defmethod perform-with-restarts (operation component)
    2385   ;; TOO verbose, especially as the default. Add your own :before method
    2386   ;; to perform-with-restart or perform if you want that:
    2387   #|(when *asdf-verbose* (explain operation component))|#
    2388   (perform operation component))
    2389 
    2390 (defmethod perform-with-restarts :around (operation component)
    2391   (loop
    2392     (restart-case
    2393         (return (call-next-method))
    2394       (retry ()
    2395         :report
    2396         (lambda (s)
    2397           (format s (compatfmt "~@<Retry ~A.~@:>")
    2398                   (operation-description operation component))))
    2399       (accept ()
    2400         :report
    2401         (lambda (s)
    2402           (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
    2403                   (operation-description operation component)))
    2404         (mark-operation-done operation component)
    2405         (return)))))
    2406 
    2407 (defmethod explain ((operation operation) (component component))
    2408   (asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
    2409                 (operation-description operation component)))
    2410 
    2411 (defmethod operation-description (operation component)
    2412   (format nil (compatfmt "~@<~A on ~A~@:>")
    2413           (class-of operation) component))
    2414 
    2415 ;;;; -------------------------------------------------------------------------
    2416 ;;;; compile-op
    2417 
    2418 (defclass compile-op (operation)
    2419   ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
    2420    (on-warnings :initarg :on-warnings :accessor operation-on-warnings
    2421                 :initform *compile-file-warnings-behaviour*)
    2422    (on-failure :initarg :on-failure :accessor operation-on-failure
    2423                :initform *compile-file-failure-behaviour*)
    2424    (flags :initarg :flags :accessor compile-op-flags
    2425           :initform nil)))
    2426 
    2427 (defun* output-file (operation component)
    2428   "The unique output file of performing OPERATION on COMPONENT"
    2429   (let ((files (output-files operation component)))
    2430     (assert (length=n-p files 1))
    2431     (first files)))
    2432 
     2437  (handler-case (file-write-date (translate-logical-pathname pathname)) (file-error () nil)))
     2438
     2439(defun* probe-file* (p &key truename)
     2440  "when given a pathname P (designated by a string as per PARSE-NAMESTRING),
     2441probes the filesystem for a file or directory with given pathname.
     2442If it exists, return its truename is ENSURE-PATHNAME is true,
     2443or the original (parsed) pathname if it is false (the default)."
     2444  (with-pathname-defaults () ;; avoids logical-pathname issues on some implementations
     2445    (etypecase p
     2446      (null nil)
     2447      (string (probe-file* (parse-namestring p) :truename truename))
     2448      (pathname
     2449       (handler-case
     2450           (or
     2451            #+allegro
     2452            (probe-file p :follow-symlinks truename)
     2453            #-(or allegro clisp gcl2.6)
     2454            (if truename
     2455                (probe-file p)
     2456                (and (not (wild-pathname-p p))
     2457                     (ignore-errors
     2458                      (let ((pp (translate-logical-pathname p)))
     2459                        #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
     2460                        #+(and lispworks unix) (system:get-file-stat pp)
     2461                        #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
     2462                        #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)))
     2463                     p))
     2464            #+(or clisp gcl2.6)
     2465            #.(flet ((probe (probe)
     2466                       `(let ((foundtrue ,probe))
     2467                          (cond
     2468                            (truename foundtrue)
     2469                            (foundtrue p)))))
     2470                #+gcl2.6
     2471                (probe '(or (probe-file p)
     2472                         (and (directory-pathname-p p)
     2473                          (ignore-errors
     2474                           (ensure-directory-pathname
     2475                            (truename* (subpathname
     2476                                        (ensure-directory-pathname p) ".")))))))
     2477                #+clisp
     2478                (let* ((fs (find-symbol* '#:file-stat :posix nil))
     2479                       (pp (find-symbol* '#:probe-pathname :ext nil))
     2480                       (resolve (if pp
     2481                                    `(ignore-errors (,pp p))
     2482                                    '(or (truename* p)
     2483                                      (truename* (ignore-errors (ensure-directory-pathname p)))))))
     2484                  (if fs
     2485                      `(if truename
     2486                           ,resolve
     2487                           (and (ignore-errors (,fs p)) p))
     2488                      (probe resolve)))))
     2489         (file-error () nil))))))
     2490
     2491(defun* directory* (pathname-spec &rest keys &key &allow-other-keys)
     2492  (apply 'directory pathname-spec
     2493         (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
     2494                             #+clozure '(:follow-links nil)
     2495                             #+clisp '(:circle t :if-does-not-exist :ignore)
     2496                             #+(or cmu scl) '(:follow-links nil :truenamep nil)
     2497                             #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
     2498                                      '(:resolve-symlinks nil))))))
     2499
     2500(defun* filter-logical-directory-results (directory entries merger)
     2501  (if (logical-pathname-p directory)
     2502      ;; Try hard to not resolve logical-pathname into physical pathnames;
     2503      ;; otherwise logical-pathname users/lovers will be disappointed.
     2504      ;; If directory* could use some implementation-dependent magic,
     2505      ;; we will have logical pathnames already; otherwise,
     2506      ;; we only keep pathnames for which specifying the name and
     2507      ;; translating the LPN commute.
     2508      (loop :for f :in entries
     2509        :for p = (or (and (logical-pathname-p f) f)
     2510                     (let* ((u (ignore-errors (funcall merger f))))
     2511                       ;; The first u avoids a cumbersome (truename u) error.
     2512                       ;; At this point f should already be a truename,
     2513                       ;; but isn't quite in CLISP, for it doesn't have :version :newest
     2514                       (and u (equal (truename* u) (truename* f)) u)))
     2515        :when p :collect p)
     2516      entries))
     2517
     2518(defun* directory-files (directory &optional (pattern *wild-file*))
     2519  (let ((dir (pathname directory)))
     2520    (when (logical-pathname-p dir)
     2521      ;; Because of the filtering we do below,
     2522      ;; logical pathnames have restrictions on wild patterns.
     2523      ;; Not that the results are very portable when you use these patterns on physical pathnames.
     2524      (when (wild-pathname-p dir)
     2525        (error "Invalid wild pattern in logical directory ~S" directory))
     2526      (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
     2527        (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
     2528      (setf pattern (make-pathname-logical pattern (pathname-host dir))))
     2529    (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
     2530      (filter-logical-directory-results
     2531       directory entries
     2532       #'(lambda (f)
     2533           (make-pathname :defaults dir
     2534                          :name (make-pathname-component-logical (pathname-name f))
     2535                          :type (make-pathname-component-logical (pathname-type f))
     2536                          :version (make-pathname-component-logical (pathname-version f))))))))
     2537
     2538(defun* subdirectories (directory)
     2539  (let* ((directory (ensure-directory-pathname directory))
     2540         #-(or abcl cormanlisp genera xcl)
     2541         (wild (merge-pathnames*
     2542                #-(or abcl allegro cmu lispworks sbcl scl xcl)
     2543                *wild-directory*
     2544                #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
     2545                directory))
     2546         (dirs
     2547          #-(or abcl cormanlisp genera xcl)
     2548          (ignore-errors
     2549            (directory* wild . #.(or #+clozure '(:directories t :files nil)
     2550                                     #+mcl '(:directories t))))
     2551          #+(or abcl xcl) (system:list-directory directory)
     2552          #+cormanlisp (cl::directory-subdirs directory)
     2553          #+genera (fs:directory-list directory))
     2554         #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
     2555         (dirs (loop :for x :in dirs
     2556                 :for d = #+(or abcl xcl) (extensions:probe-directory x)
     2557                          #+allegro (excl:probe-directory x)
     2558                          #+(or cmu sbcl scl) (directory-pathname-p x)
     2559                          #+genera (getf (cdr x) :directory)
     2560                          #+lispworks (lw:file-directory-p x)
     2561                 :when d :collect #+(or abcl allegro xcl) d
     2562                                  #+genera (ensure-directory-pathname (first x))
     2563                                  #+(or cmu lispworks sbcl scl) x)))
     2564    (filter-logical-directory-results
     2565     directory dirs
     2566     (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
     2567                       '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
     2568       #'(lambda (d)
     2569           (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
     2570             (and (consp dir) (consp (cdr dir))
     2571                  (make-pathname
     2572                   :defaults directory :name nil :type nil :version nil
     2573                   :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
     2574
     2575(defun* collect-sub*directories (directory collectp recursep collector)
     2576  (when (funcall collectp directory)
     2577    (funcall collector directory))
     2578  (dolist (subdir (subdirectories directory))
     2579    (when (funcall recursep subdir)
     2580      (collect-sub*directories subdir collectp recursep collector))))
     2581
     2582;;; Resolving symlinks somewhat
     2583(defun* truenamize (pathname)
     2584  "Resolve as much of a pathname as possible"
     2585  (block nil
     2586    (when (typep pathname '(or null logical-pathname)) (return pathname))
     2587    (let ((p pathname))
     2588      (unless (absolute-pathname-p p)
     2589        (setf p (or (absolute-pathname-p (ensure-absolute-pathname p 'get-pathname-defaults nil))
     2590                    (return p))))
     2591      (when (logical-pathname-p p) (return p))
     2592      (let ((found (probe-file* p :truename t)))
     2593        (when found (return found)))
     2594      (let* ((directory (normalize-pathname-directory-component (pathname-directory p)))
     2595             (up-components (reverse (rest directory)))
     2596             (down-components ()))
     2597        (assert (eq :absolute (first directory)))
     2598        (loop :while up-components :do
     2599          (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components))
     2600                                                       :name nil :type nil :version nil :defaults p)))
     2601            (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components)
     2602                                                      :defaults p)
     2603                                      (ensure-directory-pathname parent)))
     2604            (push (pop up-components) down-components))
     2605          :finally (return p))))))
     2606
     2607(defun* resolve-symlinks (path)
     2608  #-allegro (truenamize path)
     2609  #+allegro
     2610  (if (physical-pathname-p path)
     2611      (or (ignore-errors (excl:pathname-resolve-symbolic-links path)) path)
     2612      path))
     2613
     2614(defvar *resolve-symlinks* t
     2615  "Determine whether or not ASDF resolves symlinks when defining systems.
     2616Defaults to T.")
     2617
     2618(defun* resolve-symlinks* (path)
     2619  (if *resolve-symlinks*
     2620      (and path (resolve-symlinks path))
     2621      path))
     2622
     2623
     2624;;; Check pathname constraints
     2625
     2626(defun* ensure-pathname
     2627    (pathname &key
     2628              on-error
     2629              defaults type dot-dot
     2630              want-pathname
     2631              want-logical want-physical ensure-physical
     2632              want-relative want-absolute ensure-absolute ensure-subpath
     2633              want-non-wild want-wild wilden
     2634              want-file want-directory ensure-directory
     2635              want-existing ensure-directories-exist
     2636              truename resolve-symlinks truenamize
     2637              &aux (p pathname)) ;; mutable working copy, preserve original
     2638  "Coerces its argument into a PATHNAME,
     2639optionally doing some transformations and checking specified constraints.
     2640
     2641If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified.
     2642
     2643If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING
     2644reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE;
     2645then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true,
     2646and the all the checks and transformations are run.
     2647
     2648Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE.
     2649The boolean T is an alias for ERROR.
     2650ERROR means that an error will be raised if the constraint is not satisfied.
     2651CERROR means that an continuable error will be raised if the constraint is not satisfied.
     2652IGNORE means just return NIL instead of the pathname.
     2653
     2654The ON-ERROR argument, if not NIL, is a function designator (as per CALL-FUNCTION)
     2655that will be called with the the following arguments:
     2656a generic format string for ensure pathname, the pathname,
     2657the keyword argument corresponding to the failed check or transformation,
     2658a format string for the reason ENSURE-PATHNAME failed,
     2659and a list with arguments to that format string.
     2660If ON-ERROR is NIL, ERROR is used instead, which does the right thing.
     2661You could also pass (CERROR \"CONTINUE DESPITE FAILED CHECK\").
     2662
     2663The transformations and constraint checks are done in this order,
     2664which is also the order in the lambda-list:
     2665
     2666WANT-PATHNAME checks that pathname (after parsing if needed) is not null.
     2667Otherwise, if the pathname is NIL, ensure-pathname returns NIL.
     2668WANT-LOGICAL checks that pathname is a LOGICAL-PATHNAME
     2669WANT-PHYSICAL checks that pathname is not a LOGICAL-PATHNAME
     2670ENSURE-PHYSICAL ensures that pathname is physical via TRANSLATE-LOGICAL-PATHNAME
     2671WANT-RELATIVE checks that pathname has a relative directory component
     2672WANT-ABSOLUTE checks that pathname does have an absolute directory component
     2673ENSURE-ABSOLUTE merges with the DEFAULTS, then checks again
     2674that the result absolute is an absolute pathname indeed.
     2675ENSURE-SUBPATH checks that the pathname is a subpath of the DEFAULTS.
     2676WANT-FILE checks that pathname has a non-nil FILE component
     2677WANT-DIRECTORY checks that pathname has nil FILE and TYPE components
     2678ENSURE-DIRECTORY uses ENSURE-DIRECTORY-PATHNAME to interpret
     2679any file and type components as being actually a last directory component.
     2680WANT-NON-WILD checks that pathname is not a wild pathname
     2681WANT-WILD checks that pathname is a wild pathname
     2682WILDEN merges the pathname with **/*.*.* if it is not wild
     2683WANT-EXISTING checks that a file (or directory) exists with that pathname.
     2684ENSURE-DIRECTORIES-EXIST creates any parent directory with ENSURE-DIRECTORIES-EXIST.
     2685TRUENAME replaces the pathname by its truename, or errors if not possible.
     2686RESOLVE-SYMLINKS replaces the pathname by a variant with symlinks resolved by RESOLVE-SYMLINKS.
     2687TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible."
     2688  (block nil
     2689    (flet ((report-error (keyword description &rest arguments)
     2690             (call-function (or on-error 'error)
     2691                            "Invalid pathname ~S: ~*~?"
     2692                            pathname keyword description arguments)))
     2693      (macrolet ((err (constraint &rest arguments)
     2694                   `(report-error ',(intern* constraint :keyword) ,@arguments))
     2695                 (check (constraint condition &rest arguments)
     2696                   `(when ,constraint
     2697                      (unless ,condition (err ,constraint ,@arguments))))
     2698                 (transform (transform condition expr)
     2699                   `(when ,transform
     2700                      (,@(if condition `(when ,condition) '(progn))
     2701                       (setf p ,expr)))))
     2702        (etypecase p
     2703          ((or null pathname))
     2704          (string
     2705           (setf p (parse-unix-namestring
     2706                    p :defaults defaults :type type :dot-dot dot-dot
     2707                    :ensure-directory ensure-directory :want-relative want-relative))))
     2708        (check want-pathname (pathnamep p) "Expected a pathname, not NIL")
     2709        (unless (pathnamep p) (return nil))
     2710        (check want-logical (logical-pathname-p p) "Expected a logical pathname")
     2711        (check want-physical (physical-pathname-p p) "Expected a physical pathname")
     2712        (transform ensure-physical () (translate-logical-pathname p))
     2713        (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
     2714        (check want-relative (relative-pathname-p p) "Expected a relative pathname")
     2715        (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
     2716        (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults))
     2717        (check ensure-absolute (absolute-pathname-p p)
     2718               "Could not make into an absolute pathname even after merging with ~S" defaults)
     2719        (check ensure-subpath (absolute-pathname-p defaults)
     2720               "cannot be checked to be a subpath of non-absolute pathname ~S" defaults)
     2721        (check ensure-subpath (subpathp p defaults) "is not a sub pathname of ~S" defaults)
     2722        (check want-file (file-pathname-p p) "Expected a file pathname")
     2723        (check want-directory (directory-pathname-p p) "Expected a directory pathname")
     2724        (transform ensure-directory (not (directory-pathname-p p)) (ensure-directory-pathname p))
     2725        (check want-non-wild (not (wild-pathname-p p)) "Expected a non-wildcard pathname")
     2726        (check want-wild (wild-pathname-p p) "Expected a wildcard pathname")
     2727        (transform wilden (not (wild-pathname-p p)) (wilden p))
     2728        (when want-existing
     2729          (let ((existing (probe-file* p :truename truename)))
     2730            (if existing
     2731                (when truename
     2732                  (return existing))
     2733                (err want-existing "Expected an existing pathname"))))
     2734        (when ensure-directories-exist (ensure-directories-exist p))
     2735        (when truename
     2736          (let ((truename (truename* p)))
     2737            (if truename
     2738                (return truename)
     2739                (err truename "Can't get a truename for pathname"))))
     2740        (transform resolve-symlinks () (resolve-symlinks p))
     2741        (transform truenamize () (truenamize p))
     2742        p))))
     2743
     2744
     2745;;; Pathname defaults
     2746(defun* get-pathname-defaults (&optional (defaults *default-pathname-defaults*))
     2747  (or (absolute-pathname-p defaults)
     2748      (merge-pathnames* defaults (getcwd))))
     2749
     2750(defun* call-with-current-directory (dir thunk)
     2751  (if dir
     2752      (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir))))
     2753             (*default-pathname-defaults* dir)
     2754             (cwd (getcwd)))
     2755        (chdir dir)
     2756        (unwind-protect
     2757             (funcall thunk)
     2758          (chdir cwd)))
     2759      (funcall thunk)))
     2760
     2761(defmacro with-current-directory ((&optional dir) &body body)
     2762  "Call BODY while the POSIX current working directory is set to DIR"
     2763  `(call-with-current-directory ,dir #'(lambda () ,@body)))
     2764
     2765
     2766;;; Environment pathnames
     2767(defun* inter-directory-separator ()
     2768  (if (os-unix-p) #\: #\;))
     2769
     2770(defun* split-native-pathnames-string (string &rest constraints &key &allow-other-keys)
     2771  (loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
     2772        :collect (apply 'parse-native-namestring namestring constraints)))
     2773
     2774(defun* getenv-pathname (x &rest constraints &key on-error &allow-other-keys)
     2775  (apply 'parse-native-namestring (getenvp x)
     2776         :on-error (or on-error
     2777                       `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
     2778         constraints))
     2779(defun* getenv-pathnames (x &rest constraints &key on-error &allow-other-keys)
     2780  (apply 'split-native-pathnames-string (getenvp x)
     2781         :on-error (or on-error
     2782                       `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x))
     2783         constraints))
     2784(defun* getenv-absolute-directory (x)
     2785  (getenv-pathname x :want-absolute t :ensure-directory t))
     2786(defun* getenv-absolute-directories (x)
     2787  (getenv-pathnames x :want-absolute t :ensure-directory t))
     2788
     2789(defun* lisp-implementation-directory (&key truename)
     2790  (declare (ignorable truename))
     2791  #+(or clozure ecl gcl mkcl sbcl)
     2792  (let ((dir
     2793          (ignore-errors
     2794           #+clozure #p"ccl:"
     2795           #+(or ecl mkcl) #p"SYS:"
     2796           #+gcl system::*system-directory*
     2797           #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil))
     2798                     (funcall it)
     2799                     (getenv-pathname "SBCL_HOME" :ensure-directory t)))))
     2800    (if (and dir truename)
     2801        (truename* dir)
     2802        dir)))
     2803
     2804(defun* lisp-implementation-pathname-p (pathname)
     2805  ;; Other builtin systems are those under the implementation directory
     2806  (and (when pathname
     2807         (if-let (impdir (lisp-implementation-directory))
     2808           (or (subpathp pathname impdir)
     2809               (when *resolve-symlinks*
     2810                 (if-let (truename (truename* pathname))
     2811                   (if-let (trueimpdir (truename* impdir))
     2812                     (subpathp truename trueimpdir)))))))
     2813       t))
     2814
     2815
     2816;;; Simple filesystem operations
    24332817(defun* ensure-all-directories-exist (pathnames)
    24342818   (dolist (pathname pathnames)
    24352819     (ensure-directories-exist (translate-logical-pathname pathname))))
    24362820
    2437 (defmethod perform :before ((operation compile-op) (c source-file))
    2438   (ensure-all-directories-exist (output-files operation c)))
    2439 
    2440 (defmethod perform :after ((operation operation) (c component))
    2441   (mark-operation-done operation c))
    2442 
    2443 (defgeneric* around-compile-hook (component))
    2444 (defgeneric* call-with-around-compile-hook (component thunk))
    2445 
    2446 (defmethod around-compile-hook ((c component))
     2821(defun* rename-file-overwriting-target (source target)
     2822  #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
     2823  (posix:copy-file source target :method :rename)
     2824  #-clisp
     2825  (rename-file source target
     2826               #+clozure :if-exists #+clozure :rename-and-delete))
     2827
     2828(defun* delete-file-if-exists (x)
     2829  (when x (handler-case (delete-file x) (file-error () nil))))
     2830
     2831
     2832;;;; ---------------------------------------------------------------------------
     2833;;;; Utilities related to streams
     2834
     2835(asdf/package:define-package :asdf/stream
     2836  (:recycle :asdf/stream)
     2837  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname :asdf/filesystem)
     2838  (:export
     2839   #:*default-stream-element-type* #:*stderr* #:setup-stderr
     2840   #:with-safe-io-syntax #:call-with-safe-io-syntax
     2841   #:with-output #:output-string #:with-input
     2842   #:with-input-file #:call-with-input-file
     2843   #:finish-outputs #:format! #:safe-format!
     2844   #:copy-stream-to-stream #:concatenate-files
     2845   #:copy-stream-to-stream-line-by-line
     2846   #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
     2847   #:slurp-stream-forms #:slurp-stream-form
     2848   #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
     2849   #:eval-input #:eval-thunk #:standard-eval-thunk
     2850   #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
     2851   #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
     2852   #:*default-encoding* #:*utf-8-external-format*
     2853   ;; Temporary files
     2854   #:*temporary-directory* #:temporary-directory #:default-temporary-directory
     2855   #:setup-temporary-directory
     2856   #:call-with-temporary-file #:with-temporary-file
     2857   #:add-pathname-suffix #:tmpize-pathname
     2858   #:call-with-staging-pathname #:with-staging-pathname))
     2859(in-package :asdf/stream)
     2860
     2861(defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
     2862  "default element-type for open (depends on the current CL implementation)")
     2863
     2864(defvar *stderr* *error-output*
     2865  "the original error output stream at startup")
     2866
     2867(defun setup-stderr ()
     2868  (setf *stderr*
     2869        #+allegro excl::*stderr*
     2870        #+clozure ccl::*stderr*
     2871        #-(or allegro clozure) *error-output*))
     2872(setup-stderr)
     2873
     2874
     2875;;; Safe syntax
     2876
     2877(defvar *standard-readtable* (copy-readtable nil))
     2878
     2879(defmacro with-safe-io-syntax ((&key (package :cl)) &body body)
     2880  "Establish safe CL reader options around the evaluation of BODY"
     2881  `(call-with-safe-io-syntax #'(lambda () (let ((*package* (find-package ,package))) ,@body))))
     2882
     2883(defun* call-with-safe-io-syntax (thunk &key (package :cl))
     2884  (with-standard-io-syntax ()
     2885    (let ((*package* (find-package package))
     2886          (*readtable* *standard-readtable*)
     2887          (*read-default-float-format* 'double-float)
     2888          (*print-readably* nil)
     2889          (*read-eval* nil))
     2890      (funcall thunk))))
     2891
     2892
     2893;;; Output to a stream or string, FORMAT-style
     2894
     2895(defun* call-with-output (output function)
     2896  "Calls FUNCTION with an actual stream argument,
     2897behaving like FORMAT with respect to how stream designators are interpreted:
     2898If OUTPUT is a stream, use it as the stream.
     2899If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string.
     2900If OUTPUT is T, use *STANDARD-OUTPUT* as the stream.
     2901If OUTPUT is a string with a fill-pointer, use it as a string-output-stream.
     2902Otherwise, signal an error."
     2903  (etypecase output
     2904    (null
     2905     (with-output-to-string (stream) (funcall function stream)))
     2906    ((eql t)
     2907     (funcall function *standard-output*))
     2908    (stream
     2909     (funcall function output))
     2910    (string
     2911     (assert (fill-pointer output))
     2912     (with-output-to-string (stream output) (funcall function stream)))))
     2913
     2914(defmacro with-output ((output-var &optional (value output-var)) &body body)
     2915  "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR)
     2916as per FORMAT, and evaluate BODY within the scope of this binding."
     2917  `(call-with-output ,value #'(lambda (,output-var) ,@body)))
     2918
     2919(defun* output-string (string &optional output)
     2920  "If the desired OUTPUT is not NIL, print the string to the output; otherwise return the string"
     2921  (if output
     2922      (with-output (output) (princ string output))
     2923      string))
     2924
     2925
     2926;;; Input helpers
     2927
     2928(defun* call-with-input (input function)
     2929  "Calls FUNCTION with an actual stream argument, interpreting
     2930stream designators like READ, but also coercing strings to STRING-INPUT-STREAM.
     2931If INPUT is a STREAM, use it as the stream.
     2932If INPUT is NIL, use a *STANDARD-INPUT* as the stream.
     2933If INPUT is T, use *TERMINAL-IO* as the stream.
     2934As an extension, if INPUT is a string, use it as a string-input-stream.
     2935Otherwise, signal an error."
     2936  (etypecase input
     2937    (null (funcall function *standard-input*))
     2938    ((eql t) (funcall function *terminal-io*))
     2939    (stream (funcall function input))
     2940    (string (with-input-from-string (stream input) (funcall function stream)))))
     2941
     2942(defmacro with-input ((input-var &optional (value input-var)) &body body)
     2943  "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR)
     2944as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding."
     2945  `(call-with-input ,value #'(lambda (,input-var) ,@body)))
     2946
     2947(defun* call-with-input-file (pathname thunk
     2948                                       &key
     2949                                       (element-type *default-stream-element-type*)
     2950                                       (external-format :default)
     2951                                       (if-does-not-exist :error))
     2952  "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
     2953Other keys are accepted but discarded."
     2954  #+gcl2.6 (declare (ignore external-format))
     2955  (with-open-file (s pathname :direction :input
     2956                     :element-type element-type
     2957                     #-gcl2.6 :external-format #-gcl2.6 external-format
     2958                     :if-does-not-exist if-does-not-exist)
     2959    (funcall thunk s)))
     2960
     2961(defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
     2962  (declare (ignore element-type external-format))
     2963  `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
     2964
     2965
     2966;;; Ensure output buffers are flushed
     2967
     2968(defun* finish-outputs (&rest streams)
     2969  "Finish output on the main output streams as well as any specified one.
     2970Useful for portably flushing I/O before user input or program exit."
     2971  ;; CCL notably buffers its stream output by default.
     2972  (dolist (s (append streams
     2973                     (list *stderr* *error-output* *standard-output* *trace-output*
     2974                           *debug-io* *terminal-io* *debug-io* *query-io*)))
     2975    (ignore-errors (finish-output s)))
     2976  (values))
     2977
     2978(defun* format! (stream format &rest args)
     2979  "Just like format, but call finish-outputs before and after the output."
     2980  (finish-outputs stream)
     2981  (apply 'format stream format args)
     2982  (finish-output stream))
     2983
     2984(defun* safe-format! (stream format &rest args)
     2985  (with-safe-io-syntax ()
     2986    (ignore-errors (apply 'format! stream format args))
     2987    (finish-outputs stream))) ; just in case format failed
     2988
     2989
     2990;;; Simple Whole-Stream processing
     2991
     2992
     2993(defun* copy-stream-to-stream (input output &key element-type buffer-size linewise prefix)
     2994  "Copy the contents of the INPUT stream into the OUTPUT stream.
     2995If LINEWISE is true, then read and copy the stream line by line, with an optional PREFIX.
     2996Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE."
     2997  (with-open-stream (input input)
     2998    (if linewise
     2999        (loop* :for (line eof) = (multiple-value-list (read-line input nil nil))
     3000               :while line :do
     3001               (when prefix (princ prefix output))
     3002               (princ line output)
     3003               (unless eof (terpri output))
     3004               (finish-output output)
     3005               (when eof (return)))
     3006        (loop
     3007          :with buffer-size = (or buffer-size 8192)
     3008          :for buffer = (make-array (list buffer-size) :element-type (or element-type 'character))
     3009          :for end = (read-sequence buffer input)
     3010          :until (zerop end)
     3011          :do (write-sequence buffer output :end end)
     3012              (when (< end buffer-size) (return))))))
     3013
     3014(defun* concatenate-files (inputs output)
     3015  (with-open-file (o output :element-type '(unsigned-byte 8)
     3016                            :direction :output :if-exists :rename-and-delete)
     3017    (dolist (input inputs)
     3018      (with-open-file (i input :element-type '(unsigned-byte 8)
     3019                               :direction :input :if-does-not-exist :error)
     3020        (copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
     3021
     3022(defun* slurp-stream-string (input &key (element-type 'character))
     3023  "Read the contents of the INPUT stream as a string"
     3024  (with-open-stream (input input)
     3025    (with-output-to-string (output)
     3026      (copy-stream-to-stream input output :element-type element-type))))
     3027
     3028(defun* slurp-stream-lines (input &key count)
     3029  "Read the contents of the INPUT stream as a list of lines, return those lines.
     3030
     3031Read no more than COUNT lines."
     3032  (check-type count (or null integer))
     3033  (with-open-stream (input input)
     3034    (loop :for n :from 0
     3035          :for l = (and (or (not count) (< n count))
     3036                        (read-line input nil nil))
     3037          :while l :collect l)))
     3038
     3039(defun* slurp-stream-line (input &key (at 0))
     3040  "Read the contents of the INPUT stream as a list of lines,
     3041then return the ACCESS-AT of that list of lines using the AT specifier.
     3042PATH defaults to 0, i.e. return the first line.
     3043PATH is typically an integer, or a list of an integer and a function.
     3044If PATH is NIL, it will return all the lines in the file.
     3045
     3046The stream will not be read beyond the Nth lines,
     3047where N is the index specified by path
     3048if path is either an integer or a list that starts with an integer."
     3049  (access-at (slurp-stream-lines input :count (access-at-count at)) at))
     3050
     3051(defun* slurp-stream-forms (input &key count)
     3052"Read the contents of the INPUT stream as a list of forms,
     3053and return those forms.
     3054
     3055If COUNT is null, read to the end of the stream;
     3056if COUNT is an integer, stop after COUNT forms were read.
     3057
     3058BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
     3059  (check-type count (or null integer))
     3060  (loop :with eof = '#:eof
     3061        :for n :from 0
     3062        :for form = (if (and count (>= n count))
     3063                        eof
     3064                        (read-preserving-whitespace input nil eof))
     3065        :until (eq form eof) :collect form))
     3066
     3067(defun* slurp-stream-form (input &key (at 0))
     3068"Read the contents of the INPUT stream as a list of forms,
     3069then return the ACCESS-AT of these forms following the AT.
     3070AT defaults to 0, i.e. return the first form.
     3071AT is typically a list of integers.
     3072If AT is NIL, it will return all the forms in the file.
     3073
     3074The stream will not be read beyond the Nth form,
     3075where N is the index specified by path,
     3076if path is either an integer or a list that starts with an integer.
     3077
     3078BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
     3079  (access-at (slurp-stream-forms input :count (access-at-count at)) at))
     3080
     3081(defun* read-file-string (file &rest keys)
     3082  "Open FILE with option KEYS, read its contents as a string"
     3083  (apply 'call-with-input-file file 'slurp-stream-string keys))
     3084
     3085(defun* read-file-lines (file &rest keys)
     3086  "Open FILE with option KEYS, read its contents as a list of lines
     3087BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
     3088  (apply 'call-with-input-file file 'slurp-stream-lines keys))
     3089
     3090(defun* read-file-forms (file &rest keys &key count &allow-other-keys)
     3091  "Open input FILE with option KEYS (except COUNT),
     3092and read its contents as per SLURP-STREAM-FORMS with given COUNT.
     3093BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
     3094  (apply 'call-with-input-file file
     3095         #'(lambda (input) (slurp-stream-forms input :count count))
     3096         (remove-plist-key :count keys)))
     3097
     3098(defun* read-file-form (file &rest keys &key (at 0) &allow-other-keys)
     3099  "Open input FILE with option KEYS (except AT),
     3100and read its contents as per SLURP-STREAM-FORM with given AT specifier.
     3101BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof"
     3102  (apply 'call-with-input-file file
     3103         #'(lambda (input) (slurp-stream-form input :at at))
     3104         (remove-plist-key :at keys)))
     3105
     3106(defun* safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys)
     3107  "Reads the specified form from the top of a file using a safe standardized syntax.
     3108Extracts the form using READ-FILE-FORM,
     3109within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE."
     3110  (with-safe-io-syntax (:package package)
     3111    (apply 'read-file-form pathname (remove-plist-key :package keys))))
     3112
     3113(defun* eval-input (input)
     3114  "Portably read and evaluate forms from INPUT, return the last values."
     3115  (with-input (input)
     3116    (loop :with results :with eof ='#:eof
     3117          :for form = (read input nil eof)
     3118          :until (eq form eof)
     3119          :do (setf results (multiple-value-list (eval form)))
     3120          :finally (return (apply 'values results)))))
     3121
     3122(defun* eval-thunk (thunk)
     3123  "Evaluate a THUNK of code:
     3124If a function, FUNCALL it without arguments.
     3125If a constant literal and not a sequence, return it.
     3126If a cons or a symbol, EVAL it.
     3127If a string, repeatedly read and evaluate from it, returning the last values."
     3128  (etypecase thunk
     3129    ((or boolean keyword number character pathname) thunk)
     3130    ((or cons symbol) (eval thunk))
     3131    (function (funcall thunk))
     3132    (string (eval-input thunk))))
     3133
     3134(defun* standard-eval-thunk (thunk &key (package :cl))
     3135  "Like EVAL-THUNK, but in a more standardized evaluation context."
     3136  ;; Note: it's "standard-" not "safe-", because evaluation is never safe.
     3137  (when thunk
     3138    (with-safe-io-syntax (:package package)
     3139      (let ((*read-eval* t))
     3140        (eval-thunk thunk)))))
     3141
     3142
     3143;;; Encodings
     3144
     3145(defvar *default-encoding* :default
     3146  "Default encoding for source files.
     3147The default value :default preserves the legacy behavior.
     3148A future default might be :utf-8 or :autodetect
     3149reading emacs-style -*- coding: utf-8 -*- specifications,
     3150and falling back to utf-8 or latin1 if nothing is specified.")
     3151
     3152(defparameter *utf-8-external-format*
     3153  #+(and asdf-unicode (not clisp)) :utf-8
     3154  #+(and asdf-unicode clisp) charset:utf-8
     3155  #-asdf-unicode :default
     3156  "Default :external-format argument to pass to CL:OPEN and also
     3157CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
     3158On modern implementations, this will decode UTF-8 code points as CL characters.
     3159On legacy implementations, it may fall back on some 8-bit encoding,
     3160with non-ASCII code points being read as several CL characters;
     3161hopefully, if done consistently, that won't affect program behavior too much.")
     3162
     3163(defun* always-default-encoding (pathname)
     3164  (declare (ignore pathname))
     3165  *default-encoding*)
     3166
     3167(defvar *encoding-detection-hook* #'always-default-encoding
     3168  "Hook for an extension to define a function to automatically detect a file's encoding")
     3169
     3170(defun* detect-encoding (pathname)
     3171  (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname))
     3172      (funcall *encoding-detection-hook* pathname)
     3173      *default-encoding*))
     3174
     3175(defun* default-encoding-external-format (encoding)
     3176  (case encoding
     3177    (:default :default) ;; for backward-compatibility only. Explicit usage discouraged.
     3178    (:utf-8 *utf-8-external-format*)
     3179    (otherwise
     3180     (cerror "Continue using :external-format :default" (compatfmt "~@<Your ASDF component is using encoding ~S but it isn't recognized. Your system should :defsystem-depends-on (:asdf-encodings).~:>") encoding)
     3181     :default)))
     3182
     3183(defvar *encoding-external-format-hook*
     3184  #'default-encoding-external-format
     3185  "Hook for an extension to define a mapping between non-default encodings
     3186and implementation-defined external-format's")
     3187
     3188(defun* encoding-external-format (encoding)
     3189  (funcall *encoding-external-format-hook* encoding))
     3190
     3191
     3192;;; Using temporary files
     3193(defun* default-temporary-directory ()
     3194  (or
     3195   (when (os-unix-p)
     3196     (or (getenv-pathname "TMPDIR" :ensure-directory t)
     3197         (parse-native-namestring "/tmp/")))
     3198   (when (os-windows-p)
     3199     (getenv-pathname "TEMP" :ensure-directory t))
     3200   (subpathname (user-homedir-pathname) "tmp/")))
     3201
     3202(defvar *temporary-directory* nil)
     3203
     3204(defun* temporary-directory ()
     3205  (or *temporary-directory* (default-temporary-directory)))
     3206
     3207(defun setup-temporary-directory ()
     3208  (setf *temporary-directory* (default-temporary-directory))
     3209  ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1
     3210  #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*))
     3211
     3212(defun* call-with-temporary-file
     3213    (thunk &key
     3214     prefix keep (direction :io)
     3215     (element-type *default-stream-element-type*)
     3216     (external-format :default))
     3217  #+gcl2.6 (declare (ignorable external-format))
     3218  (check-type direction (member :output :io))
     3219  (loop
     3220    :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
     3221    :for counter :from (random (ash 1 32))
     3222    :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
     3223     ;; TODO: on Unix, do something about umask
     3224     ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL
     3225     ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr.
     3226    (with-open-file (stream pathname
     3227                            :direction direction
     3228                            :element-type element-type
     3229                            #-gcl2.6 :external-format #-gcl2.6 external-format
     3230                            :if-exists nil :if-does-not-exist :create)
     3231      (when stream
     3232        (return
     3233          (if keep
     3234              (funcall thunk stream pathname)
     3235              (unwind-protect
     3236                   (funcall thunk stream pathname)
     3237                (ignore-errors (delete-file pathname)))))))))
     3238
     3239(defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp)
     3240                                (pathname (gensym "PATHNAME") pathnamep)
     3241                                prefix keep direction element-type external-format)
     3242                               &body body)
     3243  "Evaluate BODY where the symbols specified by keyword arguments
     3244STREAM and PATHNAME are bound corresponding to a newly created temporary file
     3245ready for I/O. Unless KEEP is specified, delete the file afterwards."
     3246  (check-type stream symbol)
     3247  (check-type pathname symbol)
     3248  `(flet ((think (,stream ,pathname)
     3249            ,@(unless pathnamep `((declare (ignore ,pathname))))
     3250            ,@(unless streamp `((when ,stream (close ,stream))))
     3251            ,@body))
     3252     #-gcl (declare (dynamic-extent #'think))
     3253     (call-with-temporary-file
     3254      #'think
     3255      ,@(when direction `(:direction ,direction))
     3256      ,@(when prefix `(:prefix ,prefix))
     3257      ,@(when keep `(:keep ,keep))
     3258      ,@(when element-type `(:element-type ,element-type))
     3259      ,@(when external-format `(:external-format external-format)))))
     3260
     3261;;; Temporary pathnames
     3262(defun* add-pathname-suffix (pathname suffix)
     3263  (make-pathname :name (strcat (pathname-name pathname) suffix)
     3264                 :defaults pathname))
     3265
     3266(defun* tmpize-pathname (x)
     3267  (add-pathname-suffix x "-ASDF-TMP"))
     3268
     3269(defun* call-with-staging-pathname (pathname fun)
     3270  "Calls fun with a staging pathname, and atomically
     3271renames the staging pathname to the pathname in the end.
     3272Note: this protects only against failure of the program,
     3273not against concurrent attempts.
     3274For the latter case, we ought pick random suffix and atomically open it."
     3275  (let* ((pathname (pathname pathname))
     3276         (staging (tmpize-pathname pathname)))
     3277    (unwind-protect
     3278         (multiple-value-prog1
     3279             (funcall fun staging)
     3280           (rename-file-overwriting-target staging pathname))
     3281      (delete-file-if-exists staging))))
     3282
     3283(defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body)
     3284  `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))
     3285
     3286
     3287;;;; -------------------------------------------------------------------------
     3288;;;; Starting, Stopping, Dumping a Lisp image
     3289
     3290(asdf/package:define-package :asdf/image
     3291  (:recycle :asdf/image :xcvb-driver)
     3292  (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream :asdf/os)
     3293  (:export
     3294   #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
     3295   #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
     3296   #:*lisp-interaction*
     3297   #:fatal-conditions #:fatal-condition-p #:handle-fatal-condition
     3298   #:call-with-fatal-condition-handler #:with-fatal-condition-handler
     3299   #:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
     3300   #:*image-postlude* #:*image-dump-hook*
     3301   #:quit #:die #:raw-print-backtrace #:print-backtrace #:print-condition-backtrace
     3302   #:shell-boolean-exit
     3303   #:register-image-restore-hook #:register-image-dump-hook
     3304   #:call-image-restore-hook #:call-image-dump-hook
     3305   #:initialize-asdf-utilities #:restore-image #:dump-image #:create-image
     3306))
     3307(in-package :asdf/image)
     3308
     3309(defvar *lisp-interaction* t
     3310  "Is this an interactive Lisp environment, or is it batch processing?")
     3311
     3312(defvar *command-line-arguments* nil
     3313  "Command-line arguments")
     3314
     3315(defvar *image-dumped-p* nil ; may matter as to how to get to command-line-arguments
     3316  "Is this a dumped image? As a standalone executable?")
     3317
     3318(defvar *image-restore-hook* nil
     3319  "Functions to call (in reverse order) when the image is restored")
     3320
     3321(defvar *image-prelude* nil
     3322  "a form to evaluate, or string containing forms to read and evaluate
     3323when the image is restarted, but before the entry point is called.")
     3324
     3325(defvar *image-entry-point* nil
     3326  "a function with which to restart the dumped image when execution is restored from it.")
     3327
     3328(defvar *image-postlude* nil
     3329  "a form to evaluate, or string containing forms to read and evaluate
     3330before the image dump hooks are called and before the image is dumped.")
     3331
     3332(defvar *image-dump-hook* nil
     3333  "Functions to call (in order) when before an image is dumped")
     3334
     3335(defvar *fatal-conditions* '(error)
     3336  "conditions that cause the Lisp image to enter the debugger if interactive,
     3337or to die if not interactive")
     3338
     3339
     3340;;; Exiting properly or im-
     3341(defun* quit (&optional (code 0) (finish-output t))
     3342  "Quits from the Lisp world, with the given exit status if provided.
     3343This is designed to abstract away the implementation specific quit forms."
     3344  (when finish-output ;; essential, for ClozureCL, and for standard compliance.
     3345    (finish-outputs))
     3346  #+(or abcl xcl) (ext:quit :status code)
     3347  #+allegro (excl:exit code :quiet t)
     3348  #+clisp (ext:quit code)
     3349  #+clozure (ccl:quit code)
     3350  #+cormanlisp (win32:exitprocess code)
     3351  #+(or cmu scl) (unix:unix-exit code)
     3352  #+ecl (si:quit code)
     3353  #+gcl (lisp:quit code)
     3354  #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
     3355  #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
     3356  #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
     3357  #+mkcl (mk-ext:quit :exit-code code)
     3358  #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
     3359                 (quit (find-symbol* :quit :sb-ext nil)))
     3360             (cond
     3361               (exit `(,exit :code code :abort (not finish-output)))
     3362               (quit `(,quit :unix-status code :recklessly-p (not finish-output)))))
     3363  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
     3364  (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code))
     3365
     3366(defun* die (code format &rest arguments)
     3367  "Die in error with some error message"
     3368  (with-safe-io-syntax ()
     3369    (ignore-errors
     3370     (fresh-line *stderr*)
     3371     (apply #'format *stderr* format arguments)
     3372     (format! *stderr* "~&")))
     3373  (quit code))
     3374
     3375(defun* raw-print-backtrace (&key (stream *debug-io*) count)
     3376  "Print a backtrace, directly accessing the implementation"
     3377  (declare (ignorable stream count))
     3378  #+abcl
     3379  (let ((*debug-io* stream)) (top-level::backtrace-command count))
     3380  #+allegro
     3381  (let ((*terminal-io* stream)
     3382        (*standard-output* stream)
     3383        (tpl:*zoom-print-circle* *print-circle*)
     3384        (tpl:*zoom-print-level* *print-level*)
     3385        (tpl:*zoom-print-length* *print-length*))
     3386    (tpl:do-command "zoom"
     3387      :from-read-eval-print-loop nil
     3388      :count t
     3389      :all t))
     3390  #+clisp
     3391  (system::print-backtrace :out stream :limit count)
     3392  #+(or clozure mcl)
     3393  (let ((*debug-io* stream))
     3394    (ccl:print-call-history :count count :start-frame-number 1)
     3395    (finish-output stream))
     3396  #+(or cmucl scl)
     3397  (let ((debug:*debug-print-level* *print-level*)
     3398        (debug:*debug-print-length* *print-length*))
     3399    (debug:backtrace most-positive-fixnum stream))
     3400  #+ecl
     3401  (si::tpl-backtrace)
     3402  #+lispworks
     3403  (let ((dbg::*debugger-stack*
     3404          (dbg::grab-stack nil :how-many (or count most-positive-fixnum)))
     3405        (*debug-io* stream)
     3406        (dbg:*debug-print-level* *print-level*)
     3407        (dbg:*debug-print-length* *print-length*))
     3408    (dbg:bug-backtrace nil))
     3409  #+sbcl
     3410  (sb-debug:backtrace
     3411   #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum))
     3412   stream))
     3413
     3414(defun* print-backtrace (&rest keys &key stream count)
     3415  (declare (ignore stream count))
     3416  (with-safe-io-syntax (:package :cl)
     3417    (let ((*print-readably* nil)
     3418          (*print-circle* t)
     3419          (*print-miser-width* 75)
     3420          (*print-length* nil)
     3421          (*print-level* nil)
     3422          (*print-pretty* t))
     3423      (ignore-errors (apply 'raw-print-backtrace keys)))))
     3424
     3425(defun* print-condition-backtrace (condition &key (stream *stderr*) count)
     3426  ;; We print the condition *after* the backtrace,
     3427  ;; for the sake of who sees the backtrace at a terminal.
     3428  ;; It is up to the caller to print the condition *before*, with some context.
     3429  (print-backtrace :stream stream :count count)
     3430  (when condition
     3431    (safe-format! stream "~&Above backtrace due to this condition:~%~A~&"
     3432                  condition)))
     3433
     3434(defun fatal-condition-p (condition)
     3435  (match-any-condition-p condition *fatal-conditions*))
     3436
     3437(defun* handle-fatal-condition (condition)
     3438  "Depending on whether *LISP-INTERACTION* is set, enter debugger or die"
    24473439  (cond
    2448     ((slot-boundp c 'around-compile)
    2449      (slot-value c 'around-compile))
    2450     ((component-parent c)
    2451      (around-compile-hook (component-parent c)))))
    2452 
    2453 (defun ensure-function (fun &key (package :asdf))
    2454   (etypecase fun
    2455     ((or symbol function) fun)
    2456     (cons (eval `(function ,fun)))
    2457     (string (eval `(function ,(with-standard-io-syntax
    2458                                (let ((*package* (find-package package)))
    2459                                  (read-from-string fun))))))))
    2460 
    2461 (defmethod call-with-around-compile-hook ((c component) thunk)
    2462   (let ((hook (around-compile-hook c)))
    2463     (if hook
    2464         (funcall (ensure-function hook) thunk)
    2465         (funcall thunk))))
    2466 
    2467 ;;; perform is required to check output-files to find out where to put
    2468 ;;; its answers, in case it has been overridden for site policy
    2469 (defmethod perform ((operation compile-op) (c cl-source-file))
    2470   (let ((source-file (component-pathname c))
    2471         ;; on some implementations, there are more than one output-file,
    2472         ;; but the first one should always be the primary fasl that gets loaded.
    2473         (output-file (first (output-files operation c)))
    2474         (*compile-file-warnings-behaviour* (operation-on-warnings operation))
    2475         (*compile-file-failure-behaviour* (operation-on-failure operation)))
    2476     (multiple-value-bind (output warnings-p failure-p)
    2477         (call-with-around-compile-hook
    2478          c #'(lambda (&rest flags)
    2479                (apply *compile-op-compile-file-function* source-file
    2480                       :output-file output-file
    2481                       :external-format (component-external-format c)
    2482                       (append flags (compile-op-flags operation)))))
    2483       (unless output
    2484         (error 'compile-error :component c :operation operation))
    2485       (when failure-p
    2486         (case (operation-on-failure operation)
    2487           (:warn (warn
    2488                   (compatfmt "~@<COMPILE-FILE failed while performing ~A on ~A.~@:>")
    2489                   operation c))
    2490           (:error (error 'compile-failed :component c :operation operation))
    2491           (:ignore nil)))
    2492       (when warnings-p
    2493         (case (operation-on-warnings operation)
    2494           (:warn (warn
    2495                   (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
    2496                   operation c))
    2497           (:error (error 'compile-warned :component c :operation operation))
    2498           (:ignore nil))))))
    2499 
    2500 (defmethod output-files ((operation compile-op) (c cl-source-file))
    2501   (declare (ignorable operation))
    2502   (let* ((p (lispize-pathname (component-pathname c)))
    2503          (f (compile-file-pathname ;; fasl
    2504              p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
    2505          #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file
    2506     #+ecl (if (use-ecl-byte-compiler-p)
    2507               (list f)
    2508               (list (compile-file-pathname p :type :object) f))
    2509     #+mkcl (list o f)
    2510     #-(or ecl mkcl) (list f)))
    2511 
    2512 (defmethod perform ((operation compile-op) (c static-file))
    2513   (declare (ignorable operation c))
    2514   nil)
    2515 
    2516 (defmethod output-files ((operation compile-op) (c static-file))
    2517   (declare (ignorable operation c))
    2518   nil)
    2519 
    2520 (defmethod input-files ((operation compile-op) (c static-file))
    2521   (declare (ignorable operation c))
    2522   nil)
    2523 
    2524 (defmethod operation-description ((operation compile-op) component)
    2525   (declare (ignorable operation))
    2526   (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") component))
    2527 
    2528 (defmethod operation-description ((operation compile-op) (component module))
    2529   (declare (ignorable operation))
    2530   (format nil (compatfmt "~@<compiled ~3i~_~A~@:>") component))
    2531 
    2532 
     3440    (*lisp-interaction*
     3441     (invoke-debugger condition))
     3442    (t
     3443     (safe-format! *stderr* "~&Fatal condition:~%~A~%" condition)
     3444     (print-condition-backtrace condition :stream *stderr*)
     3445     (die 99 "~A" condition))))
     3446
     3447(defun* call-with-fatal-condition-handler (thunk)
     3448  (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition))
     3449    (funcall thunk)))
     3450
     3451(defmacro with-fatal-condition-handler ((&optional) &body body)
     3452  `(call-with-fatal-condition-handler #'(lambda () ,@body)))
     3453
     3454(defun* shell-boolean-exit (x)
     3455  "Quit with a return code that is 0 iff argument X is true"
     3456  (quit (if x 0 1)))
     3457
     3458
     3459;;; Using image hooks
     3460
     3461(defun* register-image-restore-hook (hook &optional (call-now-p t))
     3462  (register-hook-function '*image-restore-hook* hook call-now-p))
     3463
     3464(defun* register-image-dump-hook (hook &optional (call-now-p nil))
     3465  (register-hook-function '*image-dump-hook* hook call-now-p))
     3466
     3467(defun* call-image-restore-hook ()
     3468  (call-functions (reverse *image-restore-hook*)))
     3469
     3470(defun* call-image-dump-hook ()
     3471  (call-functions *image-dump-hook*))
     3472
     3473
     3474;;; Proper command-line arguments
     3475
     3476(defun* raw-command-line-arguments ()
     3477  "Find what the actual command line for this process was."
     3478  #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later!
     3479  #+allegro (sys:command-line-arguments) ; default: :application t
     3480  #+clisp (coerce (ext:argv) 'list)
     3481  #+clozure (ccl::command-line-arguments)
     3482  #+(or cmu scl) extensions:*command-line-strings*
     3483  #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
     3484  #+gcl si:*command-args*
     3485  #+genera nil
     3486  #+lispworks sys:*line-arguments-list*
     3487  #+sbcl sb-ext:*posix-argv*
     3488  #+xcl system:*argv*
     3489  #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl)
     3490  (error "raw-command-line-arguments not implemented yet"))
     3491
     3492(defun* command-line-arguments (&optional (arguments (raw-command-line-arguments)))
     3493  "Extract user arguments from command-line invocation of current process.
     3494Assume the calling conventions of a generated script that uses --
     3495if we are not called from a directly executable image."
     3496  #+abcl arguments
     3497  #-abcl
     3498  (let* (#-(or sbcl allegro)
     3499         (arguments
     3500          (if (eq *image-dumped-p* :executable)
     3501              arguments
     3502              (member "--" arguments :test 'string-equal))))
     3503    (rest arguments)))
     3504
     3505(defun setup-command-line-arguments ()
     3506  (setf *command-line-arguments* (command-line-arguments)))
     3507
     3508(defun* restore-image (&key
     3509                       ((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
     3510                       ((:restore-hook *image-restore-hook*) *image-restore-hook*)
     3511                       ((:prelude *image-prelude*) *image-prelude*)
     3512                       ((:entry-point *image-entry-point*) *image-entry-point*))
     3513  (with-fatal-condition-handler ()
     3514    (call-image-restore-hook)
     3515    (standard-eval-thunk *image-prelude*)
     3516    (let ((results (multiple-value-list
     3517                    (if *image-entry-point*
     3518                        (call-function *image-entry-point*)
     3519                        t))))
     3520      (if *lisp-interaction*
     3521          (apply 'values results)
     3522          (shell-boolean-exit (first results))))))
     3523
     3524
     3525;;; Dumping an image
     3526
     3527#-(or ecl mkcl)
     3528(defun* dump-image (filename &key output-name executable
     3529                             ((:postlude *image-postlude*) *image-postlude*)
     3530                             ((:dump-hook *image-dump-hook*) *image-dump-hook*))
     3531  (declare (ignorable filename output-name executable))
     3532  (setf *image-dumped-p* (if executable :executable t))
     3533  (standard-eval-thunk *image-postlude*)
     3534  (call-image-dump-hook)
     3535  #-(or clisp clozure cmu lispworks sbcl scl)
     3536  (when executable
     3537    (error "Dumping an executable is not supported on this implementation! Aborting."))
     3538  #+allegro
     3539  (progn
     3540    (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) ; :new 5000000
     3541    (excl:dumplisp :name filename :suppress-allegro-cl-banner t))
     3542  #+clisp
     3543  (apply #'ext:saveinitmem filename
     3544   :quiet t
     3545   :start-package *package*
     3546   :keep-global-handlers nil
     3547   :executable (if executable 0 t) ;--- requires clisp 2.48 or later, still catches --clisp-x
     3548   (when executable
     3549     (list
     3550      ;; :parse-options nil ;--- requires a non-standard patch to clisp.
     3551      :norc t :script nil :init-function #'restore-image)))
     3552  #+clozure
     3553  (ccl:save-application filename :prepend-kernel t
     3554                        :toplevel-function (when executable #'restore-image))
     3555  #+(or cmu scl)
     3556  (progn
     3557   (ext:gc :full t)
     3558   (setf ext:*batch-mode* nil)
     3559   (setf ext::*gc-run-time* 0)
     3560   (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
     3561          (when executable '(:init-function restore-image :process-command-line nil))))
     3562  #+gcl
     3563  (progn
     3564   (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
     3565   (si::save-system filename))
     3566  #+lispworks
     3567  (if executable
     3568      (lispworks:deliver 'restore-image filename 0 :interface nil)
     3569      (hcl:save-image filename :environment nil))
     3570  #+sbcl
     3571  (progn
     3572    ;;(sb-pcl::precompile-random-code-segments) ;--- it is ugly slow at compile-time (!) when the initial core is a big CLOS program. If you want it, do it yourself
     3573   (setf sb-ext::*gc-run-time* 0)
     3574   (apply 'sb-ext:save-lisp-and-die filename
     3575    :executable t ;--- always include the runtime that goes with the core
     3576    (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
     3577  #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
     3578  (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
     3579       filename (nth-value 1 (implementation-type))))
     3580
     3581
     3582#+ecl
     3583(defun create-image (destination object-files
     3584                     &key kind output-name prologue-code epilogue-code
     3585                       (prelude () preludep) (entry-point () entry-point-p) build-args)
     3586  ;; Is it meaningful to run these in the current environment?
     3587  ;; only if we also track the object files that constitute the "current" image,
     3588  ;; and otherwise simulate dump-image, including quitting at the end.
     3589  ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook)
     3590  (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
     3591  (apply 'c::builder
     3592         kind (pathname destination)
     3593         :lisp-files object-files
     3594         :init-name (c::compute-init-name (or output-name destination) :kind kind)
     3595         :prologue-code prologue-code
     3596         :epilogue-code
     3597         `(progn
     3598            ,epilogue-code
     3599            ,@(when (eq kind :program)
     3600                `((setf *image-dumped-p* :executable)
     3601                  (restore-image ;; default behavior would be (si::top-level)
     3602                   ,@(when preludep `(:prelude ',prelude))
     3603                   ,@(when entry-point-p `(:entry-point ',entry-point))))))
     3604         build-args))
     3605
     3606
     3607;;; Some universal image restore hooks
     3608(map () 'register-image-restore-hook
     3609     '(setup-temporary-directory setup-stderr setup-command-line-arguments
     3610       #+abcl detect-os))
    25333611;;;; -------------------------------------------------------------------------
    2534 ;;;; load-op
    2535 
    2536 (defclass basic-load-op (operation) ())
    2537 
    2538 (defclass load-op (basic-load-op) ())
    2539 
    2540 (defmethod perform-with-restarts ((o load-op) (c cl-source-file))
    2541   (loop
    2542     (restart-case
    2543         (return (call-next-method))
    2544       (try-recompiling ()
    2545         :report (lambda (s)
    2546                   (format s "Recompile ~a and try loading it again"
    2547                           (component-name c)))
    2548         (perform (make-sub-operation c o c 'compile-op) c)))))
    2549 
    2550 (defmethod perform ((o load-op) (c cl-source-file))
    2551   (map () #'load
    2552        #-(or ecl mkcl)
    2553        (input-files o c)
    2554        #+(or ecl mkcl)
    2555        (loop :for i :in (input-files o c)
    2556              :unless (string= (pathname-type i) "fas")
    2557              :collect (compile-file-pathname (lispize-pathname i)))))
    2558 
    2559 (defmethod perform ((operation load-op) (c static-file))
    2560   (declare (ignorable operation c))
    2561   nil)
    2562 
    2563 (defmethod operation-done-p ((operation load-op) (c static-file))
    2564   (declare (ignorable operation c))
    2565   t)
    2566 
    2567 (defmethod output-files ((operation operation) (c component))
    2568   (declare (ignorable operation c))
    2569   nil)
    2570 
    2571 (defmethod component-depends-on ((operation load-op) (c component))
    2572   (declare (ignorable operation))
    2573   (cons (list 'compile-op (component-name c))
    2574         (call-next-method)))
    2575 
    2576 (defmethod operation-description ((operation load-op) component)
    2577   (declare (ignorable operation))
    2578   (format nil (compatfmt "~@<loading ~3i~_~A~@:>")
    2579           component))
    2580 
    2581 (defmethod operation-description ((operation load-op) (component cl-source-file))
    2582   (declare (ignorable operation))
    2583   (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>")
    2584           component))
    2585 
    2586 (defmethod operation-description ((operation load-op) (component module))
    2587   (declare (ignorable operation))
    2588   (format nil (compatfmt "~@<loaded ~3i~_~A~@:>")
    2589           component))
     3612;;;; run-program initially from xcvb-driver.
     3613
     3614(asdf/package:define-package :asdf/run-program
     3615  (:recycle :asdf/run-program :xcvb-driver)
     3616  (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/filesystem :asdf/stream)
     3617  (:export
     3618   ;;; Escaping the command invocation madness
     3619   #:easy-sh-character-p #:escape-sh-token #:escape-sh-command
     3620   #:escape-windows-token #:escape-windows-command
     3621   #:escape-token #:escape-command
     3622
     3623   ;;; run-program
     3624   #:slurp-input-stream
     3625   #:run-program
     3626   #:subprocess-error
     3627   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
     3628   ))
     3629(in-package :asdf/run-program)
     3630
     3631;;;; ----- Escaping strings for the shell -----
     3632
     3633(defun* requires-escaping-p (token &key good-chars bad-chars)
     3634  "Does this token require escaping, given the specification of
     3635either good chars that don't need escaping or bad chars that do need escaping,
     3636as either a recognizing function or a sequence of characters."
     3637  (some
     3638   (cond
     3639     ((and good-chars bad-chars)
     3640      (error "only one of good-chars and bad-chars can be provided"))
     3641     ((functionp good-chars)
     3642      (complement good-chars))
     3643     ((functionp bad-chars)
     3644      bad-chars)
     3645     ((and good-chars (typep good-chars 'sequence))
     3646      #'(lambda (c) (not (find c good-chars))))
     3647     ((and bad-chars (typep bad-chars 'sequence))
     3648      #'(lambda (c) (find c bad-chars)))
     3649     (t (error "requires-escaping-p: no good-char criterion")))
     3650   token))
     3651
     3652(defun* escape-token (token &key stream quote good-chars bad-chars escaper)
     3653  "Call the ESCAPER function on TOKEN string if it needs escaping as per
     3654REQUIRES-ESCAPING-P using GOOD-CHARS and BAD-CHARS, otherwise output TOKEN,
     3655using STREAM as output (or returning result as a string if NIL)"
     3656  (if (requires-escaping-p token :good-chars good-chars :bad-chars bad-chars)
     3657      (with-output (stream)
     3658        (apply escaper token stream (when quote `(:quote ,quote))))
     3659      (output-string token stream)))
     3660
     3661(defun* escape-windows-token-within-double-quotes (x &optional s)
     3662  "Escape a string token X within double-quotes
     3663for use within a MS Windows command-line, outputing to S."
     3664  (labels ((issue (c) (princ c s))
     3665           (issue-backslash (n) (loop :repeat n :do (issue #\\))))
     3666    (loop
     3667      :initially (issue #\") :finally (issue #\")
     3668      :with l = (length x) :with i = 0
     3669      :for i+1 = (1+ i) :while (< i l) :do
     3670      (case (char x i)
     3671        ((#\") (issue-backslash 1) (issue #\") (setf i i+1))
     3672        ((#\\)
     3673         (let* ((j (and (< i+1 l) (position-if-not
     3674                                   #'(lambda (c) (eql c #\\)) x :start i+1)))
     3675                (n (- (or j l) i)))
     3676           (cond
     3677             ((null j)
     3678              (issue-backslash (* 2 n)) (setf i l))
     3679             ((and (< j l) (eql (char x j) #\"))
     3680              (issue-backslash (1+ (* 2 n))) (issue #\") (setf i (1+ j)))
     3681             (t
     3682              (issue-backslash n) (setf i j)))))
     3683        (otherwise
     3684         (issue (char x i)) (setf i i+1))))))
     3685
     3686(defun* escape-windows-token (token &optional s)
     3687  "Escape a string TOKEN within double-quotes if needed
     3688for use within a MS Windows command-line, outputing to S."
     3689  (escape-token token :stream s :bad-chars #(#\space #\tab #\") :quote nil
     3690                :escaper 'escape-windows-token-within-double-quotes))
     3691
     3692(defun* escape-sh-token-within-double-quotes (x s &key (quote t))
     3693  "Escape a string TOKEN within double-quotes
     3694for use within a POSIX Bourne shell, outputing to S;
     3695omit the outer double-quotes if key argument :QUOTE is NIL"
     3696  (when quote (princ #\" s))
     3697  (loop :for c :across x :do
     3698    (when (find c "$`\\\"") (princ #\\ s))
     3699    (princ c s))
     3700  (when quote (princ #\" s)))
     3701
     3702(defun* easy-sh-character-p (x)
     3703  (or (alphanumericp x) (find x "+-_.,%@:/")))
     3704
     3705(defun* escape-sh-token (token &optional s)
     3706  "Escape a string TOKEN within double-quotes if needed
     3707for use within a POSIX Bourne shell, outputing to S."
     3708  (escape-token token :stream s :quote #\" :good-chars
     3709                #'easy-sh-character-p
     3710                :escaper 'escape-sh-token-within-double-quotes))
     3711
     3712(defun* escape-shell-token (token &optional s)
     3713  (cond
     3714    ((os-unix-p) (escape-sh-token token s))
     3715    ((os-windows-p) (escape-windows-token token s))))
     3716
     3717(defun* escape-command (command &optional s
     3718                       (escaper 'escape-shell-token))
     3719  "Given a COMMAND as a list of tokens, return a string of the
     3720spaced, escaped tokens, using ESCAPER to escape."
     3721  (etypecase command
     3722    (string (output-string command s))
     3723    (list (with-output (s)
     3724            (loop :for first = t :then nil :for token :in command :do
     3725              (unless first (princ #\space s))
     3726              (funcall escaper token s))))))
     3727
     3728(defun* escape-windows-command (command &optional s)
     3729  "Escape a list of command-line arguments into a string suitable for parsing
     3730by CommandLineToArgv in MS Windows"
     3731    ;; http://msdn.microsoft.com/en-us/library/bb776391(v=vs.85).aspx
     3732    ;; http://msdn.microsoft.com/en-us/library/17w5ykft(v=vs.85).aspx
     3733  (escape-command command s 'escape-windows-token))
     3734
     3735(defun* escape-sh-command (command &optional s)
     3736  "Escape a list of command-line arguments into a string suitable for parsing
     3737by /bin/sh in POSIX"
     3738  (escape-command command s 'escape-sh-token))
     3739
     3740(defun* escape-shell-command (command &optional stream)
     3741  "Escape a command for the current operating system's shell"
     3742  (escape-command command stream 'escape-shell-token))
     3743
     3744
     3745;;;; Slurping a stream, typically the output of another program
     3746
     3747(defgeneric* slurp-input-stream (processor input-stream &key &allow-other-keys))
     3748
     3749#-(or gcl2.6 genera)
     3750(defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys)
     3751  (funcall function input-stream))
     3752
     3753(defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys)
     3754  (apply (first list) (cons input-stream (rest list))))
     3755
     3756#-(or gcl2.6 genera)
     3757(defmethod slurp-input-stream ((output-stream stream) input-stream
     3758                               &key linewise prefix (element-type 'character) buffer-size &allow-other-keys)
     3759  (copy-stream-to-stream
     3760   input-stream output-stream
     3761   :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size))
     3762
     3763(defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys)
     3764  (declare (ignorable x))
     3765  (slurp-stream-string stream))
     3766
     3767(defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys)
     3768  (declare (ignorable x))
     3769  (slurp-stream-string stream))
     3770
     3771(defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys)
     3772  (declare (ignorable x))
     3773  (slurp-stream-lines stream :count count))
     3774
     3775(defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys)
     3776  (declare (ignorable x))
     3777  (slurp-stream-line stream :at at))
     3778
     3779(defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys)
     3780  (d