-;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.017: Another System Definition Facility.
+;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
+;;; This is ASDF 2.019: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; Implementation-dependent tweaks
- ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults.
+ ;; (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)
+ #+ecl (unless (member :ecl-bytecmp *features*) (require :cmp))
#+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*))
- #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*)
- #+(or unix cygwin) (pushnew :asdf-unix *features*)
;;; make package if it doesn't exist yet.
;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
(unless (find-package :asdf)
(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)
#-(or gcl genera) format
#+(or gcl genera)
(loop :for (unsupported . replacement) :in
- `(("~3i~_" . "")
- #+genera
- ,@(("~@<" . "")
- ("; ~@;" . "; ")
- ("~@:>" . "")
- ("~:>" . ""))) :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.017")
+ (asdf-version "2.019")
(existing-asdf (find-class 'component nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
(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
:do (unintern old user)))
(loop :for x :in newly-exported-symbols :do
(export (intern* x package)))))
- (ensure-package (name &key nicknames use unintern fmakunbound
+ (ensure-package (name &key nicknames use unintern
shadow export redefined-functions)
(let* ((p (ensure-exists name nicknames use)))
(ensure-unintern p unintern)
(ensure-shadow p shadow)
(ensure-export p export)
- (ensure-fmakunbound p (append fmakunbound redefined-functions))
+ (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 ',unintern
- :redefined-functions ',redefined-functions
- :fmakunbound ',fmakunbound)))
+ :redefined-functions ',redefined-functions)))
(pkgdcl
:asdf
:nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
#: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
+ (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command
#:system-definition-pathname #:with-system-definitions
- #: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
+ #:search-for-system-definition #:find-component #:component-find-path
+ #:compile-system #:load-system #:load-systems #: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
+ #:input-files #:output-files #:output-file #:perform
#:operation-done-p #:explain
#:component #:source-file
#:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
#:*resolve-symlinks*
+ #:*require-asdf-operator*
#:*asdf-verbose*
+ #:*verbose-out*
#:asdf-version
#:process-source-registry
#:system-registered-p
#:asdf-message
+ #:user-output-translations-pathname
+ #:system-output-translations-pathname
+ #:user-output-translations-directory-pathname
+ #:system-output-translations-directory-pathname
+ #:user-source-registry
+ #:system-source-registry
+ #:user-source-registry-directory
+ #:system-source-registry-directory
;; Utilities
#:absolute-pathname-p
;; #:aif #:it
- ;; #:appendf
+ ;; #:appendf #:orf
#:coerce-name
#:directory-pathname-p
;; #:ends-with
#:getenv
;; #:length=n-p
;; #:find-symbol*
- #:merge-pathnames*
- #:coerce-pathname
+ #:merge-pathnames* #:coerce-pathname #:subpathname
#:pathname-directory-pathname
#:read-file-forms
;; #:remove-keys
condition-arguments condition-form
condition-format condition-location
coerce-name)
+ (ftype (function (&optional t) (values)) initialize-source-registry)
#-(or cormanlisp gcl-pre2.7)
(ftype (function (t t) t) (setf module-components-by-name)))
#+cormanlisp
(progn
(deftype logical-pathname () nil)
- (defun* make-broadcast-stream () *error-output*)
- (defun* file-namestring (p)
+ (defun make-broadcast-stream () *error-output*)
+ (defun file-namestring (p)
(setf p (pathname p))
(format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
:do (pop reldir) (pop defrev)
:finally (return (cons defabs (append (reverse defrev) reldir)))))))))))
+(defun* ununspecific (x)
+ (if (eq x :unspecific) nil x))
+
(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,
(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)
+ (labels ((unspecific-handler (p)
(if (typep p 'logical-pathname) #'ununspecific #'identity)))
(multiple-value-bind (host device directory unspecific-handler)
(ecase (first directory)
(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)
(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)))))
+ (if (or (ununspecific port)
+ (and (ununspecific host) (plusp (length host)))
+ (ununspecific scheme))
+ (let ((prefix ""))
+ (when (ununspecific port)
+ (setf prefix (format nil ":~D" port)))
+ (when (and (ununspecific host) (plusp (length host)))
+ (setf prefix (strcat host prefix)))
+ (setf prefix (strcat ":" prefix))
+ (when (ununspecific 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))
;; 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)
;; XXX we should provide some atomic interface for updating the
;; component properties
(properties :accessor component-properties :initarg :properties
(acons property new-value (slot-value c 'properties)))))
new-value)
-(defclass system (module)
+(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)))
(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
;;; 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))
- (cons 'find-system-if-being-defined *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)
:version :newest :case :local :type "asd")))
(when (probe-file* 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~@:>"))))
(let ((*systems-being-defined* (make-hash-table :test 'equal)))
(funcall thunk))))
-(defmacro with-system-definitions (() &body body)
+(defmacro with-system-definitions ((&optional) &body body)
`(call-with-system-definitions #'(lambda () ,@body)))
(defun* load-sysdef (name pathname)
(error 'load-system-definition-error
:name name :pathname pathname
:condition condition))))
- (let ((*package* package))
+ (let ((*package* package)
+ (*default-pathname-defaults*
+ (pathname-directory-pathname pathname)))
(asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%")
pathname package)
(load pathname)))
(delete-package package)))))
-(defmethod find-system ((name string) &optional (error-p t))
- (with-system-definitions ()
- (let* ((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))
+(defun* locate-system (name)
+ "Given a system NAME designator, try to locate where to load the system from.
+Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
+FOUNDP is true when a new 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, 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 (search-for-system-definition name))
- (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)))))
+ (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))))
+ (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))
(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)))))))
+ (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 "~@<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)
:type (source-file-type component (component-system component))
:defaults (component-parent-pathname component)))
+(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)))
+
;;;; -------------------------------------------------------------------------
;;;; Operations
(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 "~@<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
(handler-case
(update-flag
(do-traverse operation kid #'internal-collect))
+ #-genera
(missing-dependency (condition)
(when (eq (module-if-component-dep-fails c)
:fail)
(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)))
(assert (length=n-p files 1))
(first files)))
-(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)
+(defun* ensure-all-directories-exist (pathnames)
+ (loop :for pn :in pathnames
+ :for pathname = (if (typep pn 'logical-pathname)
+ (translate-logical-pathname pn)
+ pn)
:do (ensure-directories-exist pathname)))
+(defmethod perform :before ((operation compile-op) (c source-file))
+ (ensure-all-directories-exist (asdf: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))
+
+(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))))
(defvar *compile-op-compile-file-function* 'compile-file*
"Function used to compile lisp files.")
(*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))
+ (call-with-around-compile-hook
+ c #'(lambda ()
+ (apply *compile-op-compile-file-function* source-file
+ :output-file output-file (compile-op-flags operation))))
(unless output
(error 'compile-error :component c :operation operation))
(when failure-p
(defclass load-op (basic-load-op) ())
+(defmethod perform-with-restarts ((o load-op) (c cl-source-file))
+ (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 (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))))))
-
(defmethod perform ((operation load-op) (c static-file))
(declare (ignorable operation c))
nil)
(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)))
(get-universal-time)))))
(defmethod perform ((operation load-source-op) (c static-file))
(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: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)))
(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 (funcall (find-symbol* 'find-system :asdf) :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
"))
(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))
(apply 'operate 'load-op system args)
t)
+(defun* load-systems (&rest systems)
+ (map () 'load-system systems))
+
(defun* compile-system (system &rest args &key force verbose version
&allow-other-keys)
"Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE
(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))))
(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
(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 default-component-class
+ 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)))
(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)
(%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 nil pathname-arg-p) (class 'system)
+ &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
(with-system-definitions ()
(let* ((name (coerce-name name))
(registered (system-registered-p name))
- (system (cdr (or registered
- (register-system (make-instance 'system :name 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)))
- (%set-system-source-file (load-pathname) system)
(setf (gethash name *systems-being-defined*) system)
- (when registered
- (setf (car registered) (get-universal-time)))
- (map () 'load-system defsystem-depends-on)
+ (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)))
(parse-component-form
nil (list*
:module name
- :pathname (determine-system-pathname pathname pathname-arg-p)
+ :pathname (determine-system-pathname pathname)
component-options)))))
(defmacro defsystem (name &body options)
;;;; 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/process-output-stream and its
+;;;; derivatives such as xcvb-driver:run-program/for-side-effects.
(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)
+ (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))
#-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl 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))
+ (%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
: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))
;;; ---------------------------------------------------------------------------
;;;
;;; produce a string to identify current implementation.
;;; Initially stolen from SLIME's SWANK, rewritten since.
-;;; The (car '(...)) idiom avoids unreachable code warnings.
-
-(defparameter *implementation-type*
- (car '(#+abcl :abcl #+allegro :acl
- #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu
- #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl
- #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl)))
-
-(defparameter *operating-system*
- (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win
- #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd.
- #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd
- #+(or solaris sunos) :solaris
- #+(or freebsd netbsd openbsd bsd) :bsd
- #+unix :unix
- #+genera :genera)))
-
-(defparameter *architecture*
- (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64
- #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86
- #+hppa64 :hppa64 #+hppa :hppa
- #+(or ppc64 ppc64-target) :ppc64
- #+(or ppc32 ppc32-target ppc powerpc) :ppc32
- #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32
- #+(or arm arm-target) :arm
- #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java
- #+mipsel :mispel #+mipseb :mipseb #+mips :mips
- #+alpha :alpha #+imach :imach)))
-
-(defparameter *lisp-version-string*
+;;; We're back to runtime checking, for the sake of e.g. ABCL.
+
+(defun* first-feature (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 :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))))
+
+(defun lisp-version-string ()
(let ((s (lisp-implementation-version)))
- (or
- #+allegro
- (format nil "~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")))
- #+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)))
- (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-type ()
- *implementation-type*)
+ (car ; as opposed to OR, this idiom prevents some unreachable code warning
+ (list
+ #+allegro
+ (format nil "~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")))
+ #+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 ()
(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)))))
+ (or (implementation-type) (lisp-implementation-type))
+ (or (lisp-version-string) (lisp-implementation-version))
+ (or (operating-system) (software-type))
+ (or (architecture) (machine-type)))))
;;; ---------------------------------------------------------------------------
;;; 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
#+mcl (current-user-homedir-pathname)
#-mcl (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))))
(defun* user-configuration-directories ()
(let ((dirs
- (flet ((try (x sub) (try-directory-subpath x sub)))
- `(,(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
- ,@`(,(try (or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv "LOCALAPPDATA"))
- "common-lisp/config/")
+ `(,@(when (os-unix-p)
+ (cons
+ (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/")
+ (loop :with dirs = (getenv "XDG_CONFIG_DIRS")
+ :for dir :in (split-string dirs :separator ":")
+ :collect (subpathname* dir "common-lisp/"))))
+ ,@(when (os-windows-p)
+ `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
+ (getenv "LOCALAPPDATA"))
+ "common-lisp/config/")
;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
- ,(try (or #+lispworks (sys:get-folder-path :appdata)
- (getenv "APPDATA"))
- "common-lisp/config/"))
- ,(try (user-homedir) ".config/common-lisp/")))))
- (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal)))
+ ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
+ (getenv "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
- `(#+asdf-windows
- ,(flet ((try (x sub) (try-directory-subpath x sub)))
- ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
- (try (or #+lispworks (sys:get-folder-path :common-appdata)
- (getenv "ALLUSERSAPPDATA")
- (try (getenv "ALLUSERSPROFILE") "Application Data/"))
- "common-lisp/config/"))
- #+asdf-unix #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* (or #+lispworks (sys:get-folder-path :common-appdata)
+ (getenv "ALLUSERSAPPDATA")
+ (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))
+ "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)))
(flet ((try (x &rest sub) (and x `(,x ,@sub))))
(or
(try (getenv "XDG_CACHE_HOME") "common-lisp" :implementation)
- #+asdf-windows
- (try (or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv "LOCALAPPDATA")
- #+lispworks (sys:get-folder-path :appdata)
- (getenv "APPDATA"))
- "common-lisp" "cache" :implementation)
+ (when (os-windows-p)
+ (try (or #+lispworks (sys:get-folder-path :local-appdata)
+ (getenv "LOCALAPPDATA")
+ #+lispworks (sys:get-folder-path :appdata)
+ (getenv "APPDATA"))
+ "common-lisp" "cache" :implementation))
'(:home ".cache" "common-lisp" :implementation))))
(defun* output-translations ()
(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))))))
: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
(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"))
(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
(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)
(&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))
(source-to-target-mappings nil))
: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
(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
(and u (equal (ignore-errors (truename u)) f) u)))
:when p :collect p)
entries))
(filter-logical-directory-results
directory entries
#'(lambda (f)
- (make-pathname :defaults directory :version (pathname-version f)
- :name (pathname-name f) :type (pathname-type f))))))
+ (make-pathname :defaults directory
+ :name (pathname-name f) :type (ununspecific (pathname-type f))
+ :version (ununspecific (pathname-version f)))))))
(defun* directory-asd-files (directory)
(directory-files directory *wild-asd*))
(let* ((directory (ensure-directory-pathname directory))
#-(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 abcl cormanlisp genera xcl)
#+(or abcl xcl) (system:list-directory directory)
#+cormanlisp (cl::directory-subdirs directory)
#+genera (fs:directory-list directory))
- #+(or abcl allegro cmu genera lispworks scl xcl)
+ #+(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)))
+ #+(or cmu lispworks sbcl scl) x)))
(filter-logical-directory-results
directory dirs
(let ((prefix (normalize-pathname-directory-component
: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))))
(flet ((check (dir)
(unless (absolute-pathname-p dir)
`(:source-registry
#+sbcl (:tree ,(truenamize (getenv "SBCL_HOME")))
: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)))
- `(:source-registry
- #+sbcl (:directory ,(try (user-homedir) ".sbcl/systems/"))
- (:directory ,(default-directory))
+ `(:source-registry
+ #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
+ (:directory ,(default-directory))
,@(loop :for dir :in
- `(#+asdf-unix
- ,@`(,(or (getenv "XDG_DATA_HOME")
- (try (user-homedir) ".local/share/"))
- ,@(split-string (or (getenv "XDG_DATA_DIRS")
- "/usr/local/share:/usr/share")
- :separator ":"))
- #+asdf-windows
- ,@`(,(or #+lispworks (sys:get-folder-path :local-appdata)
- (getenv "LOCALAPPDATA"))
- ,(or #+lispworks (sys:get-folder-path :appdata)
- (getenv "APPDATA"))
- ,(or #+lispworks (sys:get-folder-path :common-appdata)
- (getenv "ALLUSERSAPPDATA")
- (try (getenv "ALLUSERSPROFILE") "Application Data/"))))
- :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*))
+ `(,@(when (os-unix-p)
+ `(,(or (getenv "XDG_DATA_HOME")
+ (subpathname (user-homedir) ".local/share/"))
+ ,@(split-string (or (getenv "XDG_DATA_DIRS")
+ "/usr/local/share:/usr/share")
+ :separator ":")))
+ ,@(when (os-windows-p)
+ `(,(or #+lispworks (sys:get-folder-path :local-appdata)
+ (getenv "LOCALAPPDATA"))
+ ,(or #+lispworks (sys:get-folder-path :appdata)
+ (getenv "APPDATA"))
+ ,(or #+lispworks (sys:get-folder-path :common-appdata)
+ (getenv "ALLUSERSAPPDATA")
+ (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")))))
+ :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"))
(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
;;;
#+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))))
+ (setf *compile-op-compile-file-function* 'ecl-compile-file)
+
+ (defun use-ecl-byte-compiler-p ()
+ (member :ecl-bytecmp *features*))
+
+ (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
+ (if (use-ecl-byte-compiler-p)
+ (apply 'compile-file* input-file keys)
+ (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))))
+ (let* ((p (lispize-pathname (component-pathname c)))
+ (f (compile-file-pathname p :type :fasl)))
+ (if (use-ecl-byte-compiler-p)
+ (list f)
+ (list (compile-file-pathname p :type :object) f))))
(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))))))
+ :collect (compile-file-pathname (lispize-pathname i))))))
;;;; -----------------------------------------------------------------
;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
(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.~@:>~%")
#+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*
#+sbcl sb-ext:*module-provider-functions*))))
projects / sbcl.git / commitdiff