-;;; This is asdf: Another System Definition Facility.
+;;; This is asdf: Another System Definition Facility.
;;; hash - $Format:%H$
;;;
;;; Local Variables:
;;; RELEASE may be slightly older but is considered `stable'
;;; -- LICENSE START
-;;; (This is the MIT / X Consortium license as taken from
+;;; (This is the MIT / X Consortium license as taken from
;;; http://www.opensource.org/licenses/mit-license.html on or about
;;; Monday; July 13, 2009)
;;;
-;;; Copyright (c) 2001-2009 Daniel Barlow and contributors
+;;; Copyright (c) 2001-2010 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
(:documentation "Another System Definition Facility")
(:export #:defsystem #:oos #:operate #:find-system #:run-shell-command
#:system-definition-pathname #:find-component ; miscellaneous
- #:compile-system #:load-system #:test-system
+ #:compile-system #:load-system #:test-system
#:compile-op #:load-op #:load-source-op
#:test-op
- #:operation ; operations
- #:feature ; sort-of operation
- #:version ; metaphorically sort-of an operation
+ #:operation ; operations
+ #:feature ; sort-of operation
+ #:version ; metaphorically sort-of an operation
#:input-files #:output-files #:perform ; operation methods
#:operation-done-p #:explain
#:system-licence
#:system-source-file
#:system-relative-pathname
- #:map-systems
+ #:map-systems
#:operation-on-warnings
#:operation-on-failure
- ;#:*component-parent-pathname*
+ ;#:*component-parent-pathname*
#:*system-definition-search-functions*
#:*central-registry* ; variables
#:*compile-file-warnings-behaviour*
#:*compile-file-failure-behaviour*
- #:*asdf-revision*
- #:*resolve-symlinks*
+ #:*resolve-symlinks*
+
+ #:asdf-version
#:operation-error #:compile-failed #:compile-warned #:compile-error
+ #:error-name
+ #:error-pathname
+ #:missing-definition
#:error-component #:error-operation
#:system-definition-error
#:missing-component
- #:missing-component-of-version
+ #:missing-component-of-version
#:missing-dependency
#:missing-dependency-of-version
#:circular-dependency ; errors
#:duplicate-names
- #:try-recompiling
+ #:try-recompiling
#:retry
#:accept ; restarts
- #:coerce-entry-to-directory
- #:remove-entry-from-registry
+ #:coerce-entry-to-directory
+ #:remove-entry-from-registry
#:standard-asdf-method-combination
#:around ; protocol assistants
-
- #:*source-to-target-mappings*
- #:*default-toplevel-directory*
- #:*centralize-lisp-binaries*
- #:*include-per-user-information*
- #:*map-all-source-files*
- #:output-files-for-system-and-operation
- #:*enable-asdf-binary-locations*
- #:implementation-specific-directory-name)
+
+ #:*source-to-target-mappings*
+ #:*default-toplevel-directory*
+ #:*centralize-lisp-binaries*
+ #:*include-per-user-information*
+ #:*map-all-source-files*
+ #:output-files-for-system-and-operation
+ #:*enable-asdf-binary-locations*
+ #:implementation-specific-directory-name
+
+ #:initialize-source-registry
+ #:clear-source-registry
+ #:ensure-source-registry
+ #:process-source-registry)
(:intern #:coerce-name
- #:system-registered-p
- #:asdf-message
- #:resolve-symlinks
- #:pathname-sans-name+type)
+ #:getenv
+ #:system-registered-p
+ #:asdf-message
+ #:resolve-symlinks
+ #:pathname-sans-name+type)
(:use :cl))
(defpackage #:asdf-extensions
(:use #:common-lisp #:asdf)
(:import-from #:asdf
- #:coerce-name
- #:system-registered-p
- #:asdf-message
- #:resolve-symlinks
- #:pathname-sans-name+type))
+ #:coerce-name
+ #:getenv
+ #:system-registered-p
+ #:asdf-message
+ #:resolve-symlinks
+ #:pathname-sans-name+type))
#+nil
(error "The author of this file habitually uses #+nil to comment out ~
(in-package #:asdf)
-(defvar *asdf-revision*
+;;;; -------------------------------------------------------------------------
+;;;; User-visible parameters
+;;;;
+(defparameter *asdf-version*
;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
- (subseq "REVISION:1.369" (1+ (length "REVISION"))))
-
+ (subseq "VERSION:1.502" (1+ (length "VERSION"))))
+
+(defun asdf-version ()
+ *asdf-version*)
(defvar *resolve-symlinks* t
"Determine whether or not ASDF resolves symlinks when defining systems.
(defparameter +asdf-methods+
'(perform explain output-files operation-done-p))
+;;;; -------------------------------------------------------------------------
+;;;; Cleanups before hot-upgrade.
+;;;; Things to do in case we're upgrading from a previous version of ASDF.
+;;;; See https://bugs.launchpad.net/asdf/+bug/485687
+;;;; * fmakunbound functions that once (in previous version of ASDF)
+;;;; were simple DEFUNs but now are generic functions.
+;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
+;;;; for each of the classes we define that has changed incompatibly.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (fmakunbound 'system-source-file)
+ #+ecl
+ (when (find-class 'compile-op nil)
+ (defmethod update-instance-for-redefined-class :after
+ ((c compile-op) added deleted plist &key)
+ (format *trace-output* "~&UI4RC:a ~S~%" (list c added deleted plist))
+ (let ((system-p (getf plist 'system-p)))
+ (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))))
+
+;;;; -------------------------------------------------------------------------
+;;;; CLOS magic for asdf:around methods
+
(define-method-combination standard-asdf-method-combination ()
((around-asdf (around))
(around (:around))
(,@(rest around-asdf) (make-method ,standard-form)))
standard-form))))
-(setf (documentation 'standard-asdf-method-combination
- 'method-combination)
+(setf (documentation 'standard-asdf-method-combination
+ 'method-combination)
"This method combination is based on the standard method combination,
but defines a new method-qualifier, `asdf:around`. `asdf:around`
methods will be run *around* any `:around` methods, so that the core
protocol may employ around methods and those around methods will not
be overridden by around methods added by a system developer.")
+;;;; -------------------------------------------------------------------------
+;;;; ASDF Interface, in terms of generic functions.
+
(defgeneric perform (operation component)
(:method-combination standard-asdf-method-combination))
(defgeneric operation-done-p (operation component)
(defgeneric component-self-dependencies (operation component))
(defgeneric traverse (operation component)
- (:documentation
+ (:documentation
"Generate and return a plan for performing `operation` on `component`.
The plan returned is a list of dotted-pairs. Each pair is the `cons`
-of ASDF operation object and a `component` object. The pairs will be
+of ASDF operation object and a `component` object. The pairs will be
processed in order by `operate`."))
(defgeneric output-files-using-mappings (source possible-paths path-mappings)
- (:documentation
+ (:documentation
"Use the variable \\*source-to-target-mappings\\* to find
an output path for the source. The algorithm transforms each
entry in possible-paths as follows: If there is a mapping
structure will mirror that of the source."))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; utility stuff
+;;;; -------------------------------------------------------------------------
+;;;; General Purpose Utilities
(defmacro aif (test then &optional else)
`(let ((it ,test)) (if it ,then ,else)))
(declare (dynamic-extent format-args))
(apply #'format *verbose-out* format-string format-args))
+;;; with apologies to christophe rhodes ...
+(defun split (string &optional max (ws '(#\Space #\Tab)))
+ (flet ((is-ws (char) (find char ws)))
+ (nreverse
+ (let ((list nil) (start 0) (words 0) end)
+ (loop
+ (when (and max (>= words (1- max)))
+ (return (cons (subseq string start) list)))
+ (setf end (position-if #'is-ws string :start start))
+ (push (subseq string start end) list)
+ (incf words)
+ (unless end (return list))
+ (setf start (1+ end)))))))
+
(defun split-path-string (s &optional force-directory)
(check-type s string)
(let* ((components (split s nil "/"))
(t
(values relative (butlast components) last-comp))))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; classes, condiitons
+(defun remove-keys (key-names args)
+ (loop :for (name val) :on args :by #'cddr
+ :unless (member (symbol-name name) key-names
+ :key #'symbol-name :test 'equal)
+ :append (list name val)))
+
+(defun remove-keyword (key args)
+ (loop :for (k v) :on args :by #'cddr
+ :unless (eq k key)
+ :append (list k v)))
+
+(defun resolve-symlinks (path)
+ #-allegro (truename path)
+ #+allegro (excl:pathname-resolve-symbolic-links path))
+
+(defun getenv (x)
+ #+sbcl
+ (sb-ext:posix-getenv x)
+ #+clozure
+ (ccl::getenv x)
+ #+clisp
+ (ext:getenv x)
+ #+cmu
+ (cdr (assoc (intern x :keyword) ext:*environment-list*))
+ #+lispworks
+ (lispworks:environment-xiable x)
+ #+allegro
+ (sys:getenv x)
+ #+gcl
+ (system:getenv x)
+ #+ecl
+ (si:getenv x))
+
+(defun ensure-directory-pathname (pathspec)
+ "Converts the non-wild pathname designator PATHSPEC to directory form."
+ (cond
+ ((stringp pathspec)
+ (pathname (concatenate 'string pathspec "/")))
+ ((not (pathnamep pathspec))
+ (error "Invalid pathname designator ~S" pathspec))
+ ((wild-pathname-p pathspec)
+ (error "Can't reliably convert wild pathnames."))
+ ((directory-pathname-p pathspec)
+ pathspec)
+ (t
+ (make-pathname :directory (append (or (pathname-directory pathspec)
+ (list :relative))
+ (list (file-namestring pathspec)))
+ :name nil :type nil :version nil
+ :defaults pathspec))))
+
+(defun length=n-p (x n) ;is it that (= (length x) n) ?
+ (check-type n (integer 0 *))
+ (loop
+ :for l = x :then (cdr l)
+ :for i :downfrom n :do
+ (cond
+ ((zerop i) (return (null l)))
+ ((not (consp l)) (return nil)))))
+
+(defun ends-with (s suffix)
+ (check-type s string)
+ (check-type suffix string)
+ (let ((start (- (length s) (length suffix))))
+ (and (<= 0 start)
+ (string-equal s suffix :start1 start))))
+
+;;;; -------------------------------------------------------------------------
+;;;; Classes, Conditions
(define-condition system-definition-error (error) ()
;; [this use of :report should be redundant, but unfortunately it's not.
(:report (lambda (c s)
(apply #'format s (format-control c) (format-arguments c)))))
+(define-condition missing-definition (system-definition-error)
+ ((name :initarg :name :reader error-name)
+ (pathname :initarg :pathname :reader error-pathname))
+ (:report (lambda (c s)
+ (format s "~@<Definition search function returned a wrong pathname ~A ~
+ in search of a definition for system ~A.~@:>"
+ (error-pathname c) (error-name c)))))
+
(define-condition circular-dependency (system-definition-error)
((components :initarg :components :reader circular-dependency-components)))
((required-by :initarg :required-by :reader missing-required-by)))
(define-condition missing-dependency-of-version (missing-dependency
- missing-component-of-version)
+ missing-component-of-version)
())
(define-condition operation-error (error)
((name :accessor component-name :initarg :name :documentation
"Component name: designator for a string composed of portable pathname characters")
(version :accessor component-version :initarg :version)
- (in-order-to :initform nil :initarg :in-order-to)
+ (in-order-to :initform nil :initarg :in-order-to
+ :accessor component-in-order-to)
;; XXX crap name
- (do-first :initform nil :initarg :do-first)
+ (do-first :initform nil :initarg :do-first
+ :accessor component-do-first)
;; methods defined using the "inline" style inside a defsystem form:
;; need to store them somewhere so we can delete them when the system
;; is re-evaluated
;; 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)
- (operation-times :initform (make-hash-table )
+ (operation-times :initform (make-hash-table)
:accessor component-operation-times)
;; XXX we should provide some atomic interface for updating the
;; component properties
(call-next-method c nil) (missing-required-by c)))
(defun sysdef-error (format &rest arguments)
- (error 'formatted-system-definition-error :format-control
- format :format-arguments arguments))
+ (error 'formatted-system-definition-error :format-control
+ format :format-arguments arguments))
;;;; methods: components
~@[ in ~A~]~@:>"
(missing-requires c)
(missing-version c)
- (when (missing-parent c)
- (component-name (missing-parent c)))))
+ (when (missing-parent c)
+ (component-name (missing-parent c)))))
(defmethod component-system ((component component))
(aif (component-parent component)
(defmethod component-relative-pathname ((component module))
(or (slot-value component 'relative-pathname)
(multiple-value-bind (relative path)
- (split-path-string (component-name component) t)
+ (split-path-string (component-name component) t)
(make-pathname
:directory `(,relative ,@path)
:host (pathname-host (component-parent-pathname component))))))
(licence :accessor system-licence :initarg :licence
:accessor system-license :initarg :license)
(source-file :reader system-source-file :initarg :source-file
- :writer %set-system-source-file)))
-
-;;; version-satisfies
+ :writer %set-system-source-file)))
-;;; with apologies to christophe rhodes ...
-(defun split (string &optional max (ws '(#\Space #\Tab)))
- (flet ((is-ws (char) (find char ws)))
- (nreverse
- (let ((list nil) (start 0) (words 0) end)
- (loop
- (when (and max (>= words (1- max)))
- (return (cons (subseq string start) list)))
- (setf end (position-if #'is-ws string :start start))
- (push (subseq string start end) list)
- (incf words)
- (unless end (return list))
- (setf start (1+ end)))))))
+;;;; -------------------------------------------------------------------------
+;;;; version-satisfies
(defmethod version-satisfies ((c component) version)
(unless (and version (slot-boundp c 'version))
(and (= (car x) (car y))
(or (not (cdr y)) (bigger (cdr x) (cdr y)))))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; finding systems
+;;;; -------------------------------------------------------------------------
+;;;; Finding systems
(defun make-defined-systems-table ()
(make-hash-table :test 'equal))
-(defvar *defined-systems* (make-defined-systems-table))
+(defvar *defined-systems* (make-defined-systems-table)
+ "This is a hash table whose keys are strings, being the
+names of the systems, and whose values are pairs, the first
+element of which is a universal-time indicating when the
+system definition was last updated, and the second element
+of which is a system object.")
(defun coerce-name (name)
(typecase name
`fn` should be a function of one argument. It will be
called with an object of type asdf:system."
(maphash (lambda (_ datum)
- (declare (ignore _))
- (destructuring-bind (_ . def) datum
- (declare (ignore _))
- (funcall fn def)))
- *defined-systems*))
+ (declare (ignore _))
+ (destructuring-bind (_ . def) datum
+ (declare (ignore _))
+ (funcall fn def)))
+ *defined-systems*))
;;; for the sake of keeping things reasonably neat, we adopt a
;;; convention that functions in this list are prefixed SYSDEF-
(let ((system-name (coerce-name system)))
(or
(some (lambda (x) (funcall x system-name))
- *system-definition-search-functions*)
+ *system-definition-search-functions*)
(let ((system-pair (system-registered-p system-name)))
(and system-pair
- (system-source-file (cdr system-pair)))))))
+ (system-source-file (cdr system-pair)))))))
(defvar *central-registry*
`((directory-namestring *default-pathname-defaults*))
"A list of 'system directory designators' ASDF uses to find systems.
-A 'system directory designator' is a pathname or a function
+A 'system directory designator' is a pathname or a function
which evaluates to a pathname. For example:
(setf asdf:*central-registry*
"Does `pathname` represent a directory?
A directory-pathname is a pathname _without_ a filename. The three
-ways that the filename components can be missing are for it to be `nil`,
+ways that the filename components can be missing are for it to be `nil`,
`:unspecific` or the empty string.
Note that this does _not_ check to see that `pathname` points to an
actually-existing directory."
(flet ((check-one (x)
- (not (null (member x '(nil :unspecific "")
- :test 'equal)))))
+ (not (null (member x '(nil :unspecific "")
+ :test 'equal)))))
(and (check-one (pathname-name pathname))
- (check-one (pathname-type pathname)))))
-
-#+(or)
-;;test
-;;?? move into testsuite sometime soon
-(every (lambda (p)
- (directory-pathname-p p))
- (list
- (make-pathname :name "." :type nil :directory '(:absolute "tmp"))
- (make-pathname :name "." :type "" :directory '(:absolute "tmp"))
- (make-pathname :name nil :type "" :directory '(:absolute "tmp"))
- (make-pathname :name "" :directory '(:absolute "tmp"))
- (make-pathname :type :unspecific :directory '(:absolute "tmp"))
- (make-pathname :name :unspecific :directory '(:absolute "tmp"))
- (make-pathname :name :unspecific :directory '(:absolute "tmp"))
- (make-pathname :type "" :directory '(:absolute "tmp"))
- ))
-
-(defun ensure-directory-pathname (pathname)
- (if (directory-pathname-p pathname)
- pathname
- (make-pathname :defaults pathname
- :directory (append
- (pathname-directory pathname)
- (list (file-namestring pathname)))
- :name nil :type nil :version nil)))
+ (check-one (pathname-type pathname)))))
(defun sysdef-central-registry-search (system)
(let ((name (coerce-name system))
- (to-remove nil)
- (to-replace nil))
+ (to-remove nil)
+ (to-replace nil))
(block nil
(unwind-protect
- (dolist (dir *central-registry*)
- (let ((defaults (eval dir)))
- (when defaults
- (cond ((directory-pathname-p defaults)
- (let ((file (and defaults
- (make-pathname
- :defaults defaults :version :newest
- :name name :type "asd" :case :local)))
+ (dolist (dir *central-registry*)
+ (let ((defaults (eval dir)))
+ (when defaults
+ (cond ((directory-pathname-p defaults)
+ (let ((file (and defaults
+ (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd" :case :local)))
#+(and (or win32 windows) (not :clisp))
(shortcut (make-pathname
:defaults defaults :version :newest
:name name :type "asd.lnk" :case :local)))
- (if (and file (probe-file file))
- (return file))
+ (if (and file (probe-file file))
+ (return file))
#+(and (or win32 windows) (not :clisp))
(when (probe-file shortcut)
(let ((target (parse-windows-shortcut shortcut)))
(when target
(return (pathname target)))))))
- (t
- (restart-case
- (let* ((*print-circle* nil)
- (message
- (format nil
- "~@<While searching for system `~a`: `~a` evaluated ~
-to `~a` which is not a directory.~@:>"
- system dir defaults)))
- (error message))
- (remove-entry-from-registry ()
- :report "Remove entry from *central-registry* and continue"
- (push dir to-remove))
- (coerce-entry-to-directory ()
- :report (lambda (s)
- (format s "Coerce entry to ~a, replace ~a and continue."
- (ensure-directory-pathname defaults) dir))
- (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
- ;; cleanup
- (dolist (dir to-remove)
- (setf *central-registry* (remove dir *central-registry*)))
- (dolist (pair to-replace)
- (let* ((current (car pair))
- (new (cdr pair))
- (position (position current *central-registry*)))
- (setf *central-registry*
- (append (subseq *central-registry* 0 position)
- (list new)
- (subseq *central-registry* (1+ position))))))))))
+ (t
+ (restart-case
+ (let* ((*print-circle* nil)
+ (message
+ (format nil
+ "~@<While searching for system `~a`: `~a` evaluated ~
+to `~a` which is not a directory.~@:>"
+ system dir defaults)))
+ (error message))
+ (remove-entry-from-registry ()
+ :report "Remove entry from *central-registry* and continue"
+ (push dir to-remove))
+ (coerce-entry-to-directory ()
+ :report (lambda (s)
+ (format s "Coerce entry to ~a, replace ~a and continue."
+ (ensure-directory-pathname defaults) dir))
+ (push (cons dir (ensure-directory-pathname defaults)) to-replace))))))))
+ ;; cleanup
+ (dolist (dir to-remove)
+ (setf *central-registry* (remove dir *central-registry*)))
+ (dolist (pair to-replace)
+ (let* ((current (car pair))
+ (new (cdr pair))
+ (position (position current *central-registry*)))
+ (setf *central-registry*
+ (append (subseq *central-registry* 0 position)
+ (list new)
+ (subseq *central-registry* (1+ position))))))))))
(defun make-temporary-package ()
(flet ((try (counter)
(< (car in-memory) (safe-file-write-date on-disk))))
(let ((package (make-temporary-package)))
(unwind-protect
- (let ((*package* package))
- (asdf-message
- "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
- ;; FIXME: This wants to be (ENOUGH-NAMESTRING
- ;; ON-DISK), but CMUCL barfs on that.
- on-disk
- *package*)
- (load on-disk))
+ (with-open-file (asd on-disk :if-does-not-exist nil)
+ (if asd
+ (let ((*package* package))
+ (asdf-message
+ "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%"
+ ;; FIXME: This wants to be (ENOUGH-NAMESTRING
+ ;; ON-DISK), but CMUCL barfs on that.
+ on-disk
+ *package*)
+ (load on-disk))
+ (error 'missing-definition :name name :pathname on-disk)))
(delete-package package))))
(let ((in-memory (system-registered-p name)))
(if in-memory
- (progn (if on-disk (setf (car in-memory)
- (safe-file-write-date on-disk)))
+ (progn (if on-disk (setf (car in-memory)
+ (safe-file-write-date on-disk)))
(cdr in-memory))
(if error-p (error 'missing-component :requires name))))))
(cons (get-universal-time) system)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; finding components
+;;;; -------------------------------------------------------------------------
+;;;; Finding components
(defmethod find-component ((module module) name &optional version)
(if (slot-boundp module 'components)
(component-name component)
(source-file-type component (component-system component))))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; operations
+;;;; -------------------------------------------------------------------------
+;;;; Operations
-;;; one of these is instantiated whenever (operate ) is called
+;;; one of these is instantiated whenever #'operate is called
(defclass operation ()
((forced :initform nil :initarg :force :accessor operation-forced)
(defmethod component-depends-on ((o operation) (c component))
(cdr (assoc (class-name (class-of o))
- (slot-value c 'in-order-to))))
+ (component-in-order-to c))))
(defmethod component-self-dependencies ((o operation) (c component))
(let ((all-deps (component-depends-on o c)))
;;; So you look at this code and think "why isn't it a bunch of
;;; methods". And the answer is, because standard method combination
;;; runs :before methods most->least-specific, which is back to front
-;;; for our purposes.
+;;; for our purposes.
(defmethod traverse ((operation operation) (c component))
(let ((forced nil))
;; in-order-to slot with canonicalized
;; names instead of coercing this late
(coerce-name required-c) required-v)
- (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))))
+ (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)))
(traverse op dep-c)))
- (do-one-dep (required-op required-c required-v)
+ (do-one-dep (required-op required-c required-v)
(loop
- (restart-case
- (return (%do-one-dep required-op required-c required-v))
- (retry ()
- :report (lambda (s)
- (format s "~@<Retry loading component ~S.~@:>"
- required-c))
- :test
- (lambda (c)
+ (restart-case
+ (return (%do-one-dep required-op required-c required-v))
+ (retry ()
+ :report (lambda (s)
+ (format s "~@<Retry loading component ~S.~@:>"
+ required-c))
+ :test
+ (lambda (c)
#|
- (print (list :c1 c (typep c 'missing-dependency)))
- (when (typep c 'missing-dependency)
- (print (list :c2 (missing-requires c) required-c
- (equalp (missing-requires c)
- required-c))))
+ (print (list :c1 c (typep c 'missing-dependency)))
+ (when (typep c 'missing-dependency)
+ (print (list :c2 (missing-requires c) required-c
+ (equalp (missing-requires c)
+ required-c))))
|#
- (and (typep c 'missing-dependency)
- (equalp (missing-requires c)
- required-c)))))))
+ (and (typep c 'missing-dependency)
+ (equalp (missing-requires c)
+ required-c)))))))
(do-dep (op dep)
(cond ((eq op 'feature)
(or (member (car dep) *features*)
(t
(dolist (d dep)
(cond ((consp d)
- (cond ((string-equal
- (symbol-name (first d))
- "VERSION")
- (appendf
- forced
- (do-one-dep op (second d) (third d))))
- ((and (string-equal
- (symbol-name (first d))
- "FEATURE")
- (find (second d) *features*
- :test 'string-equal))
- (appendf
- forced
- (do-one-dep op (second d) (third d))))
- (t
- (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature>), or a name" d))))
+ (cond ((string-equal
+ (symbol-name (first d))
+ "VERSION")
+ (appendf
+ forced
+ (do-one-dep op (second d) (third d))))
+ ((and (string-equal
+ (symbol-name (first d))
+ "FEATURE")
+ (find (second d) *features*
+ :test 'string-equal))
+ (appendf
+ forced
+ (do-one-dep op (second d) (third d))))
+ (t
+ (error "Bad dependency ~a. Dependencies must be (:version <version>), (:feature <feature>), or a name" d))))
(t
(appendf forced (do-one-dep op d nil)))))))))
(aif (component-visited-p operation c)
(error 'circular-dependency :components (list c)))
(setf (visiting-component operation c) t)
(unwind-protect
- (progn
- (loop for (required-op . deps) in
- (component-depends-on operation c)
- do (do-dep required-op deps))
- ;; constituent bits
- (let ((module-ops
- (when (typep c 'module)
- (let ((at-least-one nil)
- (forced nil)
- (error nil))
- (loop for kid in (module-components c)
- do (handler-case
- (appendf forced (traverse operation kid ))
- (missing-dependency (condition)
- (if (eq (module-if-component-dep-fails c)
- :fail)
- (error condition))
- (setf error condition))
- (:no-error (c)
- (declare (ignore c))
- (setf at-least-one t))))
- (when (and (eq (module-if-component-dep-fails c)
- :try-next)
- (not at-least-one))
- (error error))
- forced))))
- ;; now the thing itself
- (when (or forced module-ops
- (not (operation-done-p operation c))
- (let ((f (operation-forced
- (operation-ancestor operation))))
- (and f (or (not (consp f))
- (member (component-name
- (operation-ancestor operation))
- (mapcar #'coerce-name f)
- :test #'string=)))))
- (let ((do-first (cdr (assoc (class-name (class-of operation))
- (slot-value c 'do-first)))))
- (loop for (required-op . deps) in do-first
- do (do-dep required-op deps)))
- (setf forced (append (delete 'pruned-op forced :key #'car)
- (delete 'pruned-op module-ops :key #'car)
- (list (cons operation c)))))))
- (setf (visiting-component operation c) nil))
+ (progn
+ (loop :for (required-op . deps) :in
+ (component-depends-on operation c)
+ :do (do-dep required-op deps))
+ ;; constituent bits
+ (let ((module-ops
+ (when (typep c 'module)
+ (let ((at-least-one nil)
+ (forced nil)
+ (error nil))
+ (dolist (kid (module-components c))
+ (handler-case
+ (appendf forced (traverse operation kid))
+ (missing-dependency (condition)
+ (if (eq (module-if-component-dep-fails c)
+ :fail)
+ (error condition))
+ (setf error condition))
+ (:no-error (c)
+ (declare (ignore c))
+ (setf at-least-one t))))
+ (when (and (eq (module-if-component-dep-fails c)
+ :try-next)
+ (not at-least-one))
+ (error error))
+ forced))))
+ ;; now the thing itself
+ (when (or forced module-ops
+ (not (operation-done-p operation c))
+ (let ((f (operation-forced
+ (operation-ancestor operation))))
+ (and f (or (not (consp f))
+ (member (component-name
+ (operation-ancestor operation))
+ (mapcar #'coerce-name f)
+ :test #'string=)))))
+ (let ((do-first (cdr (assoc (class-name (class-of operation))
+ (component-do-first c)))))
+ (loop :for (required-op . deps) :in do-first
+ :do (do-dep required-op deps)))
+ (setf forced (append (delete 'pruned-op forced :key #'car)
+ (delete 'pruned-op module-ops :key #'car)
+ (list (cons operation c)))))))
+ (setf (visiting-component operation c) nil))
(visit-component operation c (and forced t))
forced)))
(defmethod explain ((operation operation) (component component))
(asdf-message "~&;;; ~A on ~A~%" operation component))
-;;; compile-op
+;;;; -------------------------------------------------------------------------
+;;;; compile-op
(defclass compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
:initform *compile-file-warnings-behaviour*)
(on-failure :initarg :on-failure :accessor operation-on-failure
:initform *compile-file-failure-behaviour*)
- #+ecl
(flags :initarg :system-p :accessor compile-op-flags :initform nil)))
(defmethod perform :before ((operation compile-op) (c source-file))
nil)
-;;; load-op
+;;;; -------------------------------------------------------------------------
+;;;; load-op
(defclass basic-load-op (operation) ())
(defmethod perform around ((o load-op) (c cl-source-file))
(let ((state :initial))
- (loop 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-instance 'asdf: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)))))))
+ (loop :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-instance 'asdf: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 around ((o compile-op) (c cl-source-file))
(let ((state :initial))
- (loop 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 (make-instance 'asdf:compile-op) c))
- (t
- (with-simple-restart
- (try-recompiling "Try recompiling ~a"
- (component-name c))
- (setf state :failed-compile)
- (call-next-method)
- (setf state :success)))))))
+ (loop :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 (make-instance 'asdf:compile-op) 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))
nil)
(cons (list 'compile-op (component-name c))
(call-next-method)))
-;;; load-source-op
+;;;; -------------------------------------------------------------------------
+;;;; load-source-op
(defclass load-source-op (basic-load-op) ())
;;; FIXME: we simply copy load-op's dependencies. this is Just Not Right.
(defmethod component-depends-on ((o load-source-op) (c component))
(let ((what-would-load-op-do (cdr (assoc 'load-op
- (slot-value c 'in-order-to)))))
+ (component-in-order-to c)))))
(mapcar (lambda (dep)
(if (eq (car dep) 'load-op)
(cons 'load-source-op (cdr dep))
(component-property c 'last-loaded-as-source)))
nil t))
+
+;;;; -------------------------------------------------------------------------
+;;;; test-op
+
(defclass test-op (operation) ())
(defmethod perform ((operation test-op) (c component))
(cons `(load-op ,(component-name c)) (call-next-method)))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; invoking operations
+;;;; -------------------------------------------------------------------------
+;;;; Invoking Operations
(defun operate (operation-class system &rest args &key (verbose t) version force
&allow-other-keys)
(error 'missing-component-of-version :requires system :version version))
(let ((steps (traverse op system)))
(with-compilation-unit ()
- (loop for (op . component) in steps do
- (loop
- (restart-case
- (progn (perform op component)
- (return))
- (retry ()
- :report
- (lambda (s)
- (format s "~@<Retry performing ~S on ~S.~@:>"
- op component)))
- (accept ()
- :report
- (lambda (s)
- (format s "~@<Continue, treating ~S on ~S as ~
+ (loop :for (op . component) :in steps :do
+ (loop
+ (restart-case
+ (progn (perform op component)
+ (return))
+ (retry ()
+ :report
+ (lambda (s)
+ (format s "~@<Retry performing ~S on ~S.~@:>"
+ op component)))
+ (accept ()
+ :report
+ (lambda (s)
+ (format s "~@<Continue, treating ~S on ~S as ~
having been successful.~@:>"
- op component))
- (setf (gethash (type-of op)
- (component-operation-times component))
- (get-universal-time))
- (return)))))))
+ op component))
+ (setf (gethash (type-of op)
+ (component-operation-times component))
+ (get-universal-time))
+ (return)))))))
op))
(defun oos (operation-class system &rest args &key force (verbose t) version
- &allow-other-keys)
+ &allow-other-keys)
(declare (ignore force verbose version))
(apply #'operate operation-class system args))
created with the same initargs as the original one.
"))
(setf (documentation 'oos 'function)
- (format nil
- "Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a"
- operate-docstring))
+ (format nil
+ "Short for _operate on system_ and an alias for the [operate][] function. ~&~&~a"
+ operate-docstring))
(setf (documentation 'operate 'function)
- operate-docstring))
+ operate-docstring))
(defun load-system (system &rest args &key force (verbose t) version)
"Shorthand for `(operate 'asdf:load-op system)`. See [operate][] for details."
(declare (ignore force verbose version))
(apply #'operate 'test-op system args))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; syntax
-
-(defun remove-keyword (key arglist)
- (labels ((aux (key arglist)
- (cond ((null arglist) nil)
- ((eq key (car arglist)) (cddr arglist))
- (t (cons (car arglist) (cons (cadr arglist)
- (remove-keyword
- key (cddr arglist))))))))
- (aux key arglist)))
-
-(defun resolve-symlinks (path)
- #-allegro (truename path)
- #+allegro (excl:pathname-resolve-symbolic-links path)
- )
+;;;; -------------------------------------------------------------------------
+;;;; Defsystem
(defun determine-system-pathname (pathname pathname-supplied-p)
;; called from the defsystem macro.
;; the pathname of a system is either
- ;; 1. the one supplied,
+ ;; 1. the one supplied,
;; 2. derived from the *load-truename* (see below), or
;; 3. taken from *default-pathname-defaults*
;;
;; implementations, the latter has *already resolved it.
(or (and pathname-supplied-p pathname)
(when *load-pathname*
- (pathname-sans-name+type
- (if *resolve-symlinks*
- (resolve-symlinks *load-truename*)
- *load-pathname*)))
+ (pathname-sans-name+type
+ (if *resolve-symlinks*
+ (resolve-symlinks *load-truename*)
+ *load-pathname*)))
*default-pathname-defaults*))
(defmacro defsystem (name &body options)
(t
(register-system (quote ,name)
(make-instance ',class :name ',name))))
- (%set-system-source-file *load-truename*
- (cdr (system-registered-p ',name))))
- (parse-component-form
- nil (apply
- #'list
- :module (coerce-name ',name)
- :pathname
- ,(determine-system-pathname pathname pathname-arg-p)
- ',component-options))))))
+ (%set-system-source-file *load-truename*
+ (cdr (system-registered-p ',name))))
+ (parse-component-form
+ nil (apply
+ #'list
+ :module (coerce-name ',name)
+ :pathname
+ ,(determine-system-pathname pathname pathname-arg-p)
+ ',component-options))))))
(defun class-for-type (parent type)
new-tree))
-(defun remove-keys (key-names args)
- (loop for ( name val ) on args by #'cddr
- unless (member (symbol-name name) key-names
- :key #'symbol-name :test 'equal)
- append (list name val)))
-
(defvar *serial-depends-on*)
(defun sysdef-error-component (msg type name value)
"~&The value specified for ~(~A~) ~A is ~W")
type name value))
-(defun check-component-input (type name weakly-depends-on
- depends-on components in-order-to)
+(defun check-component-input (type name weakly-depends-on
+ depends-on components in-order-to)
"A partial test of the values of a component."
(unless (listp depends-on)
(sysdef-error-component ":depends-on must be a list."
type name in-order-to)))
(defun %remove-component-inline-methods (component)
- (loop for name in +asdf-methods+
- do (map 'nil
- ;; this is inefficient as most of the stored
- ;; methods will not be for this particular gf n
- ;; But this is hardly performance-critical
- (lambda (m)
- (remove-method (symbol-function name) m))
- (component-inline-methods component)))
+ (dolist (name +asdf-methods+)
+ (map ()
+ ;; this is inefficient as most of the stored
+ ;; methods will not be for this particular gf n
+ ;; But this is hardly performance-critical
+ (lambda (m)
+ (remove-method (symbol-function name) m))
+ (component-inline-methods component)))
;; clear methods, then add the new ones
(setf (component-inline-methods component) nil))
(defun %define-component-inline-methods (ret rest)
- (loop for name in +asdf-methods+ do
- (let ((keyword (intern (symbol-name name) :keyword)))
- (loop for data = rest then (cddr data)
- for key = (first data)
- for value = (second data)
- while data
- when (eq key keyword) do
- (destructuring-bind (op qual (o c) &body body) value
- (pushnew
- (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
- ,@body))
- (component-inline-methods ret)))))))
+ (dolist (name +asdf-methods+)
+ (let ((keyword (intern (symbol-name name) :keyword)))
+ (loop :for data = rest :then (cddr data)
+ :for key = (first data)
+ :for value = (second data)
+ :while data
+ :when (eq key keyword) :do
+ (destructuring-bind (op qual (o c) &body body) value
+ (pushnew
+ (eval `(defmethod ,name ,qual ((,o ,op) (,c (eql ,ret)))
+ ,@body))
+ (component-inline-methods ret)))))))
(defun %refresh-component-inline-methods (component rest)
(%remove-component-inline-methods component)
(%define-component-inline-methods component rest))
-
+
(defun parse-component-form (parent options)
(destructuring-bind
(module-default-component-class parent))))
(let ((*serial-depends-on* nil))
(setf (module-components ret)
- (loop for c-form in components
- for c = (parse-component-form ret c-form)
- collect c
- if serial
- do (push (component-name c) *serial-depends-on*))))
+ (loop :for c-form :in components
+ :for c = (parse-component-form ret c-form)
+ :collect c
+ :if serial
+ :do (push (component-name c) *serial-depends-on*))))
;; check for duplicate names
(let ((name-hash (make-hash-table :test #'equal)))
- (loop for c in (module-components ret)
- do
- (if (gethash (component-name c)
- name-hash)
- (error 'duplicate-names
- :name (component-name c))
- (setf (gethash (component-name c)
- name-hash)
- t)))))
-
- (setf (slot-value ret 'in-order-to)
+ (loop :for c in (module-components ret) :do
+ (if (gethash (component-name c)
+ name-hash)
+ (error 'duplicate-names
+ :name (component-name c))
+ (setf (gethash (component-name c)
+ name-hash)
+ t)))))
+
+ (setf (component-in-order-to ret)
(union-of-dependencies
in-order-to
`((compile-op (compile-op ,@depends-on))
(load-op (load-op ,@depends-on))))
- (slot-value ret 'do-first) `((compile-op (load-op ,@depends-on))))
+ (component-do-first ret) `((compile-op (load-op ,@depends-on))))
(%refresh-component-inline-methods ret rest)
ret)))
-;;; optional extras
-
-;;; run-shell-command functions for other lisp implementations will be
-;;; gratefully accepted, if they do the same thing. If the docstring
-;;; is ambiguous, send a bug report
+;;;; ---------------------------------------------------------------------------
+;;;; run-shell-command
+;;;;
+;;;; run-shell-command functions for other lisp implementations will be
+;;;; gratefully accepted, if they do the same thing.
+;;;; If the docstring is ambiguous, send a bug report.
+;;;;
+;;;; 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
(defun run-shell-command (control-string &rest args)
"Interpolate `args` into `control-string` as if by `format`, and
#+sbcl
(sb-ext:process-exit-code
(apply #'sb-ext:run-program
- #+win32 "sh" #-win32 "/bin/sh"
- (list "-c" command)
- :input nil :output *verbose-out*
- #+win32 '(:search t) #-win32 nil))
+ #+win32 "sh" #-win32 "/bin/sh"
+ (list "-c" command)
+ :input nil :output *verbose-out*
+ #+win32 '(:search t) #-win32 nil))
#+(or cmu scl)
(ext:process-exit-code
#+allegro
;; 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)
- :input nil :whole nil
- #+mswindows :show-window #+mswindows :hide)
+ (excl.osi:command-output
+ (format nil "~a -c \"~a\""
+ #+mswindows "sh" #-mswindows "/bin/sh" command)
+ :input nil :whole nil
+ #+mswindows :show-window #+mswindows :hide)
(format *verbose-out* "~{~&; ~a~%~}~%" stderr)
(format *verbose-out* "~{~&; ~a~%~}~%" stdout)
exit-code)
(si:system command)
#-(or openmcl clisp lispworks allegro scl cmu sbcl ecl)
- (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+ (error "RUN-SHELL-COMMAND not implemented for this Lisp")
))
+;;;; ---------------------------------------------------------------------------
+;;;; system-relative-pathname
+
(defmethod system-source-file ((system-name t))
(system-source-file (find-system system-name)))
:defaults (system-source-file system-name)))
(defun system-relative-pathname (system pathname &key name type)
- ;; you're not allowed to muck with the return value of pathname-X
- (let ((directory (copy-list (pathname-directory pathname))))
- (when (eq (car directory) :absolute)
- (setf (car directory) :relative))
+ (let ((directory (pathname-directory pathname)))
(merge-pathnames
(make-pathname :name (or name (pathname-name pathname))
:type (or type (pathname-type pathname))
- :directory directory)
+ :directory (if (eq (car directory) :absolute)
+ (cons :relative (cdr directory))
+ directory))
(system-source-directory system))))
;;; ---------------------------------------------------------------------------
;;; ---------------------------------------------------------------------------
;;; Portions of this code were once from SWANK / SLIME
-(defparameter *centralize-lisp-binaries*
- nil "
-If true, compiled lisp files without an explicit mapping (see
+(defparameter *centralize-lisp-binaries* nil
+ "If true, compiled lisp files without an explicit mapping (see
\\*source-to-target-mappings\\*) will be placed in subdirectories of
\\*default-toplevel-directory\\*. If false, then compiled lisp files
without an explicitly mapping will be placed in subdirectories of
(defparameter *enable-asdf-binary-locations* nil
"
-If true, then compiled lisp files will be placed into a directory
+If true, then compiled lisp files will be placed into a directory
computed from the Lisp version, Operating System and computer archetecture.
See [implementation-specific-directory-name][] for details.")
(defparameter *default-toplevel-directory*
(merge-pathnames
- (make-pathname :directory '(:relative ".fasls"))
+ (make-pathname :directory '(:relative ".cache" "common-lisp"))
(truename (user-homedir-pathname)))
"If \\*centralize-lisp-binaries\\* is true, then compiled lisp files without an explicit mapping \(see \\*source-to-target-mappings\\*\) will be placed in subdirectories of \\*default-toplevel-directory\\*.")
nil
"If true, then all subclasses of source-file will have their output locations mapped by ASDF-Binary-Locations. If nil (the default), then only subclasses of cl-source-file will be mapped.")
-(defvar *source-to-target-mappings*
+(defvar *source-to-target-mappings*
#-sbcl
nil
#+sbcl
- (list (list (princ-to-string (sb-ext:posix-getenv "SBCL_HOME")) nil))
+ (list (list (princ-to-string (getenv "SBCL_HOME")) nil))
"The \\*source-to-target-mappings\\* variable specifies mappings from source to target. If the target is nil, then it means to not map the source to anything. I.e., to leave it as is. This has the effect of turning off ASDF-Binary-Locations for the given source directory. Examples:
;; compile everything in .../src and below into .../cmucl
- '((\"/nfs/home/compbio/d95-bli/share/common-lisp/src/\"
+ '((\"/nfs/home/compbio/d95-bli/share/common-lisp/src/\"
\"/nfs/home/compbio/d95-bli/lib/common-lisp/cmucl/\"))
;; leave SBCL innards alone (SBCL specific)
:linux :unix))
(defparameter *architecture-features*
- '(:amd64 (:x86-64 :x86_64 :x8664-target) :i686 :i586 :pentium3
+ '(:amd64 (:x86-64 :x86_64 :x8664-target) :i686 :i586 :pentium3
:i486 (:i386 :pc386 :iapx386) (:x86 :x8632-target) :pentium4
:hppa64 :hppa :ppc64 :ppc32 :powerpc :ppc :sparc64 :sparc))
;; note to gwking: this is in slime, system-check, and system-check-server too
(defun lisp-version-string ()
- #+cmu (substitute #\- #\/
- (substitute #\_ #\Space
- (lisp-implementation-version)))
+ #+cmu (substitute #\- #\/
+ (substitute #\_ #\Space
+ (lisp-implementation-version)))
#+scl (lisp-implementation-version)
#+sbcl (lisp-implementation-version)
#+ecl (reduce (lambda (x str) (substitute #\_ str x))
- '(#\Space #\: #\( #\))
- :initial-value (lisp-implementation-version))
+ '(#\Space #\: #\( #\))
+ :initial-value (lisp-implementation-version))
#+gcl (let ((s (lisp-implementation-version))) (subseq s 4))
#+openmcl (format nil "~d.~d~@[-~d~]"
- ccl::*openmcl-major-version*
+ ccl::*openmcl-major-version*
ccl::*openmcl-minor-version*
- #+ppc64-target 64
+ #+ppc64-target 64
#-ppc64-target nil)
#+lispworks (format nil "~A~@[~A~]"
(lisp-implementation-version)
#+allegro (format nil
"~A~A~A~A"
excl::*common-lisp-version-number*
- ; ANSI vs MoDeRn
- ;; thanks to Robert Goldman and Charley Cox for
- ;; an improvement to my hack
- (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 ""))
+ ; ANSI vs MoDeRn
+ ;; thanks to Robert Goldman and Charley Cox for
+ ;; an improvement to my hack
+ (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" ""))
#+clisp (let ((s (lisp-implementation-version)))
(subseq s 0 (position #\space s)))
unique to a Lisp implementation, Lisp implementation version,
operating system, and hardware architecture."
(and *enable-asdf-binary-locations*
- (list
- (or *implementation-specific-directory-name*
- (setf *implementation-specific-directory-name*
- (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)
- (let ((feature (find subf *features*)))
- (when feature (return-from fp (first thing))))))))
- (first-of (features)
- (loop for f in features
- when (fp f) return it))
- (maybe-warn (value fstring &rest args)
- (cond (value)
- (t (apply #'warn fstring args)
- "unknown"))))
- (let ((lisp (maybe-warn (first-of *implementation-features*)
- "No implementation feature found in ~a."
- *implementation-features*))
- (os (maybe-warn (first-of *os-features*)
- "No os feature found in ~a." *os-features*))
- (arch (maybe-warn (first-of *architecture-features*)
- "No architecture feature found in ~a."
- *architecture-features*))
- (version (maybe-warn (lisp-version-string)
- "Don't know how to get Lisp ~
+ (list
+ (or *implementation-specific-directory-name*
+ (setf *implementation-specific-directory-name*
+ (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)
+ (let ((feature (find subf *features*)))
+ (when feature (return-from fp (first thing))))))))
+ (first-of (features)
+ (loop :for f :in features
+ :when (fp f) :return :it))
+ (maybe-warn (value fstring &rest args)
+ (cond (value)
+ (t (apply #'warn fstring args)
+ "unknown"))))
+ (let ((lisp (maybe-warn (first-of *implementation-features*)
+ "No implementation feature found in ~a."
+ *implementation-features*))
+ (os (maybe-warn (first-of *os-features*)
+ "No os feature found in ~a." *os-features*))
+ (arch (maybe-warn (first-of *architecture-features*)
+ "No architecture feature found in ~a."
+ *architecture-features*))
+ (version (maybe-warn (lisp-version-string)
+ "Don't know how to get Lisp ~
implementation version.")))
- (format nil "~(~@{~a~^-~}~)" lisp version os arch))))))))
+ (format nil "~(~@{~a~^-~}~)" lisp version os arch))))))))
(defun pathname-prefix-p (prefix pathname)
(let ((prefix-ns (namestring prefix))
SBCL_HOME is set through that symlink, the default rule above
preventing SBCL contribs from being mapped elsewhere will not be
applied by the plain `*source-to-target-mappings*`."
- (loop for mapping in asdf:*source-to-target-mappings*
- for (source target) = mapping
- for true-source = (and source (resolve-symlinks source))
- if (equal source true-source)
- collect mapping
- else append (list mapping (list true-source target))))
+ (loop :for mapping :in asdf:*source-to-target-mappings*
+ :for (source target) = mapping
+ :for true-source = (and source (resolve-symlinks source))
+ :if (equal source true-source) :collect mapping
+ :else :append (list mapping (list true-source target))))
(defmethod output-files-for-system-and-operation
((system system) operation component source possible-paths)
source possible-paths (source-to-target-resolved-mappings)))
(defmethod output-files-using-mappings (source possible-paths path-mappings)
- (mapcar
- (lambda (path)
- (loop for (from to) in path-mappings
- when (pathname-prefix-p from source)
- do (return
- (if to
- (merge-pathnames
- (make-pathname :type (pathname-type path))
- (merge-pathnames (enough-namestring source from)
- to))
- path))
-
- finally
- (return
- ;; Instead of just returning the path when we
- ;; don't find a mapping, we stick stuff into
- ;; the appropriate binary directory based on
- ;; the implementation
- (if *centralize-lisp-binaries*
- (merge-pathnames
- (make-pathname
- :type (pathname-type path)
- :directory `(:relative
- ,@(cond ((eq *include-per-user-information* t)
- (cdr (pathname-directory
- (user-homedir-pathname))))
- ((not (null *include-per-user-information*))
- (list *include-per-user-information*)))
- ,@(implementation-specific-directory-name)
- ,@(rest (pathname-directory path)))
- :defaults path)
- *default-toplevel-directory*)
- (make-pathname
- :type (pathname-type path)
- :directory (append
- (pathname-directory path)
- (implementation-specific-directory-name))
- :defaults path)))))
- possible-paths))
-
-(defmethod output-files
- :around ((operation compile-op) (component source-file))
+ (mapcar
+ (lambda (path)
+ (loop :for (from to) :in path-mappings
+ :when (pathname-prefix-p from source)
+ :return
+ (if to
+ (merge-pathnames
+ (make-pathname :type (pathname-type path))
+ (merge-pathnames (enough-namestring source from)
+ to))
+ path)
+ :finally
+ (return
+ ;; Instead of just returning the path when we
+ ;; don't find a mapping, we stick stuff into
+ ;; the appropriate binary directory based on
+ ;; the implementation
+ (if *centralize-lisp-binaries*
+ (merge-pathnames
+ (make-pathname
+ :type (pathname-type path)
+ :directory `(:relative
+ ,@(cond ((eq *include-per-user-information* t)
+ (cdr (pathname-directory
+ (user-homedir-pathname))))
+ ((not (null *include-per-user-information*))
+ (list *include-per-user-information*)))
+ ,@(implementation-specific-directory-name)
+ ,@(rest (pathname-directory path)))
+ :defaults path)
+ *default-toplevel-directory*)
+ (make-pathname
+ :type (pathname-type path)
+ :directory (append
+ (pathname-directory path)
+ (implementation-specific-directory-name))
+ :defaults path)))))
+ possible-paths))
+
+(defmethod output-files
+ :around ((operation compile-op) (component source-file))
(if (or *map-all-source-files*
- (typecase component
- (cl-source-file t)
- (t nil)))
- (let ((source (component-pathname component ))
- (paths (call-next-method)))
- (output-files-for-system-and-operation
+ (typecase component
+ (cl-source-file t)
+ (t nil)))
+ (let ((source (component-pathname component))
+ (paths (call-next-method)))
+ (output-files-for-system-and-operation
(component-system component) operation component source paths))
(call-next-method)))
(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))))
+ (loop :for code = (read-byte s)
+ :until (zerop code)
+ :do (write-char (code-char code) out))))
(defun read-little-endian (s &optional (bytes 4))
- (let ((result 0))
- (loop
- for i from 0 below bytes
- do
- (setf result (logior result (ash (read-byte s) (* 8 i)))))
- result))
+ (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)))
+ (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))))
+ ((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))))))
+ (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)))))))
+ (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))))
+ nil))))
-(pushnew :asdf *features*)
+;;;; -----------------------------------------------------------------
+;;;; Source Registry Configuration, by Francois-Rene Rideau
+;;;; See README.source-registry and https://bugs.launchpad.net/asdf/+bug/485918
-#+sbcl
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (when (sb-ext:posix-getenv "SBCL_BUILDING_CONTRIB")
- (pushnew :sbcl-hooks-require *features*)))
+(pushnew 'sysdef-source-registry-search *system-definition-search-functions*)
+
+;; Using ack 1.2 exclusions
+(defvar *default-exclusions*
+ '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst"
+ ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
+ "_sgbak" "autom4te.cache" "cover_db" "_build"))
-#+(and sbcl sbcl-hooks-require)
+(defun default-registry ()
+ ())
+
+(defvar *source-registry* ()
+ "Either NIL (for uninitialized), or a list of one element,
+said element itself being a list of directory pathnames where to look for .asd files")
+
+(defun source-registry ()
+ (car *source-registry*))
+
+(defun (setf source-registry) (x)
+ (setf *source-registry* (list x)))
+
+(defun source-registry-initialized-p ()
+ (and *source-registry* t))
+
+(defun clear-source-registry ()
+ "Undoes any initialization of the source registry.
+You might want to call that before you dump an image that would be resumed
+with a different configuration, so the configuration would be re-read then."
+ (setf *source-registry* '())
+ (values))
+
+(defun sysdef-source-registry-search (system)
+ (ensure-source-registry)
+ (let ((name (coerce-name system)))
+ (block nil
+ (dolist (dir (source-registry))
+ (let ((defaults (eval dir)))
+ (when defaults
+ (cond ((directory-pathname-p defaults)
+ (let ((file (and defaults
+ (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd" :case :local)))
+ #+(and (or win32 windows) (not :clisp))
+ (shortcut (make-pathname
+ :defaults defaults :version :newest
+ :name name :type "asd.lnk" :case :local)))
+ (when (and file (probe-file file))
+ (return file))
+ #+(and (or win32 windows) (not :clisp))
+ (when (probe-file shortcut)
+ (let ((target (parse-windows-shortcut shortcut)))
+ (when target
+ (return (pathname target))))))))))))))
+
+(defun read-file-forms (file)
+ (with-open-file (in file)
+ (loop :with eof = (list nil)
+ :for form = (read in nil eof)
+ :until (eq form eof)
+ :collect form)))
+
+(defun validate-source-registry-directive (directive)
+ (unless
+ (destructuring-bind (kw &rest rest) directive
+ (case kw
+ ((:include :directory :tree)
+ (and (length=n-p rest 1)
+ (typep (car rest) '(or pathname string))))
+ ((:exclude)
+ (every #'stringp rest))
+ ((:default-registry :inherit-configuration :ignore-inherited-configuration)
+ (null rest))))
+ (error "Invalid directive ~S~%" directive))
+ directive)
+
+(defun validate-source-registry-form (form)
+ (unless (and (consp form) (eq (car form) :source-registry))
+ (error "Error: Form is not a source registry ~S~%" form))
+ (loop :with inherit = 0
+ :for directive :in (cdr form) :do
+ (unless (consp directive)
+ (error "invalid directive ~S" directive))
+ (when (member (car directive)
+ '(:inherit-configuration :ignore-inherited-configuration))
+ (incf inherit))
+ (validate-source-registry-directive directive)
+ :finally
+ (unless (= inherit 1)
+ (error "One and only one of :inherit-configuration or :ignore-inherited-configuration is required")))
+ form)
+
+(defun validate-source-registry-file (file)
+ (let ((forms (read-file-forms file)))
+ (unless (length=n-p forms 1)
+ (error "One and only one form allowed for source registry. Got: ~S~%" forms))
+ (validate-source-registry-form (car forms))))
+
+(defun validate-source-registry-directory (directory)
+ (let ((files (sort (ignore-errors
+ (directory (merge-pathnames
+ (make-pathname :name :wild :type :wild)
+ directory)
+ #+sbcl :resolve-symlinks #+sbcl nil))
+ #'string< :key #'namestring)))
+ `(:source-registry
+ ,@(loop :for file :in files :append
+ (mapcar #'validate-source-registry-directive (read-file-forms file)))
+ (:inherit-configuration))))
+
+(defun parse-source-registry-string (string)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:source-registry (:inherit-configuration)))
+ ((not (stringp string))
+ (error "environment string isn't: ~S" string))
+ ((eql (char string 0) #\()
+ (validate-source-registry-form (read-from-string string)))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :for i = (or (position #\: string :start start) end) :do
+ (let ((s (subseq string start i)))
+ (cond
+ ((equal "" s) ; empty element: inherit
+ (when inherit
+ (error "only one inherited configuration allowed: ~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)))
+ (setf start (1+ i))
+ (when (>= start end)
+ (unless inherit
+ (push '(:ignore-inherited-configuration) directives))
+ (return `(:source-registry ,@(nreverse directives)))))))))
+
+(defun collect-asd-subdirectories (directory &key (exclude *default-exclusions*) collect)
+ (let* ((files (ignore-errors
+ (directory (merge-pathnames #P"**/*.asd" directory)
+ #+sbcl #+sbcl :resolve-symlinks nil
+ #+clisp #+clisp :circle t)))
+ (dirs (remove-duplicates (mapcar #'pathname-sans-name+type files) :test #'equal)))
+ (loop
+ :for dir :in dirs
+ :unless (loop :for x :in exclude
+ :thereis (find x (pathname-directory dir) :test #'equal))
+ :do (funcall collect dir))))
+
+(defparameter *default-source-registries*
+ '(process-environment-source-registry
+ process-user-source-registry
+ process-user-source-registry-directory
+ process-system-source-registry
+ process-system-source-registry-directory
+ process-default-source-registry))
+
+(defun user-configuration-pathname ()
+ (merge-pathnames ".config/" (user-homedir-pathname)))
+(defun system-configuration-pathname ()
+ #p"/etc/")
+(defun source-registry-under (directory)
+ (merge-pathnames "common-lisp/source-registry.conf" directory))
+(defun user-source-registry-pathname ()
+ (source-registry-under (user-configuration-pathname)))
+(defun system-source-registry-pathname ()
+ (source-registry-under (system-configuration-pathname)))
+(defun source-registry-directory-under (directory)
+ (merge-pathnames "common-lisp/source-registry.conf.d/" directory))
+(defun user-source-registry-directory-pathname ()
+ (source-registry-directory-under (user-configuration-pathname)))
+(defun system-source-registry-directory-pathname ()
+ (source-registry-directory-under (system-configuration-pathname)))
+
+(defun process-environment-source-registry (&key inherit collect)
+ (process-source-registry (getenv "CL_SOURCE_REGISTRY")
+ :inherit inherit :collect collect))
+(defun process-user-source-registry (&key inherit collect)
+ (process-source-registry (user-source-registry-pathname)
+ :inherit inherit :collect collect))
+(defun process-user-source-registry-directory (&key inherit collect)
+ (process-source-registry (user-source-registry-directory-pathname)
+ :inherit inherit :collect collect))
+(defun process-system-source-registry (&key inherit collect)
+ (process-source-registry (system-source-registry-pathname)
+ :inherit inherit :collect collect))
+(defun process-system-source-registry-directory (&key inherit collect)
+ (process-source-registry (system-source-registry-directory-pathname)
+ :inherit inherit :collect collect))
+(defun process-default-source-registry (&key inherit collect)
+ (declare (ignore inherit collect))
+ nil)
+
+(defgeneric process-source-registry (spec &key inherit collect))
+(defmethod process-source-registry ((pathname pathname) &key
+ (inherit *default-source-registries*)
+ collect)
+ (cond
+ ((directory-pathname-p pathname)
+ (process-source-registry (validate-source-registry-directory pathname)
+ :inherit inherit :collect collect))
+ ((probe-file pathname)
+ (process-source-registry (validate-source-registry-file pathname)
+ :inherit inherit :collect collect))
+ (t
+ (inherit-source-registry inherit :collect collect))))
+(defmethod process-source-registry ((string string) &key
+ (inherit *default-source-registries*)
+ collect)
+ (process-source-registry (parse-source-registry-string string)
+ :inherit inherit :collect collect))
+(defmethod process-source-registry ((x null) &key
+ (inherit *default-source-registries*)
+ collect)
+ (inherit-source-registry inherit :collect collect))
+
+(defun make-collector ()
+ (let ((acc ()))
+ (values (lambda (x) (push x acc))
+ (lambda () (reverse acc)))))
+
+(defmethod process-source-registry ((form cons) &key
+ (inherit *default-source-registries*)
+ collect)
+ (multiple-value-bind (collect result)
+ (if collect
+ (values collect (constantly nil))
+ (make-collector))
+ (let ((*default-exclusions* *default-exclusions*))
+ (dolist (directive (cdr (validate-source-registry-form form)))
+ (process-source-registry-directive directive :inherit inherit :collect collect)))
+ (funcall result)))
+
+(defun inherit-source-registry (inherit &key collect)
+ (when inherit
+ (funcall (first inherit) :collect collect :inherit (rest inherit))))
+
+(defun process-source-registry-directive (directive &key inherit collect)
+ (destructuring-bind (kw &rest rest) directive
+ (ecase kw
+ ((:include)
+ (destructuring-bind (pathname) rest
+ (process-source-registry (pathname pathname) :inherit inherit :collect collect)))
+ ((:directory)
+ (destructuring-bind (pathname) rest
+ (funcall collect (ensure-directory-pathname pathname))))
+ ((:tree)
+ (destructuring-bind (pathname) rest
+ (collect-asd-subdirectories pathname :collect collect)))
+ ((:exclude)
+ (setf *default-exclusions* rest))
+ ((:default-registry)
+ (default-registry))
+ ((:inherit-configuration)
+ (inherit-source-registry inherit :collect collect))
+ ((:ignore-inherited-configuration)
+ nil))))
+
+;; Will read the configuration and initialize all internal variables,
+;; and return the new configuration.
+(defun initialize-source-registry ()
+ (setf (source-registry)
+ (inherit-source-registry *default-source-registries*)))
+
+;; checks an initial variable to see whether the state is initialized
+;; or cleared. In the former case, return current configuration; in
+;; the latter, initialize. ASDF will call this function at the start
+;; of (asdf:find-system).
+(defun ensure-source-registry ()
+ (if (source-registry-initialized-p)
+ (source-registry)
+ (initialize-source-registry)))
+
+;;;; -----------------------------------------------------------------
+;;;; SBCL hook into REQUIRE
+;;;;
+#+sbcl
(progn
(defun module-provide-asdf (name)
(handler-bind ((style-warning #'muffle-warning))
t))))
(defun contrib-sysdef-search (system)
- (let ((home (sb-ext:posix-getenv "SBCL_HOME")))
+ (let ((home (getenv "SBCL_HOME")))
(when (and home (not (string= home "")))
(let* ((name (coerce-name system))
(home (truename home))
(probe-file contrib)))))
(pushnew
- '(let ((home (sb-ext:posix-getenv "SBCL_HOME")))
+ '(let ((home (getenv "SBCL_HOME")))
(when (and home (not (string= home "")))
(merge-pathnames "site-systems/" (truename home))))
*central-registry*)
(pushnew 'module-provide-asdf sb-ext:*module-provider-functions*)
(pushnew 'contrib-sysdef-search *system-definition-search-functions*))
-(if *asdf-revision*
- (asdf-message ";; ASDF, revision ~a" *asdf-revision*)
- (asdf-message ";; ASDF, revision unknown; possibly a development version"))
-
-(provide 'asdf)
-
-
-#+(or)
-;;?? ignore -- so how will ABL get "installed"
-;; should be unnecessary with newer versions of ASDF
-;; load customizations
-(eval-when (:load-toplevel :execute)
- (let* ((*package* (find-package :common-lisp)))
- (load
- (merge-pathnames
- (make-pathname :name "asdf-binary-locations"
- :type "lisp"
- :directory '(:relative ".asdf"))
- (truename (user-homedir-pathname)))
- :if-does-not-exist nil)))
+;;;; -------------------------------------------------------------------------
+;;;; Cleanups after hot-upgrade.
+;;;; Things to do in case we're upgrading from a previous version of ASDF.
+;;;; See https://bugs.launchpad.net/asdf/+bug/485687
+;;;;
+;;;; TODO: debug why it's not enough to upgrade from ECL <= 9.11.1
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ #+ecl ;; Support upgrade from before ECL went to 1.369
+ (when (fboundp 'compile-op-system-p)
+ (defmethod compile-op-system-p ((op compile-op))
+ (getf :system-p (compile-op-flags op)))))
+
+;;;; -----------------------------------------------------------------
+;;;; Done!
+(when *load-verbose*
+ (asdf-message ";; ASDF, version ~a" (asdf-version)))
+
+(pushnew :asdf *features*)
+;;(pushnew :asdf2 *features*) ;; do that when we reach version 2
+
+(provide :asdf)
+
+;;;; The End.
Repositories / ecl.git / commitdiff