-;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.015.1: Another System Definition Facility.
+;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
+;;; 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>.
;;; http://www.opensource.org/licenses/mit-license.html on or about
;;; Monday; July 13, 2009)
;;;
-;;; Copyright (c) 2001-2011 Daniel Barlow and contributors
+;;; 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
#+xcvb (module ())
-(cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user)
+(cl:in-package :common-lisp-user)
+#+genera (in-package :future-common-lisp-user)
-#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
-(error "ASDF is not supported on your implementation. Please help us with it.")
+#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
+(error "ASDF is not supported on your implementation. Please help us port it.")
+
+;;;; 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.
#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this
-(eval-when (:compile-toplevel :load-toplevel :execute)
- ;;; Implementation-dependent tweaks
- ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
+(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.
#+allegro
(setf excl::*autoload-package-name-alist*
(remove "asdf" excl::*autoload-package-name-alist*
:test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below
- #+(and ecl (not ecl-bytecmp)) (require :cmp)
- #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
- #+(or unix cygwin) (pushnew :asdf-unix *features*)
+ #+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*))
+ #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
+ clozure lispworks (and sbcl sb-unicode) scl)
+ (pushnew :asdf-unicode *features*)
;;; make package if it doesn't exist yet.
;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
(unless (find-package :asdf)
(in-package :asdf)
-;;;; Create packages in a way that is compatible with hot-upgrade.
-;;;; See https://bugs.launchpad.net/asdf/+bug/485687
-;;;; See more near the end of the file.
-
(eval-when (:load-toplevel :compile-toplevel :execute)
+ ;;; 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))
+ #+mkcl (require :cmp)
+ #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics
+
+ ;;; Package setup, step 2.
(defvar *asdf-version* nil)
(defvar *upgraded-p* nil)
(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))
(defmacro compatfmt (format)
- #-genera format
- #+genera
+ #-(or gcl genera) format
+ #+(or gcl genera)
(loop :for (unsupported . replacement) :in
- '(("~@<" . "")
- ("; ~@;" . "; ")
- ("~3i~_" . "")
- ("~@:>" . "")
- ("~:>" . "")) :do
+ (append
+ '(("~3i~_" . ""))
+ #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do
(loop :for found = (search unsupported format) :while found :do
- (setf format
- (concatenate 'simple-string
- (subseq format 0 found) replacement
- (subseq format (+ found (length unsupported)))))))
+ (setf format (strcat (subseq format 0 found) replacement
+ (subseq format (+ found (length unsupported)))))))
format)
(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
;; "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
- (asdf-version "2.015.1")
- (existing-asdf (fboundp 'find-system))
+ (asdf-version "2.26")
+ (existing-asdf (find-class 'component nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
(unless (and existing-asdf already-there)
existing-version asdf-version))
(labels
((present-symbol-p (symbol package)
- (member (nth-value 1 (find-sym symbol package)) '(:internal :external)))
+ (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)
p)
(t
(make-package name :nicknames nicknames :use use))))))
- (find-sym (symbol package)
- (find-symbol (string symbol) package))
(intern* (symbol package)
(intern (string symbol) package))
(remove-symbol (symbol package)
- (let ((sym (find-sym symbol package)))
+ (let ((sym (find-symbol* symbol package)))
(when sym
#-cormanlisp (unexport sym package)
(unintern sym package)
:for removed = (remove-symbol sym package)
:when removed :do
(loop :for p :in packages :do
- (when (eq removed (find-sym sym p))
+ (when (eq removed (find-symbol* sym p))
(unintern removed p)))))
(ensure-shadow (package symbols)
(shadow symbols package))
(ensure-use (package use)
+ (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)
- (unless (eq sym (find-sym sym package))
+ (unless (eq sym (find-symbol* sym package))
(remove-symbol sym package)))
(use-package used package)))
(ensure-fmakunbound (package symbols)
(loop :for name :in symbols
- :for sym = (find-sym name package)
+ :for sym = (find-symbol* name package)
:when sym :do (fmakunbound sym)))
(ensure-export (package export)
(let ((formerly-exported-symbols nil)
(push sym bothly-exported-symbols)
(push sym formerly-exported-symbols)))
(loop :for sym :in export :do
- (unless (member sym bothly-exported-symbols :test 'string-equal)
+ (unless (member sym bothly-exported-symbols :test 'equal)
(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
- :for old = (find-sym new user)
+ :for old = (find-symbol* new user)
: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 fmakunbound shadow export)
+ (ensure-package (name &key nicknames use unintern
+ shadow export redefined-functions)
(let* ((p (ensure-exists name nicknames use)))
- (ensure-unintern p unintern)
+ (ensure-unintern p (append unintern #+cmu redefined-functions))
(ensure-shadow p shadow)
(ensure-export p export)
- (ensure-fmakunbound p fmakunbound)
+ #-cmu (ensure-fmakunbound p redefined-functions)
p)))
(macrolet
((pkgdcl (name &key nicknames use export
- redefined-functions unintern fmakunbound shadow)
+ redefined-functions unintern shadow)
`(ensure-package
',name :nicknames ',nicknames :use ',use :export ',export
:shadow ',shadow
- :unintern ',(append #-(or gcl ecl) redefined-functions unintern)
- :fmakunbound ',(append fmakunbound))))
+ :unintern ',unintern
+ :redefined-functions ',redefined-functions)))
(pkgdcl
:asdf
- :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
:use (:common-lisp)
:redefined-functions
(#:perform #:explain #:output-files #:operation-done-p
#:perform-with-restarts #:component-relative-pathname
#: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
#:compile-file* #:source-file-type)
:unintern
(#:*asdf-revision* #:around #:asdf-method-combination
- #:split #:make-collector
+ #:split #:make-collector #:do-dep #:do-one-dep
+ #:resolve-relative-location-component #:resolve-absolute-location-component
#:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function
- :fmakunbound
- (#:system-source-file
- #:component-relative-pathname #:system-relative-pathname
- #:process-source-registry
- #:inherit-source-registry #:process-source-registry-directive)
:export
- (#:defsystem #:oos #:operate #:find-system #:run-shell-command
- #:system-definition-pathname
- #:search-for-system-definition #:find-component ; miscellaneous
- #:compile-system #:load-system #:test-system #:clear-system
- #:compile-op #:load-op #:load-source-op
- #:test-op
- #:operation ; operations
- #:feature ; sort-of operation
- #:version ; metaphorically sort-of an operation
- #:version-satisfies
+ (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
+ #:system-definition-pathname #:with-system-definitions
+ #:search-for-system-definition #:find-component #:component-find-path
+ #: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
#:upgrade-asdf
- #:implementation-identifier #:implementation-type
-
- #:input-files #:output-files #:output-file #:perform ; operation methods
+ #:implementation-identifier #:implementation-type #:hostname
+ #:input-files #:output-files #:output-file #:perform
#:operation-done-p #:explain
#:component #:source-file
#:unix-dso
#:module-components ; component accessors
- #:module-components-by-name ; component accessors
+ #:module-components-by-name
#:component-pathname
#:component-relative-pathname
#:component-name
#:component-parent
#:component-property
#:component-system
-
#:component-depends-on
+ #:component-encoding
+ #:component-external-format
#:system-description
#:system-long-description
#:operation-on-warnings
#:operation-on-failure
#:component-visited-p
- ;;#:*component-parent-pathname*
- #:*system-definition-search-functions*
- #:*central-registry* ; variables
+
+ #:*system-definition-search-functions* ; variables
+ #:*central-registry*
#:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
#:*resolve-symlinks*
+ #:*load-system-operation*
#:*asdf-verbose*
+ #:*verbose-out*
#:asdf-version
#:coerce-entry-to-directory
#:remove-entry-from-registry
+ #:*encoding-detection-hook*
+ #:*encoding-external-format-hook*
+ #:*default-encoding*
+ #:*utf-8-external-format*
+
#:clear-configuration
#:*output-translations-parameter*
#:initialize-output-translations
#:clear-source-registry
#:ensure-source-registry
#:process-source-registry
- #:system-registered-p
+ #:system-registered-p #:registered-systems #:loaded-systems
+ #:resolve-location
#:asdf-message
-
- ;; Utilities
- #:absolute-pathname-p
+ #: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
+ #|
;; #:aif #:it
- ;; #:appendf
+ ;; #:appendf #:orf
+ #:length=n-p
+ #:remove-keys #:remove-keyword
+ #:first-char #:last-char #:string-suffix-p
#:coerce-name
- #:directory-pathname-p
- ;; #:ends-with
- #:ensure-directory-pathname
- #:getenv
- ;; #:get-uid
- ;; #:length=n-p
- ;; #:find-symbol*
- #:merge-pathnames*
- #:coerce-pathname
- #:pathname-directory-pathname
+ #:directory-pathname-p #:ensure-directory-pathname
+ #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root
+ #:getenv #:getenv-pathname #:getenv-pathnames
+ #:getenv-absolute-directory #:getenv-absolute-directories
+ #: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
#:read-file-forms
- ;; #:remove-keys
- ;; #:remove-keyword
- #:resolve-symlinks
+ #:resolve-symlinks #:truenamize
#:split-string
#:component-name-to-pathname-components
#:split-name-type
- #:subdirectories
- #:truenamize
- #:while-collecting)))
+ #:subdirectories #:directory-files
+ #:while-collecting
+ #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
+ #:*wild-path* #:wilden
+ #:directorize-pathname-host-device|#
+ )))
#+genera (import 'scl:boolean :asdf)
(setf *asdf-version* asdf-version
*upgraded-p* (if existing-version
;;;; -------------------------------------------------------------------------
;;;; User-visible parameters
;;;;
-(defun asdf-version ()
- "Exported interface to the version of ASDF currently installed. A string.
-You can compare this string with e.g.:
-(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
- *asdf-version*)
-
(defvar *resolve-symlinks* t
"Determine whether or not ASDF resolves symlinks when defining systems.
(defparameter +asdf-methods+
'(perform-with-restarts perform explain output-files operation-done-p))
+(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*
condition-arguments condition-form
condition-format condition-location
coerce-name)
- #-cormanlisp
+ (ftype (function (&optional t) (values)) initialize-source-registry)
+ #-(or cormanlisp gcl-pre2.7)
(ftype (function (t t) t) (setf module-components-by-name)))
;;;; -------------------------------------------------------------------------
-;;;; Compatibility with Corman Lisp
+;;;; Compatibility various implementations
#+cormanlisp
(progn
(deftype logical-pathname () nil)
(defun make-broadcast-stream () *error-output*)
+ (defun translate-logical-pathname (x) x)
(defun file-namestring (p)
(setf p (pathname p))
- (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))
- (defparameter *count* 3)
- (defun dbg (&rest x)
- (format *error-output* "~S~%" x)))
-#+cormanlisp
-(defun maybe-break ()
- (decf *count*)
- (unless (plusp *count*)
- (setf *count* 3)
- (break)))
+ (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))))))"))
;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities
((defdef (def* def)
`(defmacro ,def* (name formals &rest rest)
`(progn
- #+(or ecl gcl) (fmakunbound ',name)
+ #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',name)
#-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)))
(values ,@(mapcar #'(lambda (v) `(reverse ,v)) vars))))))
(defmacro aif (test then &optional else)
+ "Anaphoric version of IF, On Lisp style"
`(let ((it ,test)) (if it ,then ,else)))
(defun* pathname-directory-pathname (pathname)
(make-pathname :name nil :type nil :version nil :defaults pathname)))
(defun* normalize-pathname-directory-component (directory)
+ "Given a pathname directory component, return an equivalent form that is a list"
(cond
- #-(or cmu sbcl scl)
+ #-(or cmu sbcl scl) ;; these implementations already normalize directory components.
((stringp directory) `(:absolute ,directory) directory)
#+gcl
((and (consp directory) (stringp (first directory)))
(error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
(defun* merge-pathname-directory-components (specified defaults)
+ ;; Helper for merge-pathnames* that handles directory components.
(let ((directory (normalize-pathname-directory-component specified)))
(ecase (first directory)
((nil) defaults)
:do (pop reldir) (pop defrev)
:finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
+(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))))
+
(defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*))
- "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname
-does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS.
+ "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))
(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 ((ununspecific (x)
- (if (eq x :unspecific) nil x))
- (unspecific-handler (p)
- (if (typep p 'logical-pathname) #'ununspecific #'identity)))
+ (labels ((unspecific-handler (p)
+ (if (typep p 'logical-pathname) #'make-pathname-component-logical #'identity)))
(multiple-value-bind (host device directory unspecific-handler)
(ecase (first directory)
((:absolute)
and NIL NAME, TYPE and VERSION components"
(when pathname
(make-pathname :name nil :type nil :version nil
- :directory (merge-pathname-directory-components '(:relative :back) (pathname-directory pathname))
+ :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.
(let ((unspecific
;; Giving :unspecific as argument to make-pathname is not portable.
;; See CLHS make-pathname and 19.2.2.2.3.
- ;; We only use it on implementations that support it.
- (or #+(or clozure gcl lispworks sbcl) :unspecific)))
+ ;; We only use it on implementations that support it,
+ #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
+ #+(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 "")
:unless (eq k key)
:append (list k v)))
-#+mcl
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string))
-
(defun* getenv (x)
(declare (ignorable x))
- #+(or abcl clisp xcl) (ext:getenv 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=))
(ct:c-string-to-lisp-string buffer1))
(ct:free buffer)
(ct:free buffer1)))
- #+ecl (si:getenv x)
#+gcl (system:getenv x)
#+genera nil
#+lispworks (lispworks:environment-variable x)
(let ((value (_getenv name)))
(unless (ccl:%null-ptr-p value)
(ccl:%get-cstring value))))
+ #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x)
#+sbcl (sb-ext:posix-getenv x)
- #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
+ #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "~S is not supported on your implementation" 'getenv))
(defun* directory-pathname-p (pathname)
#+genera
(unless (fboundp 'ensure-directories-exist)
- (defun ensure-directories-exist (path)
+ (defun* ensure-directories-exist (path)
(fs:create-directories-recursively (pathname path))))
(defun* absolute-pathname-p (pathspec)
(and (typep pathspec '(or pathname string))
(eq :absolute (car (pathname-directory (pathname pathspec))))))
+(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)))
+
(defun* length=n-p (x n) ;is it that (= (length x) n) ?
(check-type n (integer 0 *))
(loop
((zerop i) (return (null l)))
((not (consp l)) (return nil)))))
-(defun* ends-with (s suffix)
+(defun* string-suffix-p (s suffix)
(check-type s string)
(check-type suffix string)
(let ((start (- (length s) (length suffix))))
:until (eq form eof)
:collect form)))
-#+asdf-unix
-(progn
- #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601)
- '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>"))
- (defun* get-uid ()
- #+allegro (excl.osi:getuid)
- #+ccl (ccl::getuid)
- #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid")
- :for f = (ignore-errors (read-from-string s))
- :when f :return (funcall f))
- #+(or cmu scl) (unix:unix-getuid)
- #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601)
- '(ffi:c-inline () () :int "getuid()" :one-liner t)
- '(ext::getuid))
- #+sbcl (sb-unix:unix-getuid)
- #-(or allegro ccl clisp cmu ecl sbcl scl)
- (let ((uid-string
- (with-output-to-string (*verbose-out*)
- (run-shell-command "id -ur"))))
- (with-input-from-string (stream uid-string)
- (read-line stream)
- (handler-case (parse-integer (read-line stream))
- (error () (error "Unable to find out user ID")))))))
-
(defun* pathname-root (pathname)
(make-pathname :directory '(:absolute)
:name nil :type nil :version nil
- :defaults pathname ;; host device, and on scl scheme scheme-specific-part port username password
+ :defaults pathname ;; host device, and on scl, *some*
+ ;; scheme-specific parts: port username password, not others:
. #.(or #+scl '(:parameters nil :query nil :fragment nil))))
-(defun* find-symbol* (s p)
- (find-symbol (string s) p))
-
(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."
(null nil)
(string (probe-file* (parse-namestring p)))
(pathname (unless (wild-pathname-p p)
- #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p)
- #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p)))
+ #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl)
+ '(probe-file p)
+ #+clisp (aif (find-symbol* '#:probe-pathname :ext)
+ `(ignore-errors (,it p)))
'(ignore-errors (truename p)))))))
-(defun* truenamize (p)
+(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*))
"Resolve as much of a pathname as possible"
(block nil
- (when (typep p '(or null logical-pathname)) (return p))
- (let* ((p (merge-pathnames* p))
- (directory (pathname-directory p)))
+ (when (typep pathname '(or null logical-pathname)) (return pathname))
+ (let ((p (merge-pathnames* pathname defaults)))
(when (typep p 'logical-pathname) (return p))
(let ((found (probe-file* p)))
(when found (return found)))
- #-(or cmu sbcl scl) (when (stringp directory) (return p))
- (when (not (eq :absolute (car directory))) (return p))
+ (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))
(let ((sofar (probe-file* (pathname-root p))))
(unless sofar (return p))
(flet ((solution (directories)
:type (pathname-type p)
:version (pathname-version p))
sofar)))
- (loop :for component :in (cdr directory)
+ (loop :with directory = (normalize-pathname-directory-component
+ (pathname-directory p))
+ :for component :in (cdr directory)
:for rest :on (cdr directory)
:for more = (probe-file*
(merge-pathnames*
(and path (resolve-symlinks path))
path))
-(defun ensure-pathname-absolute (path)
+(defun* ensure-pathname-absolute (path)
(cond
((absolute-pathname-p path) path)
((stringp path) (ensure-pathname-absolute (pathname path)))
(defparameter *wild* #-cormanlisp :wild #+cormanlisp "*")
(defparameter *wild-file*
- (make-pathname :name *wild* :type *wild* :version *wild* :directory nil))
+ (make-pathname :name *wild* :type *wild*
+ :version (or #-(or abcl xcl) *wild*) :directory nil))
(defparameter *wild-directory*
(make-pathname :directory `(:relative ,*wild*) :name nil :type nil :version nil))
(defparameter *wild-inferiors*
(merge-pathnames* *wild-path* path))
#-scl
-(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
+(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*))
(let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname)))
(last-char (namestring foo))))
(host (pathname-host pathname))
(port (ext:pathname-port pathname))
(directory (pathname-directory pathname)))
- (flet ((not-unspecific (component)
- (and (not (eq component :unspecific)) component)))
- (cond ((or (not-unspecific port)
- (and (not-unspecific host) (plusp (length host)))
- (not-unspecific scheme))
- (let ((prefix ""))
- (when (not-unspecific port)
- (setf prefix (format nil ":~D" port)))
- (when (and (not-unspecific host) (plusp (length host)))
- (setf prefix (concatenate 'string host prefix)))
- (setf prefix (concatenate 'string ":" prefix))
- (when (not-unspecific scheme)
- (setf prefix (concatenate 'string scheme prefix)))
- (assert (and directory (eq (first directory) :absolute)))
- (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
- :defaults pathname)))
- (t
- pathname)))))
+ (flet ((specificp (x) (and x (not (eq x :unspecific)))))
+ (if (or (specificp port)
+ (and (specificp host) (plusp (length host)))
+ (specificp scheme))
+ (let ((prefix ""))
+ (when (specificp port)
+ (setf prefix (format nil ":~D" port)))
+ (when (and (specificp host) (plusp (length host)))
+ (setf prefix (strcat host prefix)))
+ (setf prefix (strcat ":" prefix))
+ (when (specificp scheme)
+ (setf prefix (strcat scheme prefix)))
+ (assert (and directory (eq (first directory) :absolute)))
+ (make-pathname :directory `(:absolute ,prefix ,@(rest directory))
+ :defaults pathname)))
+ pathname)))
;;;; -------------------------------------------------------------------------
;;;; ASDF Interface, in terms of generic functions.
(defgeneric* perform-with-restarts (operation component))
(defgeneric* perform (operation component))
(defgeneric* operation-done-p (operation component))
+(defgeneric* mark-operation-done (operation component))
(defgeneric* explain (operation component))
(defgeneric* output-files (operation component))
(defgeneric* input-files (operation component))
(defgeneric* (setf component-property) (new-value component property))
-(eval-when (:compile-toplevel :load-toplevel :execute)
+(defgeneric* component-external-format (component))
+
+(defgeneric* component-encoding (component))
+
+(eval-when (#-gcl :compile-toplevel :load-toplevel :execute)
(defgeneric* (setf module-components-by-name) (new-value module)))
(defgeneric* version-satisfies (component version))
;;;; -------------------------------------------------------------------------
;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687
(when *upgraded-p*
- (when (find-class 'module nil)
- (eval
- '(defmethod update-instance-for-redefined-class :after
- ((m module) added deleted plist &key)
- (declare (ignorable deleted plist))
- (when *asdf-verbose*
- (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
- m (asdf-version)))
- (when (member 'components-by-name added)
- (compute-module-components-by-name m))
- (when (typep m 'system)
- (when (member 'source-file added)
- (%set-system-source-file
- (probe-asd (component-name m) (component-pathname m)) m)
- (when (equal (component-name m) "asdf")
- (setf (component-version m) *asdf-version*))))))))
+ (when (find-class 'module nil)
+ (eval
+ '(defmethod update-instance-for-redefined-class :after
+ ((m module) added deleted plist &key)
+ (declare (ignorable deleted plist))
+ (when *asdf-verbose*
+ (asdf-message (compatfmt "~&~@<; ~@;Updating ~A for ASDF ~A~@:>~%")
+ m (asdf-version)))
+ (when (member 'components-by-name added)
+ (compute-module-components-by-name m))
+ (when (typep m 'system)
+ (when (member 'source-file added)
+ (%set-system-source-file
+ (probe-asd (component-name m) (component-pathname m)) m)
+ (when (equal (component-name m) "asdf")
+ (setf (component-version m) *asdf-version*))))))))
;;;; -------------------------------------------------------------------------
;;;; Classes, Conditions
(defclass component ()
((name :accessor component-name :initarg :name :type string :documentation
"Component name: designator for a string composed of portable pathname characters")
- (version :accessor component-version :initarg :version) ;; :type (and string (satisfies parse-version)) -- not until we fix all systems that don't use it correctly!
+ ;; We might want to constrain version with
+ ;; :type (and string (satisfies parse-version))
+ ;; but we cannot until we fix all systems that don't use it correctly!
+ (version :accessor component-version :initarg :version)
(description :accessor component-description :initarg :description)
(long-description :accessor component-long-description :initarg :long-description)
;; This one below is used by POIU - http://www.cliki.net/poiu
;; it needn't be recompiled just because one of these dependencies
;; hasn't yet been loaded in the current image (do-first).
;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52!
+ ;; LispWorks's defsystem has caused-by and requires for in-order-to and do-first respectively.
+ ;; Maybe rename the slots in ASDF? But that's not very backwards compatible.
;; See our ASDF 2 paper for more complete explanations.
(in-order-to :initform nil :initarg :in-order-to
:accessor component-in-order-to)
;; no direct accessor for pathname, we do this as a method to allow
;; it to default in funky ways if not supplied
(relative-pathname :initarg :pathname)
+ ;; the absolute-pathname is computed based on relative-pathname...
(absolute-pathname)
(operation-times :initform (make-hash-table)
:accessor component-operation-times)
+ (around-compile :initarg :around-compile)
+ (%encoding :accessor %component-encoding :initform nil :initarg :encoding)
;; XXX we should provide some atomic interface for updating the
;; component properties
(properties :accessor component-properties :initarg :properties
:initarg :if-component-dep-fails
:accessor module-if-component-dep-fails)
(default-component-class
- :initform *default-component-class*
+ :initform nil
:initarg :default-component-class
:accessor module-default-component-class)))
(slot-value component 'absolute-pathname)
(let ((pathname
(merge-pathnames*
- (component-relative-pathname component)
- (pathname-directory-pathname (component-parent-pathname component)))))
+ (component-relative-pathname component)
+ (pathname-directory-pathname (component-parent-pathname component)))))
(unless (or (null pathname) (absolute-pathname-p pathname))
(error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>")
pathname (component-find-path component)))
(acons property new-value (slot-value c 'properties)))))
new-value)
-(defclass system (module)
+(defvar *default-encoding* :default
+ "Default encoding for source files.
+The default value :default preserves the legacy behavior.
+A future default might be :utf-8 or :autodetect
+reading emacs-style -*- coding: utf-8 -*- specifications,
+and falling back to utf-8 or latin1 if nothing is specified.")
+
+(defparameter *utf-8-external-format*
+ #+(and asdf-unicode (not clisp)) :utf-8
+ #+(and asdf-unicode clisp) charset:utf-8
+ #-asdf-unicode :default
+ "Default :external-format argument to pass to CL:OPEN and also
+CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file.
+On modern implementations, this will decode UTF-8 code points as CL characters.
+On legacy implementations, it may fall back on some 8-bit encoding,
+with non-ASCII code points being read as several CL characters;
+hopefully, if done consistently, that won't affect program behavior too much.")
+
+(defun* always-default-encoding (pathname)
+ (declare (ignore pathname))
+ *default-encoding*)
+
+(defvar *encoding-detection-hook* #'always-default-encoding
+ "Hook for an extension to define a function to automatically detect a file's encoding")
+
+(defun* detect-encoding (pathname)
+ (funcall *encoding-detection-hook* pathname))
+
+(defmethod component-encoding ((c component))
+ (or (loop :for x = c :then (component-parent x)
+ :while x :thereis (%component-encoding x))
+ (detect-encoding (component-pathname c))))
+
+(defun* default-encoding-external-format (encoding)
+ (case encoding
+ (:default :default) ;; for backwards compatibility only. Explicit usage discouraged.
+ (:utf-8 *utf-8-external-format*)
+ (otherwise
+ (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)
+ :default)))
+
+(defvar *encoding-external-format-hook*
+ #'default-encoding-external-format
+ "Hook for an extension to define a mapping between non-default encodings
+and implementation-defined external-format's")
+
+(defun encoding-external-format (encoding)
+ (funcall *encoding-external-format-hook* encoding))
+
+(defmethod component-external-format ((c component))
+ (encoding-external-format (component-encoding c)))
+
+(defclass proto-system () ; slots to keep when resetting a system
+ ;; To preserve identity for all objects, we'd need keep the components slots
+ ;; but also to modify parse-component-form to reset the recycled objects.
+ ((name) #|(components) (components-by-names)|#))
+
+(defclass system (module proto-system)
(;; description and long-description are now available for all component's,
;; but now also inherited from component, but we add the legacy accessor
(description :accessor system-description :initarg :description)
(maintainer :accessor system-maintainer :initarg :maintainer)
(licence :accessor system-licence :initarg :licence
:accessor system-license :initarg :license)
- (source-file :reader system-source-file :initarg :source-file
+ (source-file :reader %system-source-file :initarg :source-file ; for CLISP upgrade
:writer %set-system-source-file)
(defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on)))
(return-from version-satisfies t))
(version-satisfies (component-version c) version))
-(defun parse-version (string &optional on-error)
+(defun* asdf-version ()
+ "Exported interface to the version of ASDF currently installed. A string.
+You can compare this string with e.g.:
+(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")."
+ *asdf-version*)
+
+(defun* parse-version (string &optional on-error)
"Parse a version string as a series of natural integers separated by dots.
Return a (non-null) list of integers if the string is valid, NIL otherwise.
If on-error is error, warn, or designates a function of compatible signature,
(and x y (= (car x) (car y))
(or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
+;;;; -----------------------------------------------------------------
+;;;; Windows shortcut support. Based on:
+;;;;
+;;;; Jesse Hager: The Windows Shortcut File Format.
+;;;; http://www.wotsit.org/list.asp?fc=13
+
+#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
+(progn
+(defparameter *link-initial-dword* 76)
+(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
+
+(defun* read-null-terminated-string (s)
+ (with-output-to-string (out)
+ (loop :for code = (read-byte s)
+ :until (zerop code)
+ :do (write-char (code-char code) out))))
+
+(defun* read-little-endian (s &optional (bytes 4))
+ (loop :for i :from 0 :below bytes
+ :sum (ash (read-byte s) (* 8 i))))
+
+(defun* parse-file-location-info (s)
+ (let ((start (file-position s))
+ (total-length (read-little-endian s))
+ (end-of-header (read-little-endian s))
+ (fli-flags (read-little-endian s))
+ (local-volume-offset (read-little-endian s))
+ (local-offset (read-little-endian s))
+ (network-volume-offset (read-little-endian s))
+ (remaining-offset (read-little-endian s)))
+ (declare (ignore total-length end-of-header local-volume-offset))
+ (unless (zerop fli-flags)
+ (cond
+ ((logbitp 0 fli-flags)
+ (file-position s (+ start local-offset)))
+ ((logbitp 1 fli-flags)
+ (file-position s (+ start
+ network-volume-offset
+ #x14))))
+ (strcat (read-null-terminated-string s)
+ (progn
+ (file-position s (+ start remaining-offset))
+ (read-null-terminated-string s))))))
+
+(defun* parse-windows-shortcut (pathname)
+ (with-open-file (s pathname :element-type '(unsigned-byte 8))
+ (handler-case
+ (when (and (= (read-little-endian s) *link-initial-dword*)
+ (let ((header (make-array (length *link-guid*))))
+ (read-sequence header s)
+ (equalp header *link-guid*)))
+ (let ((flags (read-little-endian s)))
+ (file-position s 76) ;skip rest of header
+ (when (logbitp 0 flags)
+ ;; skip shell item id list
+ (let ((length (read-little-endian s 2)))
+ (file-position s (+ length (file-position s)))))
+ (cond
+ ((logbitp 1 flags)
+ (parse-file-location-info s))
+ (t
+ (when (logbitp 2 flags)
+ ;; skip description string
+ (let ((length (read-little-endian s 2)))
+ (file-position s (+ length (file-position s)))))
+ (when (logbitp 3 flags)
+ ;; finally, our pathname
+ (let* ((length (read-little-endian s 2))
+ (buffer (make-array length)))
+ (read-sequence buffer s)
+ (map 'string #'code-char buffer)))))))
+ (end-of-file ()
+ nil)))))
+
;;;; -------------------------------------------------------------------------
;;;; Finding systems
(defun* system-registered-p (name)
(gethash (coerce-name name) *defined-systems*))
+(defun* registered-systems ()
+ (loop :for (() . system) :being :the :hash-values :of *defined-systems*
+ :collect (coerce-name system)))
+
(defun* register-system (system)
(check-type system system)
(let ((name (component-name system)))
;;; for the sake of keeping things reasonably neat, we adopt a
;;; convention that functions in this list are prefixed SYSDEF-
-(defparameter *system-definition-search-functions*
- '(sysdef-central-registry-search
- sysdef-source-registry-search
- sysdef-find-asdf))
+(defvar *system-definition-search-functions* '())
+
+(setf *system-definition-search-functions*
+ (append
+ ;; Remove known-incompatible sysdef functions from ancient sbcl asdf.
+ (remove 'contrib-sysdef-search *system-definition-search-functions*)
+ ;; Tuck our defaults at the end of the list if they were absent.
+ ;; This is imperfect, in case they were removed on purpose,
+ ;; but then it will be the responsibility of whoever does that
+ ;; to upgrade asdf before he does such a thing rather than after.
+ (remove-if #'(lambda (x) (member x *system-definition-search-functions*))
+ '(sysdef-central-registry-search
+ sysdef-source-registry-search
+ sysdef-find-asdf))))
(defun* search-for-system-definition (system)
- (let ((system-name (coerce-name system)))
- (some #'(lambda (x) (funcall x system-name))
- *system-definition-search-functions*)))
+ (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name)))
+ (cons 'find-system-if-being-defined
+ *system-definition-search-functions*)))
(defvar *central-registry* nil
"A list of 'system directory designators' ASDF uses to find systems.
Going forward, we recommend new users should be using the source-registry.
")
+(defun* featurep (x &optional (features *features*))
+ (cond
+ ((atom x)
+ (and (member x features) t))
+ ((eq :not (car x))
+ (assert (null (cddr x)))
+ (not (featurep (cadr x) features)))
+ ((eq :or (car x))
+ (some #'(lambda (x) (featurep x features)) (cdr x)))
+ ((eq :and (car x))
+ (every #'(lambda (x) (featurep x features)) (cdr x)))
+ (t
+ (error "Malformed feature specification ~S" x))))
+
+(defun* os-unix-p ()
+ (featurep '(:or :unix :cygwin :darwin)))
+
+(defun* os-windows-p ()
+ (and (not (os-unix-p)) (featurep '(:or :win32 :windows :mswindows :mingw32))))
+
(defun* probe-asd (name defaults)
(block nil
(when (directory-pathname-p defaults)
- (let ((file
- (make-pathname
- :defaults defaults :version :newest :case :local
- :name name
- :type "asd")))
- (when (probe-file* file)
+ (let* ((file (probe-file* (subpathname defaults (strcat name ".asd")))))
+ (when file
(return file)))
- #+(and asdf-windows (not clisp))
- (let ((shortcut
- (make-pathname
- :defaults defaults :version :newest :case :local
- :name (concatenate 'string name ".asd")
- :type "lnk")))
- (when (probe-file* shortcut)
- (let ((target (parse-windows-shortcut shortcut)))
- (when target
- (return (pathname target)))))))))
+ #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!)
+ (when (os-windows-p)
+ (let ((shortcut
+ (make-pathname
+ :defaults defaults :version :newest :case :local
+ :name (strcat name ".asd")
+ :type "lnk")))
+ (when (probe-file* shortcut)
+ (let ((target (parse-windows-shortcut shortcut)))
+ (when target
+ (return (pathname target))))))))))
(defun* sysdef-central-registry-search (system)
(let ((name (coerce-name system))
0)))
(defmethod find-system ((name null) &optional (error-p t))
+ (declare (ignorable name))
(when error-p
(sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>"))))
(defmethod find-system (name &optional (error-p t))
(find-system (coerce-name name) error-p))
-(defun load-sysdef (name pathname)
- ;; Tries to load system definition with canonical NAME from PATHNAME.
- (let ((package (make-temporary-package)))
- (unwind-protect
- (handler-bind
- ((error #'(lambda (condition)
- (error 'load-system-definition-error
- :name name :pathname pathname
- :condition condition))))
- (let ((*package* package))
- (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
- pathname package)
- (load pathname)))
- (delete-package package))))
+(defvar *systems-being-defined* nil
+ "A hash-table of systems currently being defined keyed by name, or NIL")
-(defmethod find-system ((name string) &optional (error-p t))
- (let* ((in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
+(defun* find-system-if-being-defined (name)
+ (when *systems-being-defined*
+ (gethash (coerce-name name) *systems-being-defined*)))
+
+(defun* call-with-system-definitions (thunk)
+ (if *systems-being-defined*
+ (funcall thunk)
+ (let ((*systems-being-defined* (make-hash-table :test 'equal)))
+ (funcall thunk))))
+
+(defmacro with-system-definitions ((&optional) &body body)
+ `(call-with-system-definitions #'(lambda () ,@body)))
+
+(defun* load-sysdef (name pathname)
+ ;; Tries to load system definition with canonical NAME from PATHNAME.
+ (with-system-definitions ()
+ (let ((package (make-temporary-package)))
+ (unwind-protect
+ (handler-bind
+ ((error #'(lambda (condition)
+ (error 'load-system-definition-error
+ :name name :pathname pathname
+ :condition condition))))
+ (let ((*package* package)
+ (*default-pathname-defaults*
+ ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
+ (pathname-directory-pathname (translate-logical-pathname pathname)))
+ (external-format (encoding-external-format (detect-encoding pathname))))
+ (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
+ pathname package)
+ (load pathname :external-format external-format)))
+ (delete-package package)))))
+
+(defun* locate-system (name)
+ "Given a system NAME designator, try to locate where to load the system from.
+Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
+FOUNDP is true when a system was found,
+either a new unregistered one or a previously registered one.
+FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is
+PATHNAME when not null is a path from where to load the system,
+either associated with FOUND-SYSTEM, or with the PREVIOUS system.
+PREVIOUS when not null is a previously loaded SYSTEM object of same name.
+PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded."
+ (let* ((name (coerce-name name))
+ (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk
(previous (cdr in-memory))
(previous (and (typep previous 'system) previous))
(previous-time (car in-memory))
(found-system (and (typep found 'system) found))
(pathname (or (and (typep found '(or pathname string)) (pathname found))
(and found-system (system-source-file found-system))
- (and previous (system-source-file previous)))))
- (setf pathname (resolve-symlinks* pathname))
- (when (and pathname (not (absolute-pathname-p pathname)))
- (setf pathname (ensure-pathname-absolute pathname))
- (when found-system
- (%set-system-source-file pathname found-system)))
- (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
- (system-source-file previous) pathname)))
- (%set-system-source-file pathname previous)
- (setf previous-time nil))
- (when (and found-system (not previous))
- (register-system found-system))
- (when (and pathname
- (or (not previous-time)
- ;; don't reload if it's already been loaded,
- ;; or its filestamp is in the future which means some clock is skewed
- ;; and trying to load might cause an infinite loop.
- (< previous-time (safe-file-write-date pathname) (get-universal-time))))
- (load-sysdef name pathname))
- (let ((in-memory (system-registered-p name))) ; try again after loading from disk
- (cond
- (in-memory
- (when pathname
- (setf (car in-memory) (safe-file-write-date pathname)))
- (cdr in-memory))
- (error-p
- (error 'missing-component :requires name))))))
+ (and previous (system-source-file previous))))
+ (foundp (and (or found-system pathname previous) t)))
+ (check-type found (or null pathname system))
+ (when foundp
+ (setf pathname (resolve-symlinks* pathname))
+ (when (and pathname (not (absolute-pathname-p pathname)))
+ (setf pathname (ensure-pathname-absolute pathname))
+ (when found-system
+ (%set-system-source-file pathname found-system)))
+ (when (and previous (not (#-cormanlisp equal #+cormanlisp equalp
+ (system-source-file previous) pathname)))
+ (%set-system-source-file pathname previous)
+ (setf previous-time nil))
+ (values foundp found-system pathname previous previous-time))))
+
+(defmethod find-system ((name string) &optional (error-p t))
+ (with-system-definitions ()
+ (loop
+ (restart-case
+ (multiple-value-bind (foundp found-system pathname previous previous-time)
+ (locate-system name)
+ (declare (ignore foundp))
+ (when (and found-system (not previous))
+ (register-system found-system))
+ (when (and pathname
+ (or (not previous-time)
+ ;; don't reload if it's already been loaded,
+ ;; or its filestamp is in the future which means some clock is skewed
+ ;; and trying to load might cause an infinite loop.
+ (< previous-time (safe-file-write-date pathname) (get-universal-time))))
+ (load-sysdef name pathname))
+ (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
+ (return
+ (cond
+ (in-memory
+ (when pathname
+ (setf (car in-memory) (safe-file-write-date pathname)))
+ (cdr in-memory))
+ (error-p
+ (error 'missing-component :requires name))))))
+ (reinitialize-source-registry-and-retry ()
+ :report (lambda (s)
+ (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
+ (initialize-source-registry))))))
(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys)
(setf fallback (coerce-name fallback)
(declare (ignorable s))
(source-file-explicit-type component))
-(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
- ;; XCL 0.0.0.291 and ABCL 0.25 have a bug, whereby make-pathname merges directories like merge-pathnames when a :defaults is provided. Fixed in the latest XCL.
- (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))
-
(defmethod component-relative-pathname ((component component))
(coerce-pathname
(or (slot-value component 'relative-pathname)
;; to force systems named in a given list
;; However, but this feature has only ever worked but starting with ASDF 2.014.5
(forced :initform nil :initarg :force :accessor operation-forced)
+ (forced-not :initform nil :initarg :force-not :accessor operation-forced-not)
(original-initargs :initform nil :initarg :original-initargs
:accessor operation-original-initargs)
(visited-nodes :initform (make-hash-table :test 'equal) :accessor operation-visited-nodes)
(prin1 (operation-original-initargs o) stream))))
(defmethod shared-initialize :after ((operation operation) slot-names
- &key force
+ &key force force-not
&allow-other-keys)
- (declare (ignorable operation slot-names force))
- ;; empty method to disable initarg validity checking
+ ;; the &allow-other-keys disables initarg validity checking
+ (declare (ignorable operation slot-names force force-not))
+ (macrolet ((frob (x) ;; normalize forced and forced-not slots
+ `(when (consp (,x operation))
+ (setf (,x operation)
+ (mapcar #'coerce-name (,x operation))))))
+ (frob operation-forced) (frob operation-forced-not))
(values))
(defun* node-for (o c)
(cdr (assoc (type-of o) (component-in-order-to c))))
(defmethod component-self-dependencies ((o operation) (c component))
- (let ((all-deps (component-depends-on o c)))
- (remove-if-not #'(lambda (x)
- (member (component-name c) (cdr x) :test #'string=))
- all-deps)))
+ (remove-if-not
+ #'(lambda (x) (member (component-name c) (cdr x) :test #'string=))
+ (component-depends-on o c)))
(defmethod input-files ((operation operation) (c component))
(let ((parent (component-parent c))
;; e.g. LOAD-OP or LOAD-SOURCE-OP of some CL-SOURCE-FILE.
(and op-time (>= op-time (latest-in))))
((not in-files)
- ;; an operation without output-files and no input-files
+ ;; an operation with output-files and no input-files
;; is probably meant for its side-effects on the file-system,
;; assumed to have to be done everytime.
;; (I don't think there is any such case in ASDF unless extended)
(defgeneric* do-traverse (operation component collect))
-(defun* %do-one-dep (operation c collect required-op required-c required-v)
- ;; collects a partial plan that results from performing required-op
- ;; on required-c, possibly with a required-vERSION
- (let* ((dep-c (or (let ((d (find-component (component-parent c) required-c)))
- (and d (version-satisfies d required-v) d))
- (if required-v
- (error 'missing-dependency-of-version
- :required-by c
- :version required-v
- :requires required-c)
- (error 'missing-dependency
- :required-by c
- :requires required-c))))
- (op (make-sub-operation c operation dep-c required-op)))
- (do-traverse op dep-c collect)))
-
-(defun* do-one-dep (operation c collect required-op required-c required-v)
- ;; this function is a thin, error-handling wrapper around %do-one-dep.
- ;; Collects a partial plan per that function.
+(defun* resolve-dependency-name (component name &optional version)
(loop
(restart-case
- (return (%do-one-dep operation c collect
- required-op required-c required-v))
+ (return
+ (let ((comp (find-component (component-parent component) name)))
+ (unless comp
+ (error 'missing-dependency
+ :required-by component
+ :requires name))
+ (when version
+ (unless (version-satisfies comp version)
+ (error 'missing-dependency-of-version
+ :required-by component
+ :version version
+ :requires name)))
+ comp))
(retry ()
:report (lambda (s)
- (format s "~@<Retry loading ~3i~_~A.~@:>" required-c))
+ (format s (compatfmt "~@<Retry loading ~3i~_~A.~@:>") name))
:test
(lambda (c)
(or (null c)
(and (typep c 'missing-dependency)
- (equalp (missing-requires c)
- required-c))))))))
-
-(defun* do-dep (operation c collect op dep)
- ;; type of arguments uncertain:
- ;; op seems to at least potentially be a symbol, rather than an operation
- ;; dep is a list of component names
- (cond ((eq op 'feature)
- (if (member (car dep) *features*)
+ (eq (missing-required-by c) component)
+ (equal (missing-requires c) name))))))))
+
+(defun* resolve-dependency-spec (component dep-spec)
+ (cond
+ ((atom dep-spec)
+ (resolve-dependency-name component dep-spec))
+ ;; Structured dependencies --- this parses keywords.
+ ;; The keywords could conceivably be broken out and cleanly (extensibly)
+ ;; processed by EQL methods. But for now, here's what we've got.
+ ((eq :version (first dep-spec))
+ ;; https://bugs.launchpad.net/asdf/+bug/527788
+ (resolve-dependency-name component (second dep-spec) (third dep-spec)))
+ ((eq :feature (first dep-spec))
+ ;; This particular subform is not documented and
+ ;; has always been broken in the past.
+ ;; Therefore no one uses it, and I'm cerroring it out,
+ ;; after fixing it
+ ;; See https://bugs.launchpad.net/asdf/+bug/518467
+ (cerror "Continue nonetheless."
+ "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
+ (when (find (second dep-spec) *features* :test 'string-equal)
+ (resolve-dependency-name component (third dep-spec))))
+ (t
+ (error (compatfmt "~@<Bad dependency ~s. Dependencies must be (:version <name> <version>), (:feature <feature> <name>), or <name>.~@:>") dep-spec))))
+
+(defun* do-one-dep (op c collect dep-op dep-c)
+ ;; Collects a partial plan for performing dep-op on dep-c
+ ;; as dependencies of a larger plan involving op and c.
+ ;; Returns t if this should force recompilation of those who depend on us.
+ ;; dep-op is an operation class name (not an operation object),
+ ;; whereas dep-c is a component object.n
+ (do-traverse (make-sub-operation c op dep-c dep-op) dep-c collect))
+
+(defun* do-dep (op c collect dep-op-spec dep-c-specs)
+ ;; Collects a partial plan for performing dep-op-spec on each of dep-c-specs
+ ;; as dependencies of a larger plan involving op and c.
+ ;; Returns t if this should force recompilation of those who depend on us.
+ ;; dep-op-spec is either an operation class name (not an operation object),
+ ;; or the magic symbol asdf:feature.
+ ;; If dep-op-spec is asdf:feature, then the first dep-c-specs is a keyword,
+ ;; and the plan will succeed if that keyword is present in *feature*,
+ ;; or fail if it isn't
+ ;; (at which point c's :if-component-dep-fails will kick in).
+ ;; If dep-op-spec is an operation class name,
+ ;; then dep-c-specs specifies a list of sibling component of c,
+ ;; as per resolve-dependency-spec, such that operating op on c
+ ;; depends on operating dep-op-spec on each of them.
+ (cond ((eq dep-op-spec 'feature)
+ (if (member (car dep-c-specs) *features*)
nil
(error 'missing-dependency
:required-by c
- :requires (car dep))))
+ :requires (list :feature (car dep-c-specs)))))
(t
(let ((flag nil))
- (flet ((dep (op comp ver)
- (when (do-one-dep operation c collect
- op comp ver)
- (setf flag t))))
- (dolist (d dep)
- (if (atom d)
- (dep op d nil)
- ;; structured dependencies --- this parses keywords
- ;; the keywords could be broken out and cleanly (extensibly)
- ;; processed by EQL methods
- (cond ((eq :version (first d))
- ;; https://bugs.launchpad.net/asdf/+bug/527788
- (dep op (second d) (third d)))
- ;; This particular subform is not documented and
- ;; has always been broken in the past.
- ;; Therefore no one uses it, and I'm cerroring it out,
- ;; after fixing it
- ;; See https://bugs.launchpad.net/asdf/+bug/518467
- ((eq :feature (first d))
- (cerror "Continue nonetheless."
- "Congratulations, you're the first ever user of FEATURE dependencies! Please contact the asdf-devel mailing-list.")
- (when (find (second d) *features* :test 'string-equal)
- (dep op (third d) nil)))
- (t
- (error (compatfmt "~@<Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature> [version]), or a name.~@:>") d))))))
+ (dolist (d dep-c-specs)
+ (when (do-one-dep op c collect dep-op-spec
+ (resolve-dependency-spec c d))
+ (setf flag t)))
flag))))
(defvar *visit-count* 0) ; counter that allows to sort nodes from operation-visited-nodes
(error 'circular-dependency :components (list c)))
(setf (visiting-component operation c) t)
(unwind-protect
- (progn
- (let ((f (operation-forced
- (operation-ancestor operation))))
- (when (and f (or (not (consp f)) ;; T or :ALL
- (and (typep c 'system) ;; list of names of systems to force
- (member (component-name c) f
- :test #'string=))))
- (setf *forcing* t)))
+ (block nil
+ (when (typep c 'system) ;; systems can be forced or forced-not
+ (let ((ancestor (operation-ancestor operation)))
+ (flet ((match? (f)
+ (and f (or (not (consp f)) ;; T or :ALL
+ (member (component-name c) f :test #'equal)))))
+ (cond
+ ((match? (operation-forced ancestor))
+ (setf *forcing* t))
+ ((match? (operation-forced-not ancestor))
+ (return))))))
;; first we check and do all the dependencies for the module.
;; Operations planned in this loop will show up
;; in the results, and are consumed below.
(handler-case
(update-flag
(do-traverse operation kid #'internal-collect))
+ #-genera
(missing-dependency (condition)
(when (eq (module-if-component-dep-fails c)
:fail)
:do (do-dep operation c collect required-op deps)))
(do-collect collect (vector module-ops))
(do-collect collect (cons operation c)))))
- (setf (visiting-component operation c) nil)))
- (visit-component operation c (when flag (incf *visit-count*)))
- flag))
+ (setf (visiting-component operation c) nil)))
+ (visit-component operation c (when flag (incf *visit-count*)))
+ flag))
(defun* flatten-tree (l)
;; You collected things into a list.
(r* l))))
(defmethod traverse ((operation operation) (c component))
- (when (consp (operation-forced operation))
- (setf (operation-forced operation)
- (mapcar #'coerce-name (operation-forced operation))))
(flatten-tree
(while-collecting (collect)
(let ((*visit-count* 0))
(declare (ignorable operation c))
nil)
+(defmethod mark-operation-done ((operation operation) (c component))
+ (setf (gethash (type-of operation) (component-operation-times c))
+ (reduce #'max
+ (cons (get-universal-time)
+ (mapcar #'safe-file-write-date (input-files operation c))))))
+
+(defmethod perform-with-restarts (operation component)
+ ;; TOO verbose, especially as the default. Add your own :before method
+ ;; to perform-with-restart or perform if you want that:
+ #|(when *asdf-verbose* (explain operation component))|#
+ (perform operation component))
+
+(defmethod perform-with-restarts :around (operation component)
+ (loop
+ (restart-case
+ (return (call-next-method))
+ (retry ()
+ :report
+ (lambda (s)
+ (format s (compatfmt "~@<Retry ~A.~@:>")
+ (operation-description operation component))))
+ (accept ()
+ :report
+ (lambda (s)
+ (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
+ (operation-description operation component)))
+ (mark-operation-done operation component)
+ (return)))))
+
(defmethod explain ((operation operation) (component component))
(asdf-message (compatfmt "~&~@<; ~@;~A~:>~%")
(operation-description operation component)))
(flags :initarg :flags :accessor compile-op-flags
:initform nil)))
-(defun output-file (operation component)
+(defun* output-file (operation component)
"The unique output file of performing OPERATION on COMPONENT"
(let ((files (output-files operation component)))
(assert (length=n-p files 1))
(first files)))
+(defun* ensure-all-directories-exist (pathnames)
+ (dolist (pathname pathnames)
+ (ensure-directories-exist (translate-logical-pathname pathname))))
+
(defmethod perform :before ((operation compile-op) (c source-file))
- (loop :for file :in (asdf:output-files operation c)
- :for pathname = (if (typep file 'logical-pathname)
- (translate-logical-pathname file)
- file)
- :do (ensure-directories-exist pathname)))
+ (ensure-all-directories-exist (output-files operation c)))
(defmethod perform :after ((operation operation) (c component))
- (setf (gethash (type-of operation) (component-operation-times c))
- (get-universal-time)))
+ (mark-operation-done operation c))
-(defvar *compile-op-compile-file-function* 'compile-file*
- "Function used to compile lisp files.")
+(defgeneric* around-compile-hook (component))
+(defgeneric* call-with-around-compile-hook (component thunk))
+
+(defmethod around-compile-hook ((c component))
+ (cond
+ ((slot-boundp c 'around-compile)
+ (slot-value c 'around-compile))
+ ((component-parent c)
+ (around-compile-hook (component-parent c)))))
+
+(defun ensure-function (fun &key (package :asdf))
+ (etypecase fun
+ ((or symbol function) fun)
+ (cons (eval `(function ,fun)))
+ (string (eval `(function ,(with-standard-io-syntax
+ (let ((*package* (find-package package)))
+ (read-from-string fun))))))))
+
+(defmethod call-with-around-compile-hook ((c component) thunk)
+ (let ((hook (around-compile-hook c)))
+ (if hook
+ (funcall (ensure-function hook) thunk)
+ (funcall thunk))))
;;; perform is required to check output-files to find out where to put
;;; its answers, in case it has been overridden for site policy
(defmethod perform ((operation compile-op) (c cl-source-file))
- #-:broken-fasl-loader
(let ((source-file (component-pathname c))
;; on some implementations, there are more than one output-file,
;; but the first one should always be the primary fasl that gets loaded.
(*compile-file-warnings-behaviour* (operation-on-warnings operation))
(*compile-file-failure-behaviour* (operation-on-failure operation)))
(multiple-value-bind (output warnings-p failure-p)
- (apply *compile-op-compile-file-function* source-file :output-file output-file
- (compile-op-flags operation))
- (when warnings-p
- (case (operation-on-warnings operation)
- (:warn (warn
- (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
- operation c))
- (:error (error 'compile-warned :component c :operation operation))
- (:ignore nil)))
+ (call-with-around-compile-hook
+ c #'(lambda (&rest flags)
+ (apply *compile-op-compile-file-function* source-file
+ :output-file output-file
+ :external-format (component-external-format c)
+ (append flags (compile-op-flags operation)))))
+ (unless output
+ (error 'compile-error :component c :operation operation))
(when failure-p
(case (operation-on-failure operation)
(:warn (warn
operation c))
(:error (error 'compile-failed :component c :operation operation))
(:ignore nil)))
- (unless output
- (error 'compile-error :component c :operation operation)))))
+ (when warnings-p
+ (case (operation-on-warnings operation)
+ (:warn (warn
+ (compatfmt "~@<COMPILE-FILE warned while performing ~A on ~A.~@:>")
+ operation c))
+ (:error (error 'compile-warned :component c :operation operation))
+ (:ignore nil))))))
(defmethod output-files ((operation compile-op) (c cl-source-file))
(declare (ignorable operation))
- (let ((p (lispize-pathname (component-pathname c))))
- #-broken-fasl-loader (list (compile-file-pathname p))
- #+broken-fasl-loader (list p)))
+ (let* ((p (lispize-pathname (component-pathname c)))
+ (f (compile-file-pathname ;; fasl
+ p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
+ #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file
+ #+ecl (if (use-ecl-byte-compiler-p)
+ (list f)
+ (list (compile-file-pathname p :type :object) f))
+ #+mkcl (list o f)
+ #-(or ecl mkcl) (list f)))
(defmethod perform ((operation compile-op) (c static-file))
(declare (ignorable operation c))
(defclass load-op (basic-load-op) ())
-(defmethod perform ((o load-op) (c cl-source-file))
- (map () #'load (input-files o c)))
-
-(defmethod perform-with-restarts (operation component)
- ;;(when *asdf-verbose* (explain operation component)) ; TOO verbose, especially as the default.
- (perform operation component))
-
(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
- (declare (ignorable o))
- (loop :with state = :initial
- :until (or (eq state :success)
- (eq state :failure)) :do
- (case state
- (:recompiled
- (setf state :failure)
- (call-next-method)
- (setf state :success))
- (:failed-load
- (setf state :recompiled)
- (perform (make-sub-operation c o c 'compile-op) c))
- (t
- (with-simple-restart
- (try-recompiling "Recompile ~a and try loading it again"
- (component-name c))
- (setf state :failed-load)
- (call-next-method)
- (setf state :success))))))
-
-(defmethod perform-with-restarts ((o compile-op) (c cl-source-file))
- (loop :with state = :initial
- :until (or (eq state :success)
- (eq state :failure)) :do
- (case state
- (:recompiled
- (setf state :failure)
- (call-next-method)
- (setf state :success))
- (:failed-compile
- (setf state :recompiled)
- (perform-with-restarts o c))
- (t
- (with-simple-restart
- (try-recompiling "Try recompiling ~a"
- (component-name c))
- (setf state :failed-compile)
- (call-next-method)
- (setf state :success))))))
+ (loop
+ (restart-case
+ (return (call-next-method))
+ (try-recompiling ()
+ :report (lambda (s)
+ (format s "Recompile ~a and try loading it again"
+ (component-name c)))
+ (perform (make-sub-operation c o c 'compile-op) c)))))
+
+(defmethod perform ((o load-op) (c cl-source-file))
+ (map () #'load
+ #-(or ecl mkcl)
+ (input-files o c)
+ #+(or ecl mkcl)
+ (loop :for i :in (input-files o c)
+ :unless (string= (pathname-type i) "fas")
+ :collect (compile-file-pathname (lispize-pathname i)))))
(defmethod perform ((operation load-op) (c static-file))
(declare (ignorable operation c))
(declare (ignorable o))
(let ((source (component-pathname c)))
(setf (component-property c 'last-loaded-as-source)
- (and (load source)
+ (and (call-with-around-compile-hook
+ c #'(lambda () (load source :external-format (component-external-format c))))
(get-universal-time)))))
(defmethod perform ((operation load-source-op) (c static-file))
(declare (ignorable operation c))
nil)
-;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
+;;; FIXME: We simply copy load-op's dependencies. This is Just Not Right.
(defmethod component-depends-on ((o load-source-op) (c component))
(declare (ignorable o))
(loop :with what-would-load-op-do = (component-depends-on 'load-op c)
(defgeneric* operate (operation-class system &key &allow-other-keys))
(defgeneric* perform-plan (plan &key))
+;;;; Separating this into a different function makes it more forward-compatible
+(defun* cleanup-upgraded-asdf (old-version)
+ (let ((new-version (asdf-version)))
+ (unless (equal old-version new-version)
+ (cond
+ ((version-satisfies new-version old-version)
+ (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
+ old-version new-version))
+ ((version-satisfies old-version new-version)
+ (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
+ old-version new-version))
+ (t
+ (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
+ old-version new-version)))
+ (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf)))
+ ;; Invalidate all systems but ASDF itself.
+ (setf *defined-systems* (make-defined-systems-table))
+ (register-system asdf)
+ ;; If we're in the middle of something, restart it.
+ (when *systems-being-defined*
+ (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name)))
+ (clrhash *systems-being-defined*)
+ (dolist (s l) (find-system s nil))))
+ t))))
+
;;;; Try to upgrade of ASDF. If a different version was used, return T.
;;;; We need do that before we operate on anything that depends on ASDF.
(defun* upgrade-asdf ()
- (let ((version (asdf:asdf-version)))
+ (let ((version (asdf-version)))
(handler-bind (((or style-warning warning) #'muffle-warning))
(operate 'load-op :asdf :verbose nil))
- (let ((new-version (asdf:asdf-version)))
- (block nil
- (cond
- ((equal version new-version)
- (return nil))
- ((version-satisfies new-version version)
- (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
- version new-version))
- ((version-satisfies version new-version)
- (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%")
- version new-version))
- (t
- (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
- version new-version)))
- (let ((asdf (find-system :asdf)))
- ;; invalidate all systems but ASDF itself
- (setf *defined-systems* (make-defined-systems-table))
- (register-system asdf)
- t)))))
+ (cleanup-upgraded-asdf version)))
(defmethod perform-plan ((steps list) &key)
(let ((*package* *package*)
(*readtable* *readtable*))
(with-compilation-unit ()
(loop :for (op . component) :in steps :do
- (loop
- (restart-case
- (progn
- (perform-with-restarts op component)
- (return))
- (retry ()
- :report
- (lambda (s)
- (format s (compatfmt "~@<Retry ~A.~@:>")
- (operation-description op component))))
- (accept ()
- :report
- (lambda (s)
- (format s (compatfmt "~@<Continue, treating ~A as having been successful.~@:>")
- (operation-description op component)))
- (setf (gethash (type-of op)
- (component-operation-times component))
- (get-universal-time))
- (return))))))))
+ (perform-with-restarts op component)))))
(defmethod operate (operation-class system &rest args
&key ((:verbose *asdf-verbose*) *asdf-verbose*) version force
&allow-other-keys)
(declare (ignore force))
- (let* ((op (apply 'make-instance operation-class
- :original-initargs args
- args))
- (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
- (system (etypecase system
- (system system)
- ((or string symbol) (find-system system)))))
- (unless (version-satisfies system version)
- (error 'missing-component-of-version :requires system :version version))
- (let ((steps (traverse op system)))
- (when (and (not (equal '("asdf") (component-find-path system)))
- (find-if #'(lambda (x) (equal '("asdf")
- (component-find-path (cdr x))))
- steps)
- (upgrade-asdf))
- ;; If we needed to upgrade ASDF to achieve our goal,
- ;; then do it specially as the first thing, then
- ;; invalidate all existing system
- ;; retry the whole thing with the new OPERATE function,
- ;; which on some implementations
- ;; has a new symbol shadowing the current one.
- (return-from operate
- (apply (find-symbol* 'operate :asdf) operation-class system args)))
- (perform-plan steps)
- (values op steps))))
+ (with-system-definitions ()
+ (let* ((op (apply 'make-instance operation-class
+ :original-initargs args
+ args))
+ (*verbose-out* (if *asdf-verbose* *standard-output* (make-broadcast-stream)))
+ (system (etypecase system
+ (system system)
+ ((or string symbol) (find-system system)))))
+ (unless (version-satisfies system version)
+ (error 'missing-component-of-version :requires system :version version))
+ (let ((steps (traverse op system)))
+ (when (and (not (equal '("asdf") (component-find-path system)))
+ (find '("asdf") (mapcar 'cdr steps)
+ :test 'equal :key 'component-find-path)
+ (upgrade-asdf))
+ ;; If we needed to upgrade ASDF to achieve our goal,
+ ;; then do it specially as the first thing, then
+ ;; invalidate all existing system
+ ;; retry the whole thing with the new OPERATE function,
+ ;; which on some implementations
+ ;; has a new symbol shadowing the current one.
+ (return-from operate
+ (apply (find-symbol* 'operate :asdf) operation-class system args)))
+ (perform-plan steps)
+ (values op steps)))))
(defun* oos (operation-class system &rest args &key force verbose version
&allow-other-keys)
"))
(setf (documentation 'oos 'function)
(format nil
- "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a"
+ "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a"
operate-docstring))
(setf (documentation 'operate 'function)
operate-docstring))
-(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
+(defun* load-system (system &rest keys &key force verbose version &allow-other-keys)
"Shorthand for `(operate 'asdf:load-op system)`.
See OPERATE for details."
(declare (ignore force verbose version))
- (apply 'operate 'load-op system args)
+ (apply 'operate *load-system-operation* system keys)
t)
+(defun* load-systems (&rest systems)
+ (map () 'load-system systems))
+
+(defun component-loaded-p (c)
+ (and (gethash 'load-op (component-operation-times (find-component c nil))) t))
+
+(defun loaded-systems ()
+ (remove-if-not 'component-loaded-p (registered-systems)))
+
+(defun require-system (s &rest keys &key &allow-other-keys)
+ (apply 'load-system s :force-not (loaded-systems) keys))
+
(defun* compile-system (system &rest args &key force verbose version
&allow-other-keys)
- "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
+ "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE
for details."
(declare (ignore force verbose version))
(apply 'operate 'compile-op system args)
(defun* test-system (system &rest args &key force verbose version
&allow-other-keys)
- "Shorthand for `(operate 'asdf:test-op system)`. See OPERATE for
+ "Shorthand for `(asdf:operate 'asdf:test-op system)`. See OPERATE for
details."
(declare (ignore force verbose version))
(apply 'operate 'test-op system args)
(defun* load-pathname ()
(resolve-symlinks* (or *load-pathname* *compile-file-pathname*)))
-(defun* determine-system-pathname (pathname pathname-supplied-p)
+(defun* determine-system-pathname (pathname)
;; The defsystem macro calls us to determine
;; the pathname of a system as follows:
;; 1. the one supplied,
;; 3. taken from the *default-pathname-defaults* via default-directory
(let* ((file-pathname (load-pathname))
(directory-pathname (and file-pathname (pathname-directory-pathname file-pathname))))
- (or (and pathname-supplied-p
- (merge-pathnames* (coerce-pathname pathname :type :directory)
- directory-pathname))
+ (or (and pathname (subpathname directory-pathname pathname :type :directory))
directory-pathname
(default-directory))))
-(defmacro defsystem (name &body options)
- (setf name (coerce-name name))
- (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system)
- defsystem-depends-on &allow-other-keys)
- options
- (let ((component-options (remove-keys '(:class) options)))
- `(progn
- ;; system must be registered before we parse the body, otherwise
- ;; we recur when trying to find an existing system of the same name
- ;; to reuse options (e.g. pathname) from
- ,@(loop :for system :in defsystem-depends-on
- :collect `(load-system ',(coerce-name system)))
- (let ((s (system-registered-p ',name)))
- (cond ((and s (eq (type-of (cdr s)) ',class))
- (setf (car s) (get-universal-time)))
- (s
- (change-class (cdr s) ',class))
- (t
- (register-system (make-instance ',class :name ',name))))
- (%set-system-source-file (load-pathname)
- (cdr (system-registered-p ',name))))
- (parse-component-form
- nil (list*
- :module (coerce-name ',name)
- :pathname
- ,(determine-system-pathname pathname pathname-arg-p)
- ',component-options))))))
+(defun* find-class* (x &optional (errorp t) environment)
+ (etypecase x
+ ((or standard-class built-in-class) x)
+ (symbol (find-class x errorp environment))))
(defun* class-for-type (parent type)
(or (loop :for symbol :in (list
class (find-class 'component)))
:return class)
(and (eq type :file)
- (or (module-default-component-class parent)
- (find-class *default-component-class*)))
+ (find-class*
+ (or (loop :for module = parent :then (component-parent module) :while module
+ :thereis (module-default-component-class module))
+ *default-component-class*) nil))
(sysdef-error "don't recognize component type ~A" type)))
(defun* maybe-add-tree (tree op1 op2 c)
(if first-op-tree
(progn
(aif (assoc op2 (cdr first-op-tree))
- (if (find c (cdr it))
+ (if (find c (cdr it) :test #'equal)
nil
(setf (cdr it) (cons c (cdr it))))
(setf (cdr first-op-tree)
(defvar *serial-depends-on* nil)
(defun* sysdef-error-component (msg type name value)
- (sysdef-error (concatenate 'string msg
- (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
+ (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
type name value))
(defun* check-component-input (type name weakly-depends-on
(type name &rest rest &key
;; the following list of keywords is reproduced below in the
;; remove-keys form. important to keep them in sync
- components pathname default-component-class
+ components pathname
perform explain output-files operation-done-p
- weakly-depends-on
- depends-on serial in-order-to
+ weakly-depends-on depends-on serial in-order-to
+ do-first
(version nil versionp)
;; list ends
&allow-other-keys) options
(warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
version name parent)))
- (let* ((other-args (remove-keys
- '(components pathname default-component-class
- perform explain output-files operation-done-p
- weakly-depends-on
- depends-on serial in-order-to)
- rest))
- (ret
- (or (find-component parent name)
- (make-instance (class-for-type parent type)))))
+ (let* ((args (list* :name (coerce-name name)
+ :pathname pathname
+ :parent parent
+ (remove-keys
+ '(components pathname
+ perform explain output-files operation-done-p
+ weakly-depends-on depends-on serial in-order-to)
+ rest)))
+ (ret (find-component parent name)))
(when weakly-depends-on
- (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on)))
+ (appendf depends-on (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
(when *serial-depends-on*
(push *serial-depends-on* depends-on))
- (apply 'reinitialize-instance ret
- :name (coerce-name name)
- :pathname pathname
- :parent parent
- other-args)
+ (if ret ; preserve identity
+ (apply 'reinitialize-instance ret args)
+ (setf ret (apply 'make-instance (class-for-type parent type) args)))
(component-pathname ret) ; eagerly compute the absolute pathname
(when (typep ret 'module)
- (setf (module-default-component-class ret)
- (or default-component-class
- (and (typep parent 'module)
- (module-default-component-class parent))))
(let ((*serial-depends-on* nil))
(setf (module-components ret)
(loop
in-order-to
`((compile-op (compile-op ,@depends-on))
(load-op (load-op ,@depends-on)))))
- (setf (component-do-first ret) `((compile-op (load-op ,@depends-on))))
+ (setf (component-do-first ret)
+ (union-of-dependencies
+ do-first
+ `((compile-op (load-op ,@depends-on)))))
(%refresh-component-inline-methods ret rest)
ret)))
+(defun* reset-system (system &rest keys &key &allow-other-keys)
+ (change-class (change-class system 'proto-system) 'system)
+ (apply 'reinitialize-instance system keys))
+
+(defun* do-defsystem (name &rest options
+ &key pathname (class 'system)
+ defsystem-depends-on &allow-other-keys)
+ ;; The system must be registered before we parse the body,
+ ;; otherwise we recur when trying to find an existing system
+ ;; of the same name to reuse options (e.g. pathname) from.
+ ;; To avoid infinite recursion in cases where you defsystem a system
+ ;; that is registered to a different location to find-system,
+ ;; we also need to remember it in a special variable *systems-being-defined*.
+ (with-system-definitions ()
+ (let* ((name (coerce-name name))
+ (registered (system-registered-p name))
+ (registered! (if registered
+ (rplaca registered (get-universal-time))
+ (register-system (make-instance 'system :name name))))
+ (system (reset-system (cdr registered!)
+ :name name :source-file (load-pathname)))
+ (component-options (remove-keys '(:class) options)))
+ (setf (gethash name *systems-being-defined*) system)
+ (apply 'load-systems defsystem-depends-on)
+ ;; We change-class (when necessary) AFTER we load the defsystem-dep's
+ ;; since the class might not be defined as part of those.
+ (let ((class (class-for-type nil class)))
+ (unless (eq (type-of system) class)
+ (change-class system class)))
+ (parse-component-form
+ nil (list*
+ :module name
+ :pathname (determine-system-pathname pathname)
+ component-options)))))
+
+(defmacro defsystem (name &body options)
+ `(apply 'do-defsystem ',name ',options))
+
;;;; ---------------------------------------------------------------------------
;;;; run-shell-command
;;;;
;;;; gratefully accepted, if they do the same thing.
;;;; If the docstring is ambiguous, send a bug report.
;;;;
+;;;; WARNING! The function below is mostly dysfunctional.
+;;;; For instance, it will probably run fine on most implementations on Unix,
+;;;; which will hopefully use the shell /bin/sh (which we force in some cases)
+;;;; which is hopefully reasonably compatible with a POSIX *or* Bourne shell.
+;;;; But behavior on Windows may vary wildly between implementations,
+;;;; either relying on your having installed a POSIX sh, or going through
+;;;; the CMD.EXE interpreter, for a totally different meaning, depending on
+;;;; what is easily expressible in said implementation.
+;;;;
;;;; We probably should move this functionality to its own system and deprecate
;;;; use of it from the asdf package. However, this would break unspecified
;;;; existing software, so until a clear alternative exists, we can't deprecate
;;;; it, and even after it's been deprecated, we will support it for a few
;;;; years so everyone has time to migrate away from it. -- fare 2009-12-01
+;;;;
+;;;; As a suggested replacement which is portable to all ASDF-supported
+;;;; implementations and operating systems except Genera, I recommend
+;;;; xcvb-driver's xcvb-driver:run-program/ and its derivatives.
(defun* run-shell-command (control-string &rest args)
"Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
;; will this fail if command has embedded quotes - it seems to work
(multiple-value-bind (stdout stderr exit-code)
(excl.osi:command-output
- (format nil "~a -c \"~a\""
- #+mswindows "sh" #-mswindows "/bin/sh" command)
+ #-mswindows (vector "/bin/sh" "/bin/sh" "-c" command)
+ #+mswindows command ; BEWARE!
:input nil :whole nil
#+mswindows :show-window #+mswindows :hide)
- (asdf-message "~{~&; ~a~%~}~%" stderr)
- (asdf-message "~{~&; ~a~%~}~%" stdout)
+ (asdf-message "~{~&~a~%~}~%" stderr)
+ (asdf-message "~{~&~a~%~}~%" stdout)
exit-code)
- #+clisp ;XXX not exactly *verbose-out*, I know
- (or (ext:run-shell-command command :output (and *verbose-out* :terminal) :wait t) 0)
+ #+clisp
+ ;; CLISP returns NIL for exit status zero.
+ (if *verbose-out*
+ (let* ((new-command (format nil "( ~A ) ; r=$? ; echo ; echo ASDF-EXIT-STATUS $r"
+ command))
+ (outstream (ext:run-shell-command new-command :output :stream :wait t)))
+ (multiple-value-bind (retval out-lines)
+ (unwind-protect
+ (parse-clisp-shell-output outstream)
+ (ignore-errors (close outstream)))
+ (asdf-message "~{~&~a~%~}~%" out-lines)
+ retval))
+ ;; there will be no output, just grab up the exit status
+ (or (ext:run-shell-command command :output nil :wait t) 0))
#+clozure
(nth-value 1
(ccl:external-process-status
- (ccl:run-program "/bin/sh" (list "-c" command)
- :input nil :output *verbose-out*
- :wait t)))
+ (ccl:run-program
+ (cond
+ ((os-unix-p) "/bin/sh")
+ ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE!
+ (t (error "Unsupported OS")))
+ (if (os-unix-p) (list "-c" command) '())
+ :input nil :output *verbose-out* :wait t)))
+
+ #+(or cmu scl)
+ (ext:process-exit-code
+ (ext:run-program
+ "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*))
+
+ #+cormanlisp
+ (win32:system command)
#+ecl ;; courtesy of Juan Jose Garcia Ripoll
- (si:system command)
+ (ext:system command)
#+gcl
(lisp:system command)
#+lispworks
- (system:call-system-showing-output
- command
- :shell-type "/bin/sh"
- :show-cmd nil
- :prefix ""
- :output-stream *verbose-out*)
+ (apply 'system:call-system-showing-output command
+ :show-cmd nil :prefix "" :output-stream *verbose-out*
+ (when (os-unix-p) '(:shell-type "/bin/sh")))
+
+ #+mcl
+ (ccl::with-cstrs ((%command command)) (_system %command))
+
+ #+mkcl
+ ;; This has next to no chance of working on basic Windows!
+ ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH.
+ (multiple-value-bind (io process exit-code)
+ (apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh"
+ (list "-c" command)
+ :input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it
+ #-windows '(:search nil))
+ (declare (ignore io process))
+ exit-code)
#+sbcl
(sb-ext:process-exit-code
:input nil :output *verbose-out*
#+win32 '(:search t) #-win32 nil))
- #+(or cmu scl)
- (ext:process-exit-code
- (ext:run-program
- "/bin/sh"
- (list "-c" command)
- :input nil :output *verbose-out*))
-
#+xcl
(ext:run-shell-command command)
- #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl)
+ #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl)
(error "RUN-SHELL-COMMAND not implemented for this Lisp")))
+#+clisp
+(defun* parse-clisp-shell-output (stream)
+ "Helper function for running shell commands under clisp. Parses a specially-
+crafted output string to recover the exit status of the shell command and a
+list of lines of output."
+ (loop :with status-prefix = "ASDF-EXIT-STATUS "
+ :with prefix-length = (length status-prefix)
+ :with exit-status = -1 :with lines = ()
+ :for line = (read-line stream nil nil)
+ :while line :do (push line lines) :finally
+ (let* ((last (car lines))
+ (status (and last (>= (length last) prefix-length)
+ (string-equal last status-prefix :end1 prefix-length)
+ (parse-integer last :start prefix-length :junk-allowed t))))
+ (when status
+ (setf exit-status status)
+ (pop lines) (when (equal "" (car lines)) (pop lines)))
+ (return (values exit-status (reverse lines))))))
+
;;;; ---------------------------------------------------------------------------
;;;; system-relative-pathname
if that's whay you mean." ;;)
(system-source-file x))
+(defmethod system-source-file ((system system))
+ ;; might be missing when upgrading from ASDF 1 and u-i-f-r-c failed
+ (unless (slot-boundp system 'source-file)
+ (%set-system-source-file
+ (probe-asd (component-name system) (component-pathname system)) system))
+ (%system-source-file system))
(defmethod system-source-file ((system-name string))
- (system-source-file (find-system system-name)))
+ (%system-source-file (find-system system-name)))
(defmethod system-source-file ((system-name symbol))
- (system-source-file (find-system system-name)))
+ (%system-source-file (find-system system-name)))
(defun* system-source-directory (system-designator)
"Return a pathname object corresponding to the
directory in which the system specification (.asd file) is
located."
- (make-pathname :name nil
- :type nil
- :defaults (system-source-file system-designator)))
+ (pathname-directory-pathname (system-source-file system-designator)))
(defun* relativize-directory (directory)
(cond
:defaults p)))
(defun* system-relative-pathname (system name &key type)
- (merge-pathnames*
- (coerce-pathname name :type type)
- (system-source-directory system)))
+ (subpathname (system-source-directory system) name :type type))
;;; ---------------------------------------------------------------------------
;;; implementation-identifier
;;;
;;; produce a string to identify current implementation.
-;;; Initially stolen from SLIME's SWANK, hacked since.
-
-(defparameter *implementation-features*
- '((:abcl :armedbear)
- (:acl :allegro)
- (:mcl :digitool) ; before clozure, so it won't get preempted by ccl
- (:ccl :clozure)
- (:corman :cormanlisp)
- (:lw :lispworks)
- :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl))
-
-(defparameter *os-features*
- '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows
- (:solaris :sunos)
- (:linux :linux-target) ;; for GCL at least, must appear before :bsd.
- (:macosx :darwin :darwin-target :apple)
- :freebsd :netbsd :openbsd :bsd
- :unix
- :genera))
-
-(defparameter *architecture-features*
- '((:amd64 :x86-64 :x86_64 :x8664-target)
- (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
- :hppa64 :hppa
- (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc)
- :sparc64 (:sparc32 :sparc)
- (:arm :arm-target)
- (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7)
- :mipsel :mipseb :mips
- :alpha
- :imach))
-
-(defun* lisp-version-string ()
- (let ((s (lisp-implementation-version)))
- (declare (ignorable s))
- #+allegro (format nil
- "~A~A~A~A"
- excl::*common-lisp-version-number*
- ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
- (if (eq excl:*current-case-mode*
- :case-sensitive-lower) "M" "A")
- ;; Note if not using International ACL
- ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
- (excl:ics-target-case
- (:-ics "8")
- (:+ics ""))
- (if (member :64bit *features*) "-64bit" ""))
- #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
- #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
- #+clozure (format nil "~d.~d-f~d" ; shorten for windows
- ccl::*openmcl-major-version*
- ccl::*openmcl-minor-version*
- (logand ccl::fasl-version #xFF))
- #+cmu (substitute #\- #\/ s)
- #+ecl (format nil "~A~@[-~A~]" s
- (let ((vcs-id (ext:lisp-implementation-vcs-id)))
- (when (>= (length vcs-id) 8)
- (subseq vcs-id 0 8))))
- #+gcl (subseq s (1+ (position #\space s)))
- #+genera (multiple-value-bind (major minor) (sct:get-system-version "System")
- (format nil "~D.~D" major minor))
- #+lispworks (format nil "~A~@[~A~]" s
- (when (member :lispworks-64bit *features*) "-64bit"))
- ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version
- #+mcl (subseq s 8) ; strip the leading "Version "
- #+(or cormanlisp sbcl scl) s
- #-(or allegro armedbear clisp clozure cmu cormanlisp
- ecl gcl genera lispworks mcl sbcl scl) s))
+;;; Initially stolen from SLIME's SWANK, rewritten since.
+;;; We're back to runtime checking, for the sake of e.g. ABCL.
(defun* first-feature (features)
- (labels
- ((fp (thing)
- (etypecase thing
- (symbol
- (let ((feature (find thing *features*)))
- (when feature (return-from fp feature))))
- ;; allows features to be lists of which the first
- ;; member is the "main name", the rest being aliases
- (cons
- (dolist (subf thing)
- (when (find subf *features*) (return-from fp (first thing))))))
- nil))
- (loop :for f :in features
- :when (fp f) :return :it)))
-
-(defun* implementation-type ()
- (first-feature *implementation-features*))
+ (dolist (x features)
+ (multiple-value-bind (val feature)
+ (if (consp x) (values (first x) (cons :or (rest x))) (values x x))
+ (when (featurep feature) (return val)))))
+
+(defun implementation-type ()
+ (first-feature
+ '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
+ :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl)))
+
+(defun operating-system ()
+ (first-feature
+ '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first!
+ (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd
+ (:macosx :macosx :darwin :darwin-target :apple) ; also before :bsd
+ (:solaris :solaris :sunos) (:bsd :bsd :freebsd :netbsd :openbsd) :unix
+ :genera)))
+
+(defun architecture ()
+ (first-feature
+ '((:x64 :amd64 :x86-64 :x86_64 :x8664-target (:and :word-size=64 :pc386))
+ (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target)
+ (:ppc64 :ppc64 :ppc64-target) (:ppc32 :ppc32 :ppc32-target :ppc :powerpc)
+ :hppa64 :hppa :sparc64 (:sparc32 :sparc32 :sparc)
+ :mipsel :mipseb :mips :alpha (:arm :arm :arm-target) :imach
+ ;; Java comes last: if someone uses C via CFFI or otherwise JNA or JNI,
+ ;; we may have to segregate the code still by architecture.
+ (:java :java :java-1.4 :java-1.5 :java-1.6 :java-1.7))))
+
+#+clozure
+(defun* ccl-fasl-version ()
+ ;; the fasl version is target-dependent from CCL 1.8 on.
+ (or (let ((s 'ccl::target-fasl-version))
+ (and (fboundp s) (funcall s)))
+ (and (boundp 'ccl::fasl-version)
+ (symbol-value 'ccl::fasl-version))
+ (error "Can't determine fasl version.")))
+
+(defun lisp-version-string ()
+ (let ((s (lisp-implementation-version)))
+ (car ; as opposed to OR, this idiom prevents some unreachable code warning
+ (list
+ #+allegro
+ (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
+ excl::*common-lisp-version-number*
+ ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
+ (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
+ ;; Note if not using International ACL
+ ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
+ (excl:ics-target-case (:-ics "8"))
+ (and (member :smp *features*) "S"))
+ #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
+ #+clisp
+ (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
+ #+clozure
+ (format nil "~d.~d-f~d" ; shorten for windows
+ ccl::*openmcl-major-version*
+ ccl::*openmcl-minor-version*
+ (logand (ccl-fasl-version) #xFF))
+ #+cmu (substitute #\- #\/ s)
+ #+scl (format nil "~A~A" s
+ ;; ANSI upper case vs lower case.
+ (ecase ext:*case-mode* (:upper "") (:lower "l")))
+ #+ecl (format nil "~A~@[-~A~]" s
+ (let ((vcs-id (ext:lisp-implementation-vcs-id)))
+ (subseq vcs-id 0 (min (length vcs-id) 8))))
+ #+gcl (subseq s (1+ (position #\space s)))
+ #+genera
+ (multiple-value-bind (major minor) (sct:get-system-version "System")
+ (format nil "~D.~D" major minor))
+ #+mcl (subseq s 8) ; strip the leading "Version "
+ s))))
(defun* implementation-identifier ()
- (labels
- ((maybe-warn (value fstring &rest args)
- (cond (value)
- (t (apply 'warn fstring args)
- "unknown"))))
- (let ((lisp (maybe-warn (implementation-type)
- (compatfmt "~@<No implementation feature found in ~a.~@:>")
- *implementation-features*))
- (os (maybe-warn (first-feature *os-features*)
- (compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*))
- (arch (or #-clisp
- (maybe-warn (first-feature *architecture-features*)
- (compatfmt "~@<No architecture feature found in ~a.~@:>")
- *architecture-features*)))
- (version (maybe-warn (lisp-version-string)
- "Don't know how to get Lisp implementation version.")))
- (substitute-if
- #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\""))
- (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch)))))
+ (substitute-if
+ #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\""))
+ (format nil "~(~a~@{~@[-~a~]~}~)"
+ (or (implementation-type) (lisp-implementation-type))
+ (or (lisp-version-string) (lisp-implementation-version))
+ (or (operating-system) (software-type))
+ (or (architecture) (machine-type)))))
+
+(defun* hostname ()
+ ;; Note: untested on RMCL
+ #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
+ #+cormanlisp "localhost" ;; is there a better way? Does it matter?
+ #+allegro (excl.osi:gethostname)
+ #+clisp (first (split-string (machine-instance) :separator " "))
+ #+gcl (system:gethostname))
;;; ---------------------------------------------------------------------------
;;; Generic support for configuration files
-(defparameter *inter-directory-separator*
- #+asdf-unix #\:
- #-asdf-unix #\;)
+(defun inter-directory-separator ()
+ (if (os-unix-p) #\: #\;))
(defun* user-homedir ()
- (truenamize (pathname-directory-pathname (user-homedir-pathname))))
-
-(defun* try-directory-subpath (x sub &key type)
- (let* ((p (and x (ensure-directory-pathname x)))
- (tp (and p (probe-file* p)))
- (sp (and tp (merge-pathnames* (coerce-pathname sub :type type) p)))
- (ts (and sp (probe-file* sp))))
- (and ts (values sp ts))))
+ (truenamize
+ (pathname-directory-pathname
+ #+cormanlisp (ensure-directory-pathname (user-homedir-pathname))
+ #+mcl (current-user-homedir-pathname)
+ #-(or cormanlisp mcl) (user-homedir-pathname))))
+
+(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
+ (when (plusp (length x))
+ (let ((p (if want-directory (ensure-directory-pathname x) (pathname x))))
+ (when want-absolute
+ (unless (absolute-pathname-p p)
+ (cerror "ignore relative pathname"
+ "Invalid relative pathname ~A~@[ ~?~]" x fmt args)
+ (return-from ensure-pathname* nil)))
+ p)))
+(defun* split-pathnames* (x want-absolute want-directory fmt &rest args)
+ (loop :for dir :in (split-string
+ x :separator (string (inter-directory-separator)))
+ :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args)))
+(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x)))
+ (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x))
+(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x)))
+ (and (plusp (length s))
+ (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s)))
+(defun* getenv-absolute-directory (x)
+ (getenv-pathname x :want-absolute t :want-directory t))
+(defun* getenv-absolute-directories (x)
+ (getenv-pathnames x :want-absolute t :want-directory t))
+
+(defun* get-folder-path (folder)
+ (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
+ #+(and lispworks mswindows) (sys:get-folder-path folder)
+ ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+ (ecase folder
+ (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
+ (:appdata (getenv-absolute-directory "APPDATA"))
+ (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
+ (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
+
(defun* user-configuration-directories ()
- (remove-if
- #'null
- (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
- `(,(try (getenv "XDG_CONFIG_HOME") "common-lisp/")
- ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS")
- :for dir :in (split-string dirs :separator ":")
- :collect (try dir "common-lisp/"))
- #+asdf-windows
- ,@`(#+lispworks ,(try (sys:get-folder-path :common-appdata) "common-lisp/config/")
- ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
- ,(try (getenv "APPDATA") "common-lisp/config/"))
- ,(try (user-homedir) ".config/common-lisp/")))))
+ (let ((dirs
+ `(,@(when (os-unix-p)
+ (cons
+ (subpathname* (getenv-absolute-directory "XDG_CONFIG_HOME") "common-lisp/")
+ (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
+ :collect (subpathname* dir "common-lisp/"))))
+ ,@(when (os-windows-p)
+ `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
+ ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
+ ,(subpathname (user-homedir) ".config/common-lisp/"))))
+ (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
+ :from-end t :test 'equal)))
+
(defun* system-configuration-directories ()
- (remove-if
- #'null
- (append
- #+asdf-windows
- (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
- `(,@`(#+lispworks ,(try (sys:get-folder-path :local-appdata) "common-lisp/config/")
- ;;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
- ,(try (getenv "ALLUSERSPROFILE") "Application Data/common-lisp/config/"))))
- #+asdf-unix
- (list #p"/etc/common-lisp/"))))
-(defun* in-first-directory (dirs x)
- (loop :for dir :in dirs
- :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir))))))
-(defun* in-user-configuration-directory (x)
- (in-first-directory (user-configuration-directories) x))
-(defun* in-system-configuration-directory (x)
- (in-first-directory (system-configuration-directories) x))
+ (cond
+ ((os-unix-p) '(#p"/etc/common-lisp/"))
+ ((os-windows-p)
+ (aif
+ ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
+ (subpathname* (get-folder-path :common-appdata) "common-lisp/config/")
+ (list it)))))
+
+(defun* in-first-directory (dirs x &key (direction :input))
+ (loop :with fun = (ecase direction
+ ((nil :input :probe) 'probe-file*)
+ ((:output :io) 'identity))
+ :for dir :in dirs
+ :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir))))))
+
+(defun* in-user-configuration-directory (x &key (direction :input))
+ (in-first-directory (user-configuration-directories) x :direction direction))
+(defun* in-system-configuration-directory (x &key (direction :input))
+ (in-first-directory (system-configuration-directories) x :direction direction))
(defun* configuration-inheritance-directive-p (x)
(let ((kw '(:inherit-configuration :ignore-inherited-configuration)))
#+clozure '(:follow-links nil)
#+clisp '(:circle t :if-does-not-exist :ignore)
#+(or cmu scl) '(:follow-links nil :truenamep nil)
- #+sbcl (when (find-symbol "RESOLVE-SYMLINKS" "SB-IMPL") '(:resolve-symlinks nil))))))
+ #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl)
+ '(:resolve-symlinks nil))))))
(defun* validate-configuration-directory (directory tag validator &key invalid-form-reporter)
"Map the VALIDATOR across the .conf files in DIRECTORY, the TAG will
(defvar *user-cache*
(flet ((try (x &rest sub) (and x `(,x ,@sub))))
(or
- (try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
- #+asdf-windows
- (try (getenv "APPDATA") "common-lisp" "cache" :implementation)
+ (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
+ (when (os-windows-p)
+ (try (or (get-folder-path :local-appdata)
+ (get-folder-path :appdata))
+ "common-lisp" "cache" :implementation))
'(:home ".cache" "common-lisp" :implementation))))
-(defvar *system-cache*
- ;; No good default, plus there's a security problem
- ;; with other users messing with such directories.
- *user-cache*)
(defun* output-translations ()
(car *output-translations*))
(values (or null pathname) &optional))
resolve-location))
-(defun* resolve-relative-location-component (super x &key directory wilden)
- (let* ((r (etypecase x
- (pathname x)
- (string x)
- (cons
- (return-from resolve-relative-location-component
- (if (null (cdr x))
+(defun* resolve-relative-location-component (x &key directory wilden)
+ (let ((r (etypecase x
+ (pathname x)
+ (string (coerce-pathname x :type (when directory :directory)))
+ (cons
+ (if (null (cdr x))
+ (resolve-relative-location-component
+ (car x) :directory directory :wilden wilden)
+ (let* ((car (resolve-relative-location-component
+ (car x) :directory t :wilden nil)))
+ (merge-pathnames*
(resolve-relative-location-component
- super (car x) :directory directory :wilden wilden)
- (let* ((car (resolve-relative-location-component
- super (car x) :directory t :wilden nil))
- (cdr (resolve-relative-location-component
- (merge-pathnames* car super) (cdr x)
- :directory directory :wilden wilden)))
- (merge-pathnames* cdr car)))))
- ((eql :default-directory)
- (relativize-pathname-directory (default-directory)))
- ((eql :*/) *wild-directory*)
- ((eql :**/) *wild-inferiors*)
- ((eql :*.*.*) *wild-file*)
- ((eql :implementation) (implementation-identifier))
- ((eql :implementation-type) (string-downcase (implementation-type)))
- #+asdf-unix
- ((eql :uid) (princ-to-string (get-uid)))))
- (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r)))
- (s (if (or (pathnamep x) (not wilden)) d (wilden d))))
- (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super))))
- (error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super))
- (merge-pathnames* s super)))
+ (cdr x) :directory directory :wilden wilden)
+ car))))
+ ((eql :default-directory)
+ (relativize-pathname-directory (default-directory)))
+ ((eql :*/) *wild-directory*)
+ ((eql :**/) *wild-inferiors*)
+ ((eql :*.*.*) *wild-file*)
+ ((eql :implementation)
+ (coerce-pathname (implementation-identifier) :type :directory))
+ ((eql :implementation-type)
+ (coerce-pathname (string-downcase (implementation-type)) :type :directory))
+ ((eql :hostname)
+ (coerce-pathname (hostname) :type :directory)))))
+ (when (absolute-pathname-p r)
+ (error (compatfmt "~@<pathname ~S is not relative~@:>") x))
+ (if (or (pathnamep x) (not wilden)) r (wilden r))))
(defvar *here-directory* nil
"This special variable is bound to the currect directory during calls to
(let* ((r
(etypecase x
(pathname x)
- (string (if directory (ensure-directory-pathname x) (parse-namestring x)))
+ (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x)))
+ #+mcl (unless p (error "POSIX pathname ~S does not exist" x))
+ (if directory (ensure-directory-pathname p) p)))
(cons
(return-from resolve-absolute-location-component
(if (null (cdr x))
(resolve-absolute-location-component
(car x) :directory directory :wilden wilden)
- (let* ((car (resolve-absolute-location-component
- (car x) :directory t :wilden nil))
- (cdr (resolve-relative-location-component
- car (cdr x) :directory directory :wilden wilden)))
- (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ?
+ (merge-pathnames*
+ (resolve-relative-location-component
+ (cdr x) :directory directory :wilden wilden)
+ (resolve-absolute-location-component
+ (car x) :directory t :wilden nil)))))
((eql :root)
;; special magic! we encode such paths as relative pathnames,
;; but it means "relative to the root of the source pathname's host and device".
:default-directory)
:directory t :wilden nil))
((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil))
- ((eql :system-cache) (resolve-location *system-cache* :directory t :wilden nil))
+ ((eql :system-cache)
+ (error "Using the :system-cache is deprecated. ~%~
+Please remove it from your ASDF configuration"))
((eql :default-directory) (default-directory))))
(s (if (and wilden (not (pathnamep x)))
(wilden r)
r)))
(unless (absolute-pathname-p s)
- (error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s))
+ (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x))
s))
(defun* resolve-location (x &key directory wilden)
:for (component . morep) :on (cdr x)
:for dir = (and (or morep directory) t)
:for wild = (and wilden (not morep))
- :do (setf path (resolve-relative-location-component
- path component :directory dir :wilden wild))
+ :do (setf path (merge-pathnames*
+ (resolve-relative-location-component
+ component :directory dir :wilden wild)
+ path))
:finally (return path))))
(defun* location-designator-p (x)
(relative-component-p (c)
(typep c '(or string pathname
(member :default-directory :*/ :**/ :*.*.*
- :implementation :implementation-type
- #+asdf-unix :uid)))))
+ :implementation :implementation-type)))))
(or (typep x 'boolean)
(absolute-component-p x)
(and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x))))))
(defun* location-function-p (x)
(and
- (consp x)
(length=n-p x 2)
- (or (and (equal (first x) :function)
- (typep (second x) 'symbol))
- (and (equal (first x) 'lambda)
- (cddr x)
- (length=n-p (second x) 2)))))
+ (eq (car x) :function)
+ (or (symbolp (cadr x))
+ (and (consp (cadr x))
+ (eq (caadr x) 'lambda)
+ (length=n-p (cadadr x) 2)))))
(defun* validate-output-translations-directive (directive)
(or (member directive '(:enable-user-cache :disable-cache nil))
:with start = 0
:with end = (length string)
:with source = nil
- :for i = (or (position *inter-directory-separator* string :start start) end) :do
+ :with separator = (inter-directory-separator)
+ :for i = (or (position separator string :start start) end) :do
(let ((s (subseq string start i)))
(cond
(source
`(:output-translations
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
- #+sbcl ,(let ((h (getenv "SBCL_HOME")))
- (when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
- #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) ; not needed: no precompiled ASDF system
- #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) ; not needed: no precompiled ASDF system
+ #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t)))
+ (when h `((,(truenamize h) ,*wild-inferiors*) ())))
+ ;; The below two are not needed: no precompiled ASDF system there
+ #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ())
+ #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
+ ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
;; All-import, here is where we want user stuff to be:
:inherit-configuration
;; These are for convenience, and can be overridden by the user:
(defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf"))
(defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/"))
-(defun* user-output-translations-pathname ()
- (in-user-configuration-directory *output-translations-file*))
-(defun* system-output-translations-pathname ()
- (in-system-configuration-directory *output-translations-file*))
-(defun* user-output-translations-directory-pathname ()
- (in-user-configuration-directory *output-translations-directory*))
-(defun* system-output-translations-directory-pathname ()
- (in-system-configuration-directory *output-translations-directory*))
+(defun* user-output-translations-pathname (&key (direction :input))
+ (in-user-configuration-directory *output-translations-file* :direction direction))
+(defun* system-output-translations-pathname (&key (direction :input))
+ (in-system-configuration-directory *output-translations-file* :direction direction))
+(defun* user-output-translations-directory-pathname (&key (direction :input))
+ (in-user-configuration-directory *output-translations-directory* :direction direction))
+(defun* system-output-translations-directory-pathname (&key (direction :input))
+ (in-system-configuration-directory *output-translations-directory* :direction direction))
(defun* environment-output-translations ()
(getenv "ASDF_OUTPUT_TRANSLATIONS"))
((eq dst t)
(funcall collect (list trusrc t)))
(t
- (let* ((trudst (make-pathname
- :defaults (if dst (resolve-location dst :directory t :wilden t) trusrc)))
+ (let* ((trudst (if dst
+ (resolve-location dst :directory t :wilden t)
+ trusrc))
(wilddst (merge-pathnames* *wild-file* trudst)))
(funcall collect (list wilddst t))
(funcall collect (list trusrc trudst)))))))))))
(translate-pathname path absolute-source destination))))
(defun* apply-output-translations (path)
+ #+cormanlisp (truenamize path) #-cormanlisp
(etypecase path
- #+cormanlisp (t (truenamize path))
(logical-pathname
path)
((or pathname string)
(defmethod output-files :around (operation component)
"Translate output files, unless asked not to"
- (declare (ignorable operation component))
+ operation component ;; hush genera, not convinced by declare ignorable(!)
(values
(multiple-value-bind (files fixedp) (call-next-method)
(if fixedp
t))
(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
- (or output-file
+ (if (absolute-pathname-p output-file)
+ ;; what cfp should be doing, w/ mp* instead of mp
+ (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
+ (defaults (make-pathname
+ :type type :defaults (merge-pathnames* input-file))))
+ (merge-pathnames* output-file defaults))
(apply-output-translations
- (apply 'compile-file-pathname
- (truenamize (lispize-pathname input-file))
- keys))))
+ (apply 'compile-file-pathname input-file
+ (if output-file keys (remove-keyword :output-file keys))))))
(defun* tmpize-pathname (x)
(make-pathname
- :name (format nil "ASDF-TMP-~A" (pathname-name x))
+ :name (strcat "ASDF-TMP-" (pathname-name x))
:defaults x))
(defun* delete-file-if-exists (x)
(when (and x (probe-file* x))
(delete-file x)))
-(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys)
- (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys)))
+(defun* compile-file* (input-file &rest keys &key compile-check output-file &allow-other-keys)
+ (let* ((keywords (remove-keyword :compile-check keys))
+ (output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))
(tmp-file (tmpize-pathname output-file))
(status :error))
(multiple-value-bind (output-truename warnings-p failure-p)
- (apply 'compile-file input-file :output-file tmp-file keys)
+ (apply 'compile-file input-file :output-file tmp-file keywords)
(cond
(failure-p
(setf status *compile-file-failure-behaviour*))
(setf status *compile-file-warnings-behaviour*))
(t
(setf status :success)))
- (ecase status
- ((:success :warn :ignore)
+ (cond
+ ((and (ecase status
+ ((:success :warn :ignore) t)
+ ((:error nil)))
+ (or (not compile-check)
+ (apply compile-check input-file :output-file tmp-file keywords)))
(delete-file-if-exists output-file)
(when output-truename
(rename-file output-truename output-file)
(setf output-truename output-file)))
- (:error
+ (t ;; error or failed check
(delete-file-if-exists output-truename)
- (setf output-truename nil)))
+ (setf output-truename nil failure-p t)))
(values output-truename warnings-p failure-p))))
#+abcl
(&key
(centralize-lisp-binaries nil)
(default-toplevel-directory
- ;; Use ".cache/common-lisp" instead ???
- (merge-pathnames* (make-pathname :directory '(:relative ".fasls"))
- (user-homedir)))
+ (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
(include-per-user-information nil)
- (map-all-source-files (or #+(or ecl clisp) t nil))
+ (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
(source-to-target-mappings nil))
- #+(or ecl clisp)
+ #+(or clisp ecl mkcl)
(when (null map-all-source-files)
- (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
+ (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
(let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
(mapped-files (if map-all-source-files *wild-file*
- (make-pathname :name :wild :version :wild :type fasl-type)))
+ (make-pathname :type fasl-type :defaults *wild-file*)))
(destination-directory
(if centralize-lisp-binaries
`(,default-toplevel-directory
:ignore-inherited-configuration))))
;;;; -----------------------------------------------------------------
-;;;; Windows shortcut support. Based on:
-;;;;
-;;;; Jesse Hager: The Windows Shortcut File Format.
-;;;; http://www.wotsit.org/list.asp?fc=13
-
-#+(and asdf-windows (not clisp))
-(progn
-(defparameter *link-initial-dword* 76)
-(defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70))
-
-(defun* read-null-terminated-string (s)
- (with-output-to-string (out)
- (loop :for code = (read-byte s)
- :until (zerop code)
- :do (write-char (code-char code) out))))
-
-(defun* read-little-endian (s &optional (bytes 4))
- (loop
- :for i :from 0 :below bytes
- :sum (ash (read-byte s) (* 8 i))))
-
-(defun* parse-file-location-info (s)
- (let ((start (file-position s))
- (total-length (read-little-endian s))
- (end-of-header (read-little-endian s))
- (fli-flags (read-little-endian s))
- (local-volume-offset (read-little-endian s))
- (local-offset (read-little-endian s))
- (network-volume-offset (read-little-endian s))
- (remaining-offset (read-little-endian s)))
- (declare (ignore total-length end-of-header local-volume-offset))
- (unless (zerop fli-flags)
- (cond
- ((logbitp 0 fli-flags)
- (file-position s (+ start local-offset)))
- ((logbitp 1 fli-flags)
- (file-position s (+ start
- network-volume-offset
- #x14))))
- (concatenate 'string
- (read-null-terminated-string s)
- (progn
- (file-position s (+ start remaining-offset))
- (read-null-terminated-string s))))))
-
-(defun* parse-windows-shortcut (pathname)
- (with-open-file (s pathname :element-type '(unsigned-byte 8))
- (handler-case
- (when (and (= (read-little-endian s) *link-initial-dword*)
- (let ((header (make-array (length *link-guid*))))
- (read-sequence header s)
- (equalp header *link-guid*)))
- (let ((flags (read-little-endian s)))
- (file-position s 76) ;skip rest of header
- (when (logbitp 0 flags)
- ;; skip shell item id list
- (let ((length (read-little-endian s 2)))
- (file-position s (+ length (file-position s)))))
- (cond
- ((logbitp 1 flags)
- (parse-file-location-info s))
- (t
- (when (logbitp 2 flags)
- ;; skip description string
- (let ((length (read-little-endian s 2)))
- (file-position s (+ length (file-position s)))))
- (when (logbitp 3 flags)
- ;; finally, our pathname
- (let* ((length (read-little-endian s 2))
- (buffer (make-array length)))
- (read-sequence buffer s)
- (map 'string #'code-char buffer)))))))
- (end-of-file ()
- nil)))))
-
-;;;; -----------------------------------------------------------------
;;;; Source Registry Configuration, by Francois-Rene Rideau
;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
"_sgbak" "autom4te.cache" "cover_db" "_build"
- "debian")) ;; debian often build stuff under the debian directory... BAD.
+ "debian")) ;; debian often builds stuff under the debian directory... BAD.
(defvar *source-registry-exclusions* *default-source-registry-exclusions*)
(defparameter *wild-asd*
(make-pathname :directory nil :name *wild* :type "asd" :version :newest))
-(defun directory-asd-files (directory)
- (ignore-errors
- (directory* (merge-pathnames* *wild-asd* directory))))
-
-(defun subdirectories (directory)
+(defun* filter-logical-directory-results (directory entries merger)
+ (if (typep directory 'logical-pathname)
+ ;; Try hard to not resolve logical-pathname into physical pathnames;
+ ;; otherwise logical-pathname users/lovers will be disappointed.
+ ;; If directory* could use some implementation-dependent magic,
+ ;; we will have logical pathnames already; otherwise,
+ ;; we only keep pathnames for which specifying the name and
+ ;; translating the LPN commute.
+ (loop :for f :in entries
+ :for p = (or (and (typep f 'logical-pathname) f)
+ (let* ((u (ignore-errors (funcall merger f))))
+ ;; The first u avoids a cumbersome (truename u) error.
+ ;; At this point f should already be a truename,
+ ;; but isn't quite in CLISP, for doesn't have :version :newest
+ (and u (equal (ignore-errors (truename u)) (truename f)) u)))
+ :when p :collect p)
+ entries))
+
+(defun* directory-files (directory &optional (pattern *wild-file*))
+ (let ((dir (pathname directory)))
+ (when (typep dir 'logical-pathname)
+ ;; Because of the filtering we do below,
+ ;; logical pathnames have restrictions on wild patterns.
+ ;; Not that the results are very portable when you use these patterns on physical pathnames.
+ (when (wild-pathname-p dir)
+ (error "Invalid wild pattern in logical directory ~S" directory))
+ (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
+ (error "Invalid file pattern ~S for logical directory ~S" pattern directory))
+ (setf pattern (make-pathname-logical pattern (pathname-host dir))))
+ (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
+ (filter-logical-directory-results
+ directory entries
+ #'(lambda (f)
+ (make-pathname :defaults dir
+ :name (make-pathname-component-logical (pathname-name f))
+ :type (make-pathname-component-logical (pathname-type f))
+ :version (make-pathname-component-logical (pathname-version f))))))))
+
+(defun* directory-asd-files (directory)
+ (directory-files directory *wild-asd*))
+
+(defun* subdirectories (directory)
(let* ((directory (ensure-directory-pathname directory))
- #-(or cormanlisp genera xcl)
+ #-(or abcl cormanlisp genera xcl)
(wild (merge-pathnames*
- #-(or abcl allegro cmu lispworks scl xcl)
+ #-(or abcl allegro cmu lispworks sbcl scl xcl)
*wild-directory*
- #+(or abcl allegro cmu lispworks scl xcl) "*.*"
+ #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*"
directory))
(dirs
- #-(or cormanlisp genera xcl)
+ #-(or abcl cormanlisp genera xcl)
(ignore-errors
(directory* wild . #.(or #+clozure '(:directories t :files nil)
#+mcl '(:directories t))))
+ #+(or abcl xcl) (system:list-directory directory)
#+cormanlisp (cl::directory-subdirs directory)
- #+genera (fs:directory-list directory)
- #+xcl (system:list-directory directory))
- #+(or abcl allegro cmu genera lispworks scl xcl)
+ #+genera (fs:directory-list directory))
+ #+(or abcl allegro cmu genera lispworks sbcl scl xcl)
(dirs (loop :for x :in dirs
:for d = #+(or abcl xcl) (extensions:probe-directory x)
#+allegro (excl:probe-directory x)
- #+(or cmu scl) (directory-pathname-p x)
+ #+(or cmu sbcl scl) (directory-pathname-p x)
#+genera (getf (cdr x) :directory)
#+lispworks (lw:file-directory-p x)
:when d :collect #+(or abcl allegro xcl) d
#+genera (ensure-directory-pathname (first x))
- #+(or cmu lispworks scl) x)))
- dirs))
-
-(defun collect-asds-in-directory (directory collect)
+ #+(or cmu lispworks sbcl scl) x)))
+ (filter-logical-directory-results
+ directory dirs
+ (let ((prefix (or (normalize-pathname-directory-component (pathname-directory directory))
+ '(:absolute)))) ; because allegro returns NIL for #p"FOO:"
+ #'(lambda (d)
+ (let ((dir (normalize-pathname-directory-component (pathname-directory d))))
+ (and (consp dir) (consp (cdr dir))
+ (make-pathname
+ :defaults directory :name nil :type nil :version nil
+ :directory (append prefix (make-pathname-component-logical (last dir)))))))))))
+
+(defun* collect-asds-in-directory (directory collect)
(map () collect (directory-asd-files directory)))
-(defun collect-sub*directories (directory collectp recursep collector)
+(defun* collect-sub*directories (directory collectp recursep collector)
(when (funcall collectp directory)
(funcall collector directory))
(dolist (subdir (subdirectories directory))
(when (funcall recursep subdir)
(collect-sub*directories subdir collectp recursep collector))))
-(defun collect-sub*directories-asd-files
+(defun* collect-sub*directories-asd-files
(directory &key
(exclude *default-source-registry-exclusions*)
collect)
:with directives = ()
:with start = 0
:with end = (length string)
- :for pos = (position *inter-directory-separator* string :start start) :do
+ :with separator = (inter-directory-separator)
+ :for pos = (position separator string :start start) :do
(let ((s (subseq string start (or pos end))))
- (cond
- ((equal "" s) ; empty element: inherit
- (when inherit
- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
- string))
- (setf inherit t)
- (push ':inherit-configuration directives))
- ((ends-with s "//")
- (push `(:tree ,(subseq s 0 (1- (length s)))) directives))
- (t
- (push `(:directory ,s) directives)))
+ (flet ((check (dir)
+ (unless (absolute-pathname-p dir)
+ (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
+ dir))
+ (cond
+ ((equal "" s) ; empty element: inherit
+ (when inherit
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
+ (setf inherit t)
+ (push ':inherit-configuration directives))
+ ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
+ (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
+ (t
+ (push `(:directory ,(check s)) directives))))
(cond
(pos
(setf start (1+ pos)))
(defun* wrapping-source-registry ()
`(:source-registry
- #+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
+ #+ecl (:tree ,(translate-logical-pathname "SYS:"))
+ #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
+ #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t)))
:inherit-configuration
- #+cmu (:tree #p"modules:")))
+ #+cmu (:tree #p"modules:")
+ #+scl (:tree #p"file://modules/")))
(defun* default-source-registry ()
- (flet ((try (x sub) (try-directory-subpath x sub :type :directory)))
- `(:source-registry
- #+sbcl (:directory ,(merge-pathnames* ".sbcl/systems/" (user-homedir)))
- (:directory ,(default-directory))
- ,@(let*
- #+asdf-unix
- ((datahome
- (or (getenv "XDG_DATA_HOME")
- (try (user-homedir) ".local/share/")))
- (datadirs
- (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share"))
- (dirs (cons datahome (split-string datadirs :separator ":"))))
- #+asdf-windows
- ((datahome (getenv "APPDATA"))
- (datadir
- #+lispworks (sys:get-folder-path :local-appdata)
- #-lispworks (try (getenv "ALLUSERSPROFILE")
- "Application Data"))
- (dirs (list datahome datadir)))
- #-(or asdf-unix asdf-windows)
- ((dirs ()))
- (loop :for dir :in dirs
- :collect `(:directory ,(try dir "common-lisp/systems/"))
- :collect `(:tree ,(try dir "common-lisp/source/"))))
- :inherit-configuration)))
-(defun* user-source-registry ()
- (in-user-configuration-directory *source-registry-file*))
-(defun* system-source-registry ()
- (in-system-configuration-directory *source-registry-file*))
-(defun* user-source-registry-directory ()
- (in-user-configuration-directory *source-registry-directory*))
-(defun* system-source-registry-directory ()
- (in-system-configuration-directory *source-registry-directory*))
+ `(:source-registry
+ #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
+ (:directory ,(default-directory))
+ ,@(loop :for dir :in
+ `(,@(when (os-unix-p)
+ `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
+ (subpathname (user-homedir) ".local/share/"))
+ ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
+ '("/usr/local/share" "/usr/share"))))
+ ,@(when (os-windows-p)
+ (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
+ :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+ :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+ :inherit-configuration))
+(defun* user-source-registry (&key (direction :input))
+ (in-user-configuration-directory *source-registry-file* :direction direction))
+(defun* system-source-registry (&key (direction :input))
+ (in-system-configuration-directory *source-registry-file* :direction direction))
+(defun* user-source-registry-directory (&key (direction :input))
+ (in-user-configuration-directory *source-registry-directory* :direction direction))
+(defun* system-source-registry-directory (&key (direction :input))
+ (in-system-configuration-directory *source-registry-directory* :direction direction))
(defun* environment-source-registry ()
(getenv "CL_SOURCE_REGISTRY"))
,parameter
,@*default-source-registries*)
:register #'(lambda (directory &key recurse exclude)
- (collect (list directory :recurse recurse :exclude exclude)))))
- :test 'equal :from-end t)))
+ (collect (list directory :recurse recurse :exclude exclude))))))
+ :test 'equal :from-end t))
-;; Will read the configuration and initialize all internal variables,
-;; and return the new configuration.
+;; Will read the configuration and initialize all internal variables.
(defun* compute-source-registry (&optional parameter (registry *source-registry*))
(dolist (entry (flatten-source-registry parameter))
(destructuring-bind (directory &key recurse exclude) entry
- (let* ((h (make-hash-table :test 'equal)))
+ (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
(register-asd-directory
directory :recurse recurse :exclude exclude :collect
#'(lambda (asd)
- (let ((name (pathname-name asd)))
+ (let* ((name (pathname-name asd))
+ (name (if (typep asd 'logical-pathname)
+ ;; logical pathnames are upper-case,
+ ;; at least in the CLHS and on SBCL,
+ ;; yet (coerce-name :foo) is lower-case.
+ ;; won't work well with (load-system "Foo")
+ ;; instead of (load-system 'foo)
+ (string-downcase name)
+ name)))
(cond
((gethash name registry) ; already shadowed by something else
nil)
(clear-output-translations))
-;;; ECL support for COMPILE-OP / LOAD-OP
+;;; ECL and MKCL support for COMPILE-OP / LOAD-OP
;;;
-;;; In ECL, these operations produce both FASL files and the
-;;; object files that they are built from. Having both of them allows
-;;; us to later on reuse the object files for bundles, libraries,
-;;; standalone executables, etc.
+;;; In ECL and MKCL, these operations produce both
+;;; FASL files and the object files that they are built from.
+;;; Having both of them allows us to later on reuse the object files
+;;; for bundles, libraries, standalone executables, etc.
;;;
;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
;;;
-#+ecl
-(progn
- (setf *compile-op-compile-file-function*
- (lambda (input-file &rest keys &key output-file &allow-other-keys)
- (declare (ignore output-file))
- (multiple-value-bind (object-file flags1 flags2)
- (apply 'compile-file* input-file :system-p t keys)
- (values (and object-file
- (c::build-fasl (compile-file-pathname object-file :type :fasl)
- :lisp-files (list object-file))
- object-file)
- flags1
- flags2))))
-
- (defmethod output-files ((operation compile-op) (c cl-source-file))
- (declare (ignorable operation))
- (let ((p (lispize-pathname (component-pathname c))))
- (list (compile-file-pathname p :type :object)
- (compile-file-pathname p :type :fasl))))
-
- (defmethod perform ((o load-op) (c cl-source-file))
- (map () #'load
- (loop :for i :in (input-files o c)
- :unless (string= (pathname-type i) "fas")
- :collect (compile-file-pathname (lispize-pathname i))))))
+;;; Also, register-pre-built-system.
-;;;; -----------------------------------------------------------------
-;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
+#+(or ecl mkcl)
+(progn
+ (defun register-pre-built-system (name)
+ (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))
+
+ #+(or (and ecl win32) (and mkcl windows))
+ (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
+ (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
+
+ (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
+ (loop :for f :in #+ecl ext:*module-provider-functions*
+ #+mkcl mk-ext::*module-provider-functions*
+ :unless (eq f 'module-provide-asdf)
+ :collect #'(lambda (name)
+ (let ((l (multiple-value-list (funcall f name))))
+ (and (first l) (register-pre-built-system (coerce-name name)))
+ (values-list l)))))
+
+ (setf *compile-op-compile-file-function* 'compile-file-keeping-object)
+
+ (defun compile-file-keeping-object (input-file &rest keys &key &allow-other-keys)
+ (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys)
+ #+mkcl progn
+ (multiple-value-bind (object-file flags1 flags2)
+ (apply 'compile-file* input-file
+ #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil keys)
+ (values (and object-file
+ (compiler::build-fasl
+ (compile-file-pathname object-file
+ #+ecl :type #+ecl :fasl #+mkcl :fasl-p #+mkcl t)
+ #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file))
+ object-file)
+ flags1
+ flags2)))))
+
+;;;; -----------------------------------------------------------------------
+;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
;;;;
-(defvar *require-asdf-operator* 'load-op)
-
(defun* module-provide-asdf (name)
(handler-bind
((style-warning #'muffle-warning)
+ #-genera
(missing-component (constantly nil))
(error #'(lambda (e)
(format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
(let ((*verbose-out* (make-broadcast-stream))
(system (find-system (string-downcase name) nil)))
(when system
- (operate *require-asdf-operator* system :verbose nil)
+ (require-system system :verbose nil)
t))))
-#+(or abcl clisp clozure cmu ecl sbcl)
+#+(or abcl clisp clozure cmu ecl mkcl sbcl)
(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
(when x
(eval `(pushnew 'module-provide-asdf
#+abcl sys::*module-provider-functions*
#+clisp ,x
#+clozure ccl:*module-provider-functions*
- #+cmu ext:*module-provider-functions*
- #+ecl si:*module-provider-functions*
+ #+(or cmu ecl) ext:*module-provider-functions*
+ #+mkcl mk-ext:*module-provider-functions*
#+sbcl sb-ext:*module-provider-functions*))))
(when *load-verbose*
(asdf-message ";; ASDF, version ~a~%" (asdf-version)))
+#+mkcl
+(progn
+ (defvar *loading-asdf-bundle* nil)
+ (unless *loading-asdf-bundle*
+ (let ((*central-registry*
+ (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*))
+ (*loading-asdf-bundle* t))
+ (clear-system :asdf-bundle) ;; we hope to force a reload.
+ (multiple-value-bind (result bundling-error)
+ (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle))
+ (unless result
+ (format *error-output*
+ "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%"
+ bundling-error))))))
+
#+allegro
(eval-when (:compile-toplevel :execute)
(when (boundp 'excl:*warn-on-nested-reader-conditionals*)