Skip to content
asdf.lisp 194 KiB
Newer Older
Raymond Toy's avatar
Raymond Toy committed
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
Raymond Toy's avatar
Raymond Toy committed
;;; This is ASDF 2.26: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
;;; Note first that the canonical source for ASDF is presently
;;; <URL:http://common-lisp.net/project/asdf/>.
;;;
;;; If you obtained this copy from anywhere else, and you experience
;;; trouble using it, or find bugs, you may want to check at the
;;; location above for a more recent version (and for documentation
;;; and test files, if your copy came without them) before reporting
;;; bugs.  There are usually two "supported" revisions - the git master
;;; branch is the latest development version, whereas the git release
;;; branch may be slightly older but is considered `stable'

;;; -- LICENSE START
;;; (This is the MIT / X Consortium license as taken from
;;;  http://www.opensource.org/licenses/mit-license.html on or about
;;;  Monday; July 13, 2009)
;;;
Raymond Toy's avatar
Raymond Toy committed
;;; Copyright (c) 2001-2012 Daniel Barlow and contributors
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining
;;; a copy of this software and associated documentation files (the
;;; "Software"), to deal in the Software without restriction, including
;;; without limitation the rights to use, copy, modify, merge, publish,
;;; distribute, sublicense, and/or sell copies of the Software, and to
;;; permit persons to whom the Software is furnished to do so, subject to
;;; the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
;;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
;;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
;;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
;;;
;;; -- LICENSE END

;;; The problem with writing a defsystem replacement is bootstrapping:
;;; we can't use defsystem to compile it.  Hence, all in one file.

rtoy's avatar
rtoy committed
#+xcvb (module ())
Raymond Toy's avatar
Raymond Toy committed
(cl:in-package :common-lisp-user)
#+genera (in-package :future-common-lisp-user)
Raymond Toy's avatar
Raymond Toy committed
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
rtoy's avatar
rtoy committed
(error "ASDF is not supported on your implementation. Please help us port it.")
rtoy's avatar
rtoy committed

Raymond Toy's avatar
Raymond Toy committed
;;;; Create and setup packages in a way that is compatible with hot-upgrade.
;;;; See https://bugs.launchpad.net/asdf/+bug/485687
;;;; See these two eval-when forms, and more near the end of the file.

rtoy's avatar
rtoy committed
#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this

Raymond Toy's avatar
Raymond Toy committed
(eval-when (:load-toplevel :compile-toplevel :execute)
  ;;; Before we do anything, some implementation-dependent tweaks
  ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults.
rtoy's avatar
rtoy committed
  #+allegro
  (setf excl::*autoload-package-name-alist*
        (remove "asdf" excl::*autoload-package-name-alist*
rtoy's avatar
rtoy committed
                :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
rtoy's avatar
rtoy committed
  #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
  (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
            (and (= system::*gcl-major-version* 2)
                 (< system::*gcl-minor-version* 7)))
    (pushnew :gcl-pre2.7 *features*))
Raymond Toy's avatar
Raymond Toy committed
  #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
        clozure lispworks (and sbcl sb-unicode) scl)
Raymond Toy's avatar
Raymond Toy committed
  (pushnew :asdf-unicode *features*)
rtoy's avatar
rtoy committed
  ;;; make package if it doesn't exist yet.
  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
  (unless (find-package :asdf)
    (make-package :asdf :use '(:common-lisp))))
rtoy's avatar
rtoy committed

(in-package :asdf)

(eval-when (:load-toplevel :compile-toplevel :execute)
Raymond Toy's avatar
Raymond Toy committed
  ;;; This would belong amongst implementation-dependent tweaks above,
  ;;; except that the defun has to be in package asdf.
  #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
  #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
Raymond Toy's avatar
Raymond Toy committed
  #+mkcl (require :cmp)
  #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics
Raymond Toy's avatar
Raymond Toy committed

  ;;; Package setup, step 2.
rtoy's avatar
rtoy committed
  (defvar *asdf-version* nil)
  (defvar *upgraded-p* nil)
rtoy's avatar
rtoy committed
  (defvar *asdf-verbose* nil) ; was t from 2.000 to 2.014.12.
  (defun find-symbol* (s p)
    (find-symbol (string s) p))
  ;; Strip out formatting that is not supported on Genera.
  ;; Has to be inside the eval-when to make Lispworks happy (!)
  (defun strcat (&rest strings)
    (apply 'concatenate 'string strings))
rtoy's avatar
rtoy committed
  (defmacro compatfmt (format)
rtoy's avatar
rtoy committed
    #-(or gcl genera) format
    #+(or gcl genera)
rtoy's avatar
rtoy committed
    (loop :for (unsupported . replacement) :in
      (append
       '(("~3i~_" . ""))
       #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
rtoy's avatar
rtoy committed
      (loop :for found = (search unsupported format) :while found :do
        (setf format (strcat (subseq format 0 found) replacement
                             (subseq format (+ found (length unsupported)))))))
rtoy's avatar
rtoy committed
    format)
rtoy's avatar
rtoy committed
  (let* (;; For bug reporting sanity, please always bump this version when you modify this file.
         ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version
         ;; can help you do these changes in synch (look at the source for documentation).
         ;; Relying on its automation, the version is now redundantly present on top of this file.
rtoy's avatar
rtoy committed
         ;; "2.345" would be an official release
         ;; "2.345.6" would be a development version in the official upstream
         ;; "2.345.0.7" would be your seventh local modification of official release 2.345
         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
Raymond Toy's avatar
Raymond Toy committed
         (asdf-version "2.26")
rtoy's avatar
rtoy committed
         (existing-asdf (find-class 'component nil))
rtoy's avatar
rtoy committed
         (existing-version *asdf-version*)
         (already-there (equal asdf-version existing-version)))
    (unless (and existing-asdf already-there)
rtoy's avatar
rtoy committed
      (when (and existing-asdf *asdf-verbose*)
rtoy's avatar
rtoy committed
        (format *trace-output*
rtoy's avatar
rtoy committed
                (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%")
                existing-version asdf-version))
          ((present-symbol-p (symbol package)
rtoy's avatar
rtoy committed
             (member (nth-value 1 (find-symbol* symbol package)) '(:internal :external)))
           (present-symbols (package)
             ;; #-genera (loop :for s :being :the :present-symbols :in package :collect s) #+genera
             (let (l)
               (do-symbols (s package)
                 (when (present-symbol-p s package) (push s l)))
               (reverse l)))
           (unlink-package (package)
rtoy's avatar
rtoy committed
             (let ((u (find-package package)))
               (when u
                 (ensure-unintern u (present-symbols u))
rtoy's avatar
rtoy committed
                 (loop :for p :in (package-used-by-list u) :do
                   (unuse-package u p))
                 (delete-package u))))
           (ensure-exists (name nicknames use)
rtoy's avatar
rtoy committed
             (let ((previous
                    (remove-duplicates
                     (mapcar #'find-package (cons name nicknames))
                     :from-end t)))
               ;; do away with packages with conflicting (nick)names
               (map () #'unlink-package (cdr previous))
               ;; reuse previous package with same name
               (let ((p (car previous)))
                 (cond
                   (p
                    (rename-package p name nicknames)
                    (ensure-use p use)
rtoy's avatar
rtoy committed
                    p)
                   (t
                    (make-package name :nicknames nicknames :use use))))))
           (intern* (symbol package)
             (intern (string symbol) package))
           (remove-symbol (symbol package)
rtoy's avatar
rtoy committed
             (let ((sym (find-symbol* symbol package)))
rtoy's avatar
rtoy committed
                 #-cormanlisp (unexport sym package)
rtoy's avatar
rtoy committed
                 (unintern sym package)
                 sym)))
           (ensure-unintern (package symbols)
rtoy's avatar
rtoy committed
             (loop :with packages = (list-all-packages)
               :for sym :in symbols
               :for removed = (remove-symbol sym package)
               :when removed :do
               (loop :for p :in packages :do
rtoy's avatar
rtoy committed
                 (when (eq removed (find-symbol* sym p))
rtoy's avatar
rtoy committed
                   (unintern removed p)))))
           (ensure-shadow (package symbols)
             (shadow symbols package))
           (ensure-use (package use)
Raymond Toy's avatar
Raymond Toy committed
             (dolist (used (package-use-list package))
               (unless (member (package-name used) use :test 'string=)
                 (unuse-package used)
                 (do-external-symbols (sym used)
                   (when (eq sym (find-symbol* sym package))
                     (remove-symbol sym package)))))
             (dolist (used (reverse use))
               (do-external-symbols (sym used)
rtoy's avatar
rtoy committed
                 (unless (eq sym (find-symbol* sym package))
                   (remove-symbol sym package)))
               (use-package used package)))
           (ensure-fmakunbound (package symbols)
             (loop :for name :in symbols
rtoy's avatar
rtoy committed
               :for sym = (find-symbol* name package)
               :when sym :do (fmakunbound sym)))
           (ensure-export (package export)
rtoy's avatar
rtoy committed
             (let ((formerly-exported-symbols nil)
                   (bothly-exported-symbols nil)
                   (newly-exported-symbols nil))
               (do-external-symbols (sym package)
rtoy's avatar
rtoy committed
                 (if (member sym export :test 'string-equal)
                     (push sym bothly-exported-symbols)
                     (push sym formerly-exported-symbols)))
               (loop :for sym :in export :do
                 (unless (member sym bothly-exported-symbols :test 'equal)
rtoy's avatar
rtoy committed
                   (push sym newly-exported-symbols)))
               (loop :for user :in (package-used-by-list package)
                 :for shadowing = (package-shadowing-symbols user) :do
                 (loop :for new :in newly-exported-symbols
rtoy's avatar
rtoy committed
                   :for old = (find-symbol* new user)
rtoy's avatar
rtoy committed
                   :when (and old (not (member old shadowing)))
                   :do (unintern old user)))
               (loop :for x :in newly-exported-symbols :do
                 (export (intern* x package)))))
           (ensure-package (name &key nicknames use unintern
                                 shadow export redefined-functions)
rtoy's avatar
rtoy committed
             (let* ((p (ensure-exists name nicknames use)))
Raymond Toy's avatar
Raymond Toy committed
               (ensure-unintern p (append unintern #+cmu redefined-functions))
               (ensure-shadow p shadow)
               (ensure-export p export)
Raymond Toy's avatar
Raymond Toy committed
               #-cmu (ensure-fmakunbound p redefined-functions)
               p)))
        (macrolet
            ((pkgdcl (name &key nicknames use export
                           redefined-functions unintern shadow)
rtoy's avatar
rtoy committed
                 `(ensure-package
                   ',name :nicknames ',nicknames :use ',use :export ',export
                   :shadow ',shadow
rtoy's avatar
rtoy committed
                   :unintern ',unintern
                   :redefined-functions ',redefined-functions)))
rtoy's avatar
rtoy committed
           :use (:common-lisp)
           :redefined-functions
           (#:perform #:explain #:output-files #:operation-done-p
            #:perform-with-restarts #:component-relative-pathname
rtoy's avatar
rtoy committed
            #:system-source-file #:operate #:find-component #:find-system
            #:apply-output-translations #:translate-pathname* #:resolve-location
            #:system-relative-pathname
            #:inherit-source-registry #:process-source-registry
            #:process-source-registry-directive
rtoy's avatar
rtoy committed
            #:compile-file* #:source-file-type)
           :unintern
           (#:*asdf-revision* #:around #:asdf-method-combination
            #:split #:make-collector #:do-dep #:do-one-dep
            #:resolve-relative-location-component #:resolve-absolute-location-component
rtoy's avatar
rtoy committed
            #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
           (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
rtoy's avatar
rtoy committed
            #:system-definition-pathname #:with-system-definitions
            #:search-for-system-definition #:find-component #:component-find-path
Raymond Toy's avatar
Raymond Toy committed
            #:compile-system #:load-system #:load-systems
            #:require-system #:test-system #:clear-system
            #:operation #:compile-op #:load-op #:load-source-op #:test-op
            #:feature #:version #:version-satisfies
rtoy's avatar
rtoy committed
            #:upgrade-asdf
Raymond Toy's avatar
Raymond Toy committed
            #:implementation-identifier #:implementation-type #:hostname
            #:input-files #:output-files #:output-file #:perform
            #:operation-done-p #:explain

            #:component #:source-file
            #:c-source-file #:cl-source-file #:java-source-file
rtoy's avatar
rtoy committed
            #:cl-source-file.cl #:cl-source-file.lsp
            #:static-file
            #:doc-file
            #:html-file
            #:text-file
            #:source-file-type
            #:module                     ; components
            #:system
            #:unix-dso

            #:module-components          ; component accessors
Raymond Toy's avatar
Raymond Toy committed
            #:module-components-by-name
            #:component-pathname
            #:component-relative-pathname
            #:component-name
            #:component-version
            #:component-parent
            #:component-property
            #:component-system
            #:component-depends-on
Raymond Toy's avatar
Raymond Toy committed
            #:component-encoding
            #:component-external-format

            #:system-description
            #:system-long-description
            #:system-author
            #:system-maintainer
            #:system-license
            #:system-licence
            #:system-source-file
            #:system-source-directory
            #:system-relative-pathname
            #:map-systems

rtoy's avatar
rtoy committed
            #:operation-description
            #:operation-on-warnings
            #:operation-on-failure
rtoy's avatar
rtoy committed
            #:component-visited-p
Raymond Toy's avatar
Raymond Toy committed

            #:*system-definition-search-functions*   ; variables
            #:*central-registry*
            #:*compile-file-warnings-behaviour*
            #:*compile-file-failure-behaviour*
            #:*resolve-symlinks*
Raymond Toy's avatar
Raymond Toy committed
            #:*load-system-operation*
            #:*asdf-verbose*
            #:*verbose-out*

            #:asdf-version

            #:operation-error #:compile-failed #:compile-warned #:compile-error
            #:error-name
            #:error-pathname
            #:load-system-definition-error
            #:error-component #:error-operation
            #:system-definition-error
            #:missing-component
            #:missing-component-of-version
            #:missing-dependency
            #:missing-dependency-of-version
            #:circular-dependency        ; errors
            #:duplicate-names

            #:try-recompiling
            #:retry
            #:accept                     ; restarts
            #:coerce-entry-to-directory
            #:remove-entry-from-registry

Raymond Toy's avatar
Raymond Toy committed
            #:*encoding-detection-hook*
            #:*encoding-external-format-hook*
            #:*default-encoding*
            #:*utf-8-external-format*

rtoy's avatar
rtoy committed
            #:clear-configuration
            #:*output-translations-parameter*
            #:initialize-output-translations
            #:disable-output-translations
            #:clear-output-translations
            #:ensure-output-translations
            #:apply-output-translations
rtoy's avatar
rtoy committed
            #:compile-file*
            #:compile-file-pathname*
            #:enable-asdf-binary-locations-compatibility
            #:*default-source-registries*
            #:*source-registry-parameter*
            #:initialize-source-registry
            #:compute-source-registry
            #:clear-source-registry
            #:ensure-source-registry
rtoy's avatar
rtoy committed
            #:process-source-registry
Raymond Toy's avatar
Raymond Toy committed
            #:system-registered-p #:registered-systems #:loaded-systems
            #:resolve-location
rtoy's avatar
rtoy committed
            #:asdf-message
            #:user-output-translations-pathname
            #:system-output-translations-pathname
            #:user-output-translations-directory-pathname
            #:system-output-translations-directory-pathname
            #:user-source-registry
            #:system-source-registry
            #:user-source-registry-directory
            #:system-source-registry-directory
            ;; Utilities: please use asdf-utils instead
            #|
rtoy's avatar
rtoy committed
            ;; #:aif #:it
            ;; #:appendf #:orf
Raymond Toy's avatar
Raymond Toy committed
            #:length=n-p
            #:remove-keys #:remove-keyword
Raymond Toy's avatar
Raymond Toy committed
            #:first-char #:last-char #:string-suffix-p
rtoy's avatar
rtoy committed
            #:coerce-name
Raymond Toy's avatar
Raymond Toy committed
            #:directory-pathname-p #:ensure-directory-pathname
            #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root
Raymond Toy's avatar
Raymond Toy committed
            #:getenv #:getenv-pathname #:getenv-pathnames
Raymond Toy's avatar
Raymond Toy committed
            #:getenv-absolute-directory #:getenv-absolute-directories
Raymond Toy's avatar
Raymond Toy committed
            #:probe-file*
            #:find-symbol* #:strcat
            #:make-pathname-component-logical #:make-pathname-logical
            #:merge-pathnames* #:coerce-pathname #:subpathname #:subpathname*
            #:pathname-directory-pathname #:pathname-parent-directory-pathname
rtoy's avatar
rtoy committed
            #:read-file-forms
Raymond Toy's avatar
Raymond Toy committed
            #:resolve-symlinks #:truenamize
rtoy's avatar
rtoy committed
            #:split-string
            #:component-name-to-pathname-components
            #:split-name-type
Raymond Toy's avatar
Raymond Toy committed
            #:subdirectories #:directory-files
            #:while-collecting
            #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
            #:*wild-path* #:wilden
            #:directorize-pathname-host-device|#
Raymond Toy's avatar
Raymond Toy committed
            )))
rtoy's avatar
rtoy committed
        #+genera (import 'scl:boolean :asdf)
rtoy's avatar
rtoy committed
        (setf *asdf-version* asdf-version
              *upgraded-p* (if existing-version
                               (cons existing-version *upgraded-p*)
                               *upgraded-p*))))))

;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
;;;;
(defvar *resolve-symlinks* t
  "Determine whether or not ASDF resolves symlinks when defining systems.

rtoy's avatar
rtoy committed
Defaults to T.")
rtoy's avatar
rtoy committed
(defvar *compile-file-warnings-behaviour*
  (or #+clisp :ignore :warn)
  "How should ASDF react if it encounters a warning when compiling a file?
Valid values are :error, :warn, and :ignore.")
rtoy's avatar
rtoy committed
(defvar *compile-file-failure-behaviour*
  (or #+sbcl :error #+clisp :ignore :warn)
  "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE)
when compiling a file?  Valid values are :error, :warn, and :ignore.
Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")

(defvar *verbose-out* nil)

(defparameter +asdf-methods+
  '(perform-with-restarts perform explain output-files operation-done-p))

Raymond Toy's avatar
Raymond Toy committed
(defvar *load-system-operation* 'load-op
  "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")

(defvar *compile-op-compile-file-function* 'compile-file*
  "Function used to compile lisp files.")



#+allegro
(eval-when (:compile-toplevel :execute)
  (defparameter *acl-warn-save*
                (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
                  excl:*warn-on-nested-reader-conditionals*))
  (when (boundp 'excl:*warn-on-nested-reader-conditionals*)
    (setf excl:*warn-on-nested-reader-conditionals* nil)))

rtoy's avatar
rtoy committed
;;;; -------------------------------------------------------------------------
;;;; Resolve forward references

(declaim (ftype (function (t) t)
                format-arguments format-control
                error-name error-pathname error-condition
                duplicate-names-name
                error-component error-operation
                module-components module-components-by-name
                circular-dependency-components
                condition-arguments condition-form
                condition-format condition-location
                coerce-name)
         (ftype (function (&optional t) (values)) initialize-source-registry)
rtoy's avatar
rtoy committed
         #-(or cormanlisp gcl-pre2.7)
rtoy's avatar
rtoy committed
         (ftype (function (t t) t) (setf module-components-by-name)))

;;;; -------------------------------------------------------------------------
rtoy's avatar
rtoy committed
;;;; Compatibility various implementations
rtoy's avatar
rtoy committed
#+cormanlisp
(progn
  (deftype logical-pathname () nil)
  (defun make-broadcast-stream () *error-output*)
  (defun translate-logical-pathname (x) x)
  (defun file-namestring (p)
rtoy's avatar
rtoy committed
    (setf p (pathname p))
rtoy's avatar
rtoy committed
    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))

#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl
      (read-from-string
       "(eval-when (:compile-toplevel :load-toplevel :execute)
          (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string)
          (ccl:define-entry-point (_system \"system\") ((name :string)) :int)
          ;; Note: ASDF may expect user-homedir-pathname to provide
          ;; the pathname of the current user's home directory, whereas
          ;; MCL by default provides the directory from which MCL was started.
          ;; See http://code.google.com/p/mcl/wiki/Portability
          (defun current-user-homedir-pathname ()
            (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))
          (defun probe-posix (posix-namestring)
            \"If a file exists for the posix namestring, return the pathname\"
            (ccl::with-cstrs ((cpath posix-namestring))
              (ccl::rlet ((is-dir :boolean)
                          (fsref :fsref))
                (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir))
                  (ccl::%path-from-fsref fsref is-dir))))))"))
rtoy's avatar
rtoy committed

;;;; -------------------------------------------------------------------------
rtoy's avatar
rtoy committed
;;;; General Purpose Utilities

rtoy's avatar
rtoy committed
(macrolet
    ((defdef (def* def)
       `(defmacro ,def* (name formals &rest rest)
          `(progn
rtoy's avatar
rtoy committed
             #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
rtoy's avatar
rtoy committed
             #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
             ,(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl
                `(declaim (notinline ,name)))
rtoy's avatar
rtoy committed
             (,',def ,name ,formals ,@rest)))))
  (defdef defgeneric* defgeneric)
  (defdef defun* defun))

(defmacro while-collecting ((&rest collectors) &body body)
rtoy's avatar
rtoy committed
  "COLLECTORS should be a list of names for collections.  A collector
defines a function that, when applied to an argument inside BODY, will
add its argument to the corresponding collection.  Returns multiple values,
a list for each collection, in order.
   E.g.,
\(while-collecting \(foo bar\)
           \(dolist \(x '\(\(a 1\) \(b 2\) \(c 3\)\)\)
             \(foo \(first x\)\)
             \(bar \(second x\)\)\)\)
Returns two values: \(A B C\) and \(1 2 3\)."
  (let ((vars (mapcar #'(lambda (x) (gensym (symbol-name x))) collectors))
        (initial-values (mapcar (constantly nil) collectors)))
    `(let ,(mapcar #'list vars initial-values)
       (flet ,(mapcar #'(lambda (c v) `(,c (x) (push x ,v) (values))) collectors vars)
         ,@body
         (values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))

(defmacro aif (test then &optional else)
Raymond Toy's avatar
Raymond Toy committed
  "Anaphoric version of IF, On Lisp style"
  `(let ((it ,test)) (if it ,then ,else)))

rtoy's avatar
rtoy committed
(defun* pathname-directory-pathname (pathname)
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
  (when pathname
    (make-pathname :name nil :type nil :version nil :defaults pathname)))
(defun* normalize-pathname-directory-component (directory)
Raymond Toy's avatar
Raymond Toy committed
  "Given a pathname directory component, return an equivalent form that is a list"
Raymond Toy's avatar
Raymond Toy committed
    #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
    ((stringp directory) `(:absolute ,directory) directory)
    #+gcl
    ((and (consp directory) (stringp (first directory)))
     `(:absolute ,@directory))
    ((or (null directory)
         (and (consp directory) (member (first directory) '(:absolute :relative))))
     directory)
    (t
rtoy's avatar
rtoy committed
     (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))

(defun* merge-pathname-directory-components (specified defaults)
Raymond Toy's avatar
Raymond Toy committed
  ;; Helper for merge-pathnames* that handles directory components.
  (let ((directory (normalize-pathname-directory-component specified)))
    (ecase (first directory)
      ((nil) defaults)
      (:absolute specified)
      (:relative
       (let ((defdir (normalize-pathname-directory-component defaults))
             (reldir (cdr directory)))
         (cond
           ((null defdir)
            directory)
           ((not (eq :back (first reldir)))
            (append defdir reldir))
           (t
            (loop :with defabs = (first defdir)
              :with defrev = (reverse (rest defdir))
              :while (and (eq :back (car reldir))
                          (or (and (eq :absolute defabs) (null defrev))
                              (stringp (car defrev))))
              :do (pop reldir) (pop defrev)
              :finally (return (cons defabs (append (reverse defrev) reldir)))))))))))

Raymond Toy's avatar
Raymond Toy committed
(defun* make-pathname-component-logical (x)
  "Make a pathname component suitable for use in a logical-pathname"
  (typecase x
    ((eql :unspecific) nil)
    #+clisp (string (string-upcase x))
    #+clisp (cons (mapcar 'make-pathname-component-logical x))
    (t x)))

(defun* make-pathname-logical (pathname host)
  "Take a PATHNAME's directory, name, type and version components,
and make a new pathname with corresponding components and specified logical HOST"
  (make-pathname
   :host host
   :directory (make-pathname-component-logical (pathname-directory pathname))
   :name (make-pathname-component-logical (pathname-name pathname))
   :type (make-pathname-component-logical (pathname-type pathname))
   :version (make-pathname-component-logical (pathname-version pathname))))
rtoy's avatar
rtoy committed
(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
rtoy's avatar
rtoy committed
  "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that
if the SPECIFIED pathname does not have an absolute directory,
then the HOST and DEVICE both come from the DEFAULTS, whereas
if the SPECIFIED pathname does have an absolute directory,
then the HOST and DEVICE both come from the SPECIFIED.
Also, if either argument is NIL, then the other argument is returned unmodified."
  (when (null specified) (return-from merge-pathnames* defaults))
  (when (null defaults) (return-from merge-pathnames* specified))
rtoy's avatar
rtoy committed
  #+scl
  (ext:resolve-pathname specified defaults)
  #-scl
  (let* ((specified (pathname specified))
         (defaults (pathname defaults))
         (directory (normalize-pathname-directory-component (pathname-directory specified)))
         (name (or (pathname-name specified) (pathname-name defaults)))
         (type (or (pathname-type specified) (pathname-type defaults)))
         (version (or (pathname-version specified) (pathname-version defaults))))
    (labels ((unspecific-handler (p)
Raymond Toy's avatar
Raymond Toy committed
               (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
      (multiple-value-bind (host device directory unspecific-handler)
rtoy's avatar
rtoy committed
          (ecase (first directory)
            ((:absolute)
             (values (pathname-host specified)
                     (pathname-device specified)
                     directory
                     (unspecific-handler specified)))
            ((nil :relative)
             (values (pathname-host defaults)
                     (pathname-device defaults)
                     (merge-pathname-directory-components directory (pathname-directory defaults))
                     (unspecific-handler defaults))))
        (make-pathname :host host :device device :directory directory
                       :name (funcall unspecific-handler name)
                       :type (funcall unspecific-handler type)
                       :version (funcall unspecific-handler version))))))

(defun* pathname-parent-directory-pathname (pathname)
  "Returns a new pathname with same HOST, DEVICE, DIRECTORY as PATHNAME,
and NIL NAME, TYPE and VERSION components"
  (when pathname
    (make-pathname :name nil :type nil :version nil
rtoy's avatar
rtoy committed
                   :directory (merge-pathname-directory-components
                               '(:relative :back) (pathname-directory pathname))
                   :defaults pathname)))

(define-modify-macro appendf (&rest args)
  append "Append onto list") ;; only to be used on short lists.

(define-modify-macro orf (&rest args)
  or "or a flag")

rtoy's avatar
rtoy committed
(defun* first-char (s)
  (and (stringp s) (plusp (length s)) (char s 0)))

rtoy's avatar
rtoy committed
(defun* last-char (s)
  (and (stringp s) (plusp (length s)) (char s (1- (length s)))))

rtoy's avatar
rtoy committed

rtoy's avatar
rtoy committed
(defun* asdf-message (format-string &rest format-args)
  (declare (dynamic-extent format-args))
rtoy's avatar
rtoy committed
  (apply 'format *verbose-out* format-string format-args))
rtoy's avatar
rtoy committed
(defun* split-string (string &key max (separator '(#\Space #\Tab)))
  "Split STRING into a list of components separated by
any of the characters in the sequence SEPARATOR.
If MAX is specified, then no more than max(1,MAX) components will be returned,
starting the separation from the end, e.g. when called with arguments
 \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")."
rtoy's avatar
rtoy committed
  (catch nil
    (let ((list nil) (words 0) (end (length string)))
      (flet ((separatorp (char) (find char separator))
rtoy's avatar
rtoy committed
             (done () (throw nil (cons (subseq string 0 end) list))))
        (loop
          :for start = (if (and max (>= words (1- max)))
                           (done)
                           (position-if #'separatorp string :end end :from-end t)) :do
          (when (null start)
            (done))
          (push (subseq string (1+ start) end) list)
          (incf words)
          (setf end start))))))

rtoy's avatar
rtoy committed
(defun* split-name-type (filename)
  (let ((unspecific
         ;; Giving :unspecific as argument to make-pathname is not portable.
         ;; See CLHS make-pathname and 19.2.2.2.3.
Raymond Toy's avatar
Raymond Toy committed
         ;; We only use it on implementations that support it,
Raymond Toy's avatar
Raymond Toy committed
         #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
Raymond Toy's avatar
Raymond Toy committed
         #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil))
    (destructuring-bind (name &optional (type unspecific))
        (split-string filename :max 2 :separator ".")
      (if (equal name "")
          (values filename unspecific)
          (values name type)))))

rtoy's avatar
rtoy committed
(defun* component-name-to-pathname-components (s &key force-directory force-relative)
  "Splits the path string S, returning three values:
A flag that is either :absolute or :relative, indicating
   how the rest of the values are to be interpreted.
A directory path --- a list of strings, suitable for
   use with MAKE-PATHNAME when prepended with the flag
   value.
A filename with type extension, possibly NIL in the
   case of a directory pathname.
FORCE-DIRECTORY forces S to be interpreted as a directory
pathname \(third return value will be NIL, final component
of S will be treated as part of the directory path.

The intention of this function is to support structured component names,
e.g., \(:file \"foo/bar\"\), which will be unpacked to relative
pathnames."
  (check-type s string)
rtoy's avatar
rtoy committed
  (when (find #\: s)
rtoy's avatar
rtoy committed
    (error (compatfmt "~@<A portable ASDF pathname designator cannot include a #\: character: ~3i~_~S~@:>") s))
  (let* ((components (split-string s :separator "/"))
         (last-comp (car (last components))))
    (multiple-value-bind (relative components)
        (if (equal (first components) "")
            (if (equal (first-char s) #\/)
rtoy's avatar
rtoy committed
                (progn
                  (when force-relative
rtoy's avatar
rtoy committed
                    (error (compatfmt "~@<Absolute pathname designator not allowed: ~3i~_~S~@:>") s))
rtoy's avatar
rtoy committed
                  (values :absolute (cdr components)))
                (values :relative nil))
          (values :relative components))
      (setf components (remove-if #'(lambda (x) (member x '("" ".") :test #'equal)) components))
      (setf components (substitute :back ".." components :test #'equal))
      (cond
        ((equal last-comp "")
rtoy's avatar
rtoy committed
         (values relative components nil)) ; "" already removed
        (force-directory
         (values relative components nil))
        (t
         (values relative (butlast components) last-comp))))))

rtoy's avatar
rtoy committed
(defun* remove-keys (key-names args)
  (loop :for (name val) :on args :by #'cddr
    :unless (member (symbol-name name) key-names
                    :key #'symbol-name :test 'equal)
    :append (list name val)))

rtoy's avatar
rtoy committed
(defun* remove-keyword (key args)
  (loop :for (k v) :on args :by #'cddr
    :unless (eq k key)
    :append (list k v)))

rtoy's avatar
rtoy committed
(defun* getenv (x)
  (declare (ignorable x))
  #+(or abcl clisp ecl xcl) (ext:getenv x)
  #+allegro (sys:getenv x)
  #+clozure (ccl:getenv x)
  #+(or cmu scl) (cdr (assoc x ext:*environment-list* :test #'string=))
rtoy's avatar
rtoy committed
  #+cormanlisp
  (let* ((buffer (ct:malloc 1))
         (cname (ct:lisp-string-to-c-string x))
         (needed-size (win:getenvironmentvariable cname buffer 0))
         (buffer1 (ct:malloc (1+ needed-size))))
    (prog1 (if (zerop (win:getenvironmentvariable cname buffer1 needed-size))
               nil
               (ct:c-string-to-lisp-string buffer1))
      (ct:free buffer)
      (ct:free buffer1)))
  #+gcl (system:getenv x)
  #+genera nil
  #+lispworks (lispworks:environment-variable x)
  #+mcl (ccl:with-cstrs ((name x))
          (let ((value (_getenv name)))
            (unless (ccl:%null-ptr-p value)
              (ccl:%get-cstring value))))
Raymond Toy's avatar
Raymond Toy committed
  #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x)
  #+sbcl (sb-ext:posix-getenv x)
Raymond Toy's avatar
Raymond Toy committed
  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
rtoy's avatar
rtoy committed
  (error "~S is not supported on your implementation" 'getenv))
rtoy's avatar
rtoy committed

(defun* directory-pathname-p (pathname)
  "Does PATHNAME represent a directory?

A directory-pathname is a pathname _without_ a filename. The three
ways that the filename components can be missing are for it to be NIL,
:UNSPECIFIC or the empty string.
Note that this does _not_ check to see that PATHNAME points to an
actually-existing directory."
rtoy's avatar
rtoy committed
  (when pathname
    (let ((pathname (pathname pathname)))
      (flet ((check-one (x)
               (member x '(nil :unspecific "") :test 'equal)))
        (and (not (wild-pathname-p pathname))
             (check-one (pathname-name pathname))
             (check-one (pathname-type pathname))
             t)))))
rtoy's avatar
rtoy committed
(defun* ensure-directory-pathname (pathspec)
  "Converts the non-wild pathname designator PATHSPEC to directory form."
  (cond
   ((stringp pathspec)
    (ensure-directory-pathname (pathname pathspec)))
   ((not (pathnamep pathspec))
rtoy's avatar
rtoy committed
    (error (compatfmt "~@<Invalid pathname designator ~S~@:>") pathspec))
   ((wild-pathname-p pathspec)
rtoy's avatar
rtoy committed
    (error (compatfmt "~@<Can't reliably convert wild pathname ~3i~_~S~@:>") pathspec))
   ((directory-pathname-p pathspec)
    pathspec)
   (t
    (make-pathname :directory (append (or (pathname-directory pathspec)
                                          (list :relative))
                                      (list (file-namestring pathspec)))
                   :name nil :type nil :version nil
                   :defaults pathspec))))

#+genera
(unless (fboundp 'ensure-directories-exist)
rtoy's avatar
rtoy committed
  (defun* ensure-directories-exist (path)
    (fs:create-directories-recursively (pathname path))))

rtoy's avatar
rtoy committed
(defun* absolute-pathname-p (pathspec)
rtoy's avatar
rtoy committed
  (and (typep pathspec '(or pathname string))
       (eq :absolute (car (pathname-directory (pathname pathspec))))))
Raymond Toy's avatar
Raymond Toy committed
(defun* coerce-pathname (name &key type defaults)
  "coerce NAME into a PATHNAME.
When given a string, portably decompose it into a relative pathname:
#\\/ separates subdirectories. The last #\\/-separated string is as follows:
if TYPE is NIL, its last #\\. if any separates name and type from from type;
if TYPE is a string, it is the type, and the whole string is the name;
if TYPE is :DIRECTORY, the string is a directory component;
if the string is empty, it's a directory.
Any directory named .. is read as :BACK.
Host, device and version components are taken from DEFAULTS."
  ;; The defaults are required notably because they provide the default host
  ;; to the below make-pathname, which may crucially matter to people using
  ;; merge-pathnames with non-default hosts,  e.g. for logical-pathnames.
  ;; NOTE that the host and device slots will be taken from the defaults,
  ;; but that should only matter if you later merge relative pathnames with
  ;; CL:MERGE-PATHNAMES instead of ASDF:MERGE-PATHNAMES*
  (etypecase name
    ((or null pathname)
     name)
    (symbol
     (coerce-pathname (string-downcase name) :type type :defaults defaults))
    (string
     (multiple-value-bind (relative path filename)
         (component-name-to-pathname-components name :force-directory (eq type :directory)
                                                :force-relative t)
       (multiple-value-bind (name type)
           (cond
             ((or (eq type :directory) (null filename))
              (values nil nil))
             (type
              (values filename type))
             (t
              (split-name-type filename)))
         (apply 'make-pathname :directory (cons relative path) :name name :type type
                (when defaults `(:defaults ,defaults))))))))

(defun* merge-component-name-type (name &key type defaults)
  ;; For backwards compatibility only, for people using internals.
  ;; Will be removed in a future release, e.g. 2.016.
  (warn "Please don't use ASDF::MERGE-COMPONENT-NAME-TYPE. Use ASDF:COERCE-PATHNAME.")
  (coerce-pathname name :type type :defaults defaults))

(defun* subpathname (pathname subpath &key type)
  (and pathname (merge-pathnames* (coerce-pathname subpath :type type)
                                  (pathname-directory-pathname pathname))))

(defun subpathname* (pathname subpath &key type)
  (and pathname
       (subpathname (ensure-directory-pathname pathname) subpath :type type)))

rtoy's avatar
rtoy committed
(defun* length=n-p (x n) ;is it that (= (length x) n) ?
  (check-type n (integer 0 *))
  (loop
    :for l = x :then (cdr l)
    :for i :downfrom n :do
    (cond
      ((zerop i) (return (null l)))
      ((not (consp l)) (return nil)))))

Raymond Toy's avatar
Raymond Toy committed
(defun* string-suffix-p (s suffix)
  (check-type s string)
  (check-type suffix string)
  (let ((start (- (length s) (length suffix))))
    (and (<= 0 start)
         (string-equal s suffix :start1 start))))

rtoy's avatar
rtoy committed
(defun* read-file-forms (file)
  (with-open-file (in file)
    (loop :with eof = (list nil)
     :for form = (read in nil eof)
     :until (eq form eof)
     :collect form)))

rtoy's avatar
rtoy committed
(defun* pathname-root (pathname)
rtoy's avatar
rtoy committed
  (make-pathname :directory '(:absolute)
                 :name nil :type nil :version nil
rtoy's avatar
rtoy committed
                 :defaults pathname ;; host device, and on scl, *some*
                 ;; scheme-specific parts: port username password, not others:
rtoy's avatar
rtoy committed
                 . #.(or #+scl '(:parameters nil :query nil :fragment nil))))
rtoy's avatar
rtoy committed
(defun* probe-file* (p)
  "when given a pathname P, probes the filesystem for a file or directory
with given pathname and if it exists return its truename."
rtoy's avatar
rtoy committed
  (etypecase p
rtoy's avatar
rtoy committed
    (null nil)
    (string (probe-file* (parse-namestring p)))
    (pathname (unless (wild-pathname-p p)
Raymond Toy's avatar
Raymond Toy committed
                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl)
rtoy's avatar
rtoy committed
                      '(probe-file p)
rtoy's avatar
rtoy committed
                      #+clisp (aif (find-symbol* '#:probe-pathname :ext)
                                   `(ignore-errors (,it p)))
                      '(ignore-errors (truename p)))))))
rtoy's avatar
rtoy committed
(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
  "Resolve as much of a pathname as possible"
  (block nil
rtoy's avatar
rtoy committed
    (when (typep pathname '(or null logical-pathname)) (return pathname))
    (let ((p (merge-pathnames* pathname defaults)))
      (when (typep p 'logical-pathname) (return p))
rtoy's avatar
rtoy committed
      (let ((found (probe-file* p)))
        (when found (return found)))
rtoy's avatar
rtoy committed
      (unless (absolute-pathname-p p)
        (let ((true-defaults (ignore-errors (truename defaults))))
          (when true-defaults
            (setf p (merge-pathnames pathname true-defaults)))))
      (unless (absolute-pathname-p p) (return p))
rtoy's avatar
rtoy committed
      (let ((sofar (probe-file* (pathname-root p))))
        (unless sofar (return p))
        (flet ((solution (directories)
                 (merge-pathnames*
                  (make-pathname :host nil :device nil
                                 :directory `(:relative ,@directories)
                                 :name (pathname-name p)
                                 :type (pathname-type p)
                                 :version (pathname-version p))
                  sofar)))
rtoy's avatar
rtoy committed
          (loop :with directory = (normalize-pathname-directory-component
                                   (pathname-directory p))
            :for component :in (cdr directory)
            :for rest :on (cdr directory)
rtoy's avatar
rtoy committed
            :for more = (probe-file*
                         (merge-pathnames*
                          (make-pathname :directory `(:relative ,component))
                          sofar)) :do
            (if more
                (setf sofar more)
                (return (solution rest)))
            :finally
            (return (solution nil))))))))

rtoy's avatar
rtoy committed
(defun* resolve-symlinks (path)
  #-allegro (truenamize path)
  #+allegro (if (typep path 'logical-pathname)
                path
                (excl:pathname-resolve-symbolic-links path)))
rtoy's avatar
rtoy committed
(defun* resolve-symlinks* (path)
  (if *resolve-symlinks*
      (and path (resolve-symlinks path))
      path))

rtoy's avatar
rtoy committed
(defun* ensure-pathname-absolute (path)
rtoy's avatar
rtoy committed
  (cond
    ((absolute-pathname-p path) path)
    ((stringp path) (ensure-pathname-absolute (pathname path)))
    ((not (pathnamep path)) (error "not a valid pathname designator ~S" path))
    (t (let ((resolved (resolve-symlinks path)))
         (assert (absolute-pathname-p resolved))
         resolved))))

rtoy's avatar
rtoy committed
(defun* default-directory ()
  (truenamize (pathname-directory-pathname *default-pathname-defaults*)))

rtoy's avatar
rtoy committed
(defun* lispize-pathname (input-file)
  (make-pathname :type "lisp" :defaults input-file))

rtoy's avatar
rtoy committed
(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
(defparameter *wild-file*
rtoy's avatar
rtoy committed
  (make-pathname :name *wild* :type *wild*
                 :version (or #-(or abcl xcl) *wild*) :directory nil))
(defparameter *wild-directory*
rtoy's avatar
rtoy committed
  (make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
(defparameter *wild-inferiors*
  (make-pathname :directory '(:relative :wild-inferiors) :name nil :type nil :version nil))
(defparameter *wild-path*
  (merge-pathnames *wild-file* *wild-inferiors*))
rtoy's avatar
rtoy committed
(defun* wilden (path)
  (merge-pathnames* *wild-path* path))

rtoy's avatar
rtoy committed
#-scl
rtoy's avatar
rtoy committed
(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
  (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
    (last-char (namestring foo))))

rtoy's avatar
rtoy committed
#-scl
rtoy's avatar
rtoy committed
(defun* directorize-pathname-host-device (pathname)
  (let* ((root (pathname-root pathname))
         (wild-root (wilden root))
         (absolute-pathname (merge-pathnames* pathname root))
         (separator (directory-separator-for-host root))
         (root-namestring (namestring root))
         (root-string
          (substitute-if #\/
                         #'(lambda (x) (or (eql x #\:)
                                           (eql x separator)))
                         root-namestring)))
    (multiple-value-bind (relative path filename)
rtoy's avatar
rtoy committed
        (component-name-to-pathname-components root-string :force-directory t)
      (declare (ignore relative filename))
      (let ((new-base
             (make-pathname :defaults root
                            :directory `(:absolute ,@path))))
        (translate-pathname absolute-pathname wild-root (wilden new-base))))))