;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.29: Another System Definition Facility.
+;;; This is ASDF 3.0.2: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
(declaim (optimize (speed 1) (safety 3) (debug 3)))
(setf ext:*gc-verbose* nil))
-#+(or abcl clisp cmu ecl xcl)
+#+(or abcl clisp clozure cmu ecl xcl)
(eval-when (:load-toplevel :compile-toplevel :execute)
(unless (member :asdf3 *features*)
(let* ((existing-version
(existing-major-minor (subseq existing-version 0 second-dot))
(existing-version-number (and existing-version (read-from-string existing-major-minor)))
(away (format nil "~A-~A" :asdf existing-version)))
- (when (and existing-version (< existing-version-number
- #+abcl 2.25 #+clisp 2.27 #+cmu 2.018 #+ecl 2.21 #+xcl 2.27))
+ (when (and existing-version
+ (< existing-version-number #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27))
(rename-package :asdf away)
(when *load-verbose*
- (format t "; Renamed old ~A package away to ~A~%" :asdf away))))))
+ (format t "~&; Renamed old ~A package away to ~A~%" :asdf away))))))
;;;; ---------------------------------------------------------------------------
;;;; Handle ASDF package upgrade, including implementation-dependent magic.
;;
;; See https://bugs.launchpad.net/asdf/+bug/485687
;;
-;; CAUTION: we must handle the first few packages specially for hot-upgrade.
-;; asdf/package will be frozen as of ASDF 3
-;; to forever export the same exact symbols.
-;; Any other symbol must be import-from'ed
-;; and reexported in a different package
-;; (alternatively the package may be dropped & replaced by one with a new name).
-
-(defpackage :asdf/package
+
+(defpackage :uiop/package
+ ;; CAUTION: we must handle the first few packages specially for hot-upgrade.
+ ;; This package definition MUST NOT change unless its name too changes;
+ ;; if/when it changes, don't forget to add new functions missing from below.
+ ;; Until then, asdf/package is frozen to forever
+ ;; import and export the same exact symbols as for ASDF 2.27.
+ ;; Any other symbol must be import-from'ed and re-export'ed in a different package.
(:use :common-lisp)
(:export
#:find-package* #:find-symbol* #:symbol-call
- #:intern* #:unintern* #:export* #:make-symbol*
- #:symbol-shadowing-p #:home-package-p #:rehome-symbol
+ #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
+ #:symbol-shadowing-p #:home-package-p
#:symbol-package-name #:standard-common-lisp-symbol-p
#:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
- #:nuke-symbol-in-package #:nuke-symbol
+ #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol
#:ensure-package-unused #:delete-package*
- #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names
+ #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
#:package-definition-form #:parse-define-package-form
#:ensure-package #:define-package))
-(in-package :asdf/package)
+(in-package :uiop/package)
;;;; General purpose package utilities
(let* ((package (find-package* package-designator))
(symbol (intern* name package)))
(export (or symbol (list symbol)) package)))
+ (defun import* (symbol package-designator)
+ (import (or symbol (list symbol)) (find-package* package-designator)))
+ (defun shadowing-import* (symbol package-designator)
+ (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
+ (defun shadow* (name package-designator)
+ (shadow (string name) (find-package* package-designator)))
(defun make-symbol* (name)
(etypecase name
(string (make-symbol name))
(multiple-value-bind (sym stat) (find-symbol name package)
(when (and (member stat '(:internal :external)) (eq symbol sym))
(if (symbol-shadowing-p symbol package)
- (shadowing-import (get-dummy-symbol symbol) package)
- (unintern symbol package))))))
+ (shadowing-import* (get-dummy-symbol symbol) package)
+ (unintern* symbol package))))))
(defun nuke-symbol (symbol &optional (packages (list-all-packages)))
#+(or clisp clozure)
(multiple-value-bind (setf-symbol kind)
(package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p)
(when old-package
(if shadowing
- (shadowing-import shadowing old-package))
- (unintern symbol old-package))
+ (shadowing-import* shadowing old-package))
+ (unintern* symbol old-package))
(cond
(overwritten-symbol-shadowing-p
- (shadowing-import symbol package))
+ (shadowing-import* symbol package))
(t
(when overwritten-symbol-status
- (unintern overwritten-symbol package))
- (import symbol package)))
+ (unintern* overwritten-symbol package))
+ (import* symbol package)))
(if shadowing
- (shadowing-import symbol old-package)
- (import symbol old-package))
+ (shadowing-import* symbol old-package)
+ (import* symbol old-package))
#+(or clisp clozure)
(multiple-value-bind (setf-symbol kind)
(get-setf-function-symbol symbol)
(symbol-name setf-symbol) (symbol-package-name setf-symbol)
(symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
(when (symbol-package setf-symbol)
- (unintern setf-symbol (symbol-package setf-symbol)))
+ (unintern* setf-symbol (symbol-package setf-symbol)))
(setf (fdefinition new-setf-symbol) setf-function)
(set-setf-function-symbol new-setf-symbol symbol kind))))
#+(or clisp clozure)
(or (home-package-p import-me from-package) (symbol-package-name import-me))
(package-name to-package) status
(and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
- (shadowing-import import-me to-package))))))
+ (shadowing-import* import-me to-package))))))
+ (defun ensure-imported (import-me into-package &optional from-package)
+ (check-type import-me symbol)
+ (check-type into-package package)
+ (check-type from-package (or null package))
+ (let ((name (symbol-name import-me)))
+ (multiple-value-bind (existing status) (find-symbol name into-package)
+ (cond
+ ((not status)
+ (import* import-me into-package))
+ ((eq import-me existing))
+ (t
+ (let ((shadowing-p (symbol-shadowing-p existing into-package)))
+ (note-package-fishiness
+ :ensure-imported name
+ (and from-package (package-name from-package))
+ (or (home-package-p import-me from-package) (symbol-package-name import-me))
+ (package-name into-package)
+ status
+ (and status (or (home-package-p existing into-package) (symbol-package-name existing)))
+ shadowing-p)
+ (cond
+ ((or shadowing-p (eq status :inherited))
+ (shadowing-import* import-me into-package))
+ (t
+ (unintern* existing into-package)
+ (import* import-me into-package))))))))
+ (values))
(defun ensure-import (name to-package from-package shadowed imported)
(check-type name string)
(check-type to-package package)
(when (null import-status)
(note-package-fishiness
:import-uninterned name (package-name from-package) (package-name to-package))
- (setf import-me (intern name from-package)))
+ (setf import-me (intern* name from-package)))
(multiple-value-bind (existing status) (find-symbol name to-package)
(cond
- ((gethash name imported)
- (unless (eq import-me existing)
+ ((and imported (gethash name imported))
+ (unless (and status (eq import-me existing))
(error "Can't import ~S from both ~S and ~S"
name (package-name (symbol-package existing)) (package-name from-package))))
((gethash name shadowed)
(error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
(t
- (setf (gethash name imported) t)
- (unless (and status (eq import-me existing))
- (when status
- (note-package-fishiness
- :import name
- (package-name from-package)
- (or (home-package-p import-me from-package) (symbol-package-name import-me))
- (package-name to-package) status
- (and status (or (home-package-p existing to-package) (symbol-package-name existing))))
- (unintern* existing to-package))
- (import import-me to-package)))))))
+ (setf (gethash name imported) t))))
+ (ensure-imported import-me to-package from-package)))
(defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
(check-type name string)
(check-type symbol symbol)
(note-package-fishiness
:import-uninterned name
(package-name from-package) (package-name to-package) mixp)
- (import symbol from-package)
+ (import* symbol from-package)
(setf sp (package-name from-package)))
(cond
((gethash name shadowed))
(defun symbol-recycled-p (sym recycle)
(check-type sym symbol)
(check-type recycle list)
- (member (symbol-package sym) recycle))
+ (and (member (symbol-package sym) recycle) t))
(defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
(check-type name string)
(check-type package package)
(check-type symbol symbol)
(check-type to-package package)
(check-type recycle list)
+ (assert (equal name (symbol-name symbol)))
(multiple-value-bind (existing status) (find-symbol name to-package)
(unless (and status (eq symbol existing))
(let ((accessible
(or (home-package-p existing to-package) (symbol-package-name existing))
status shadowing)
(if (or (eq status :inherited) shadowing)
- (shadowing-import symbol to-package)
+ (shadowing-import* symbol to-package)
(unintern existing to-package))
t)))))
(when (and accessible (eq status :external))
(defun ensure-exported (name symbol from-package &optional recycle)
(dolist (to-package (package-used-by-list from-package))
(ensure-exported-to-user name symbol to-package recycle))
- (import symbol from-package)
+ (unless (eq from-package (symbol-package symbol))
+ (ensure-imported symbol from-package))
(export* name from-package))
(defun ensure-export (name from-package &optional recycle)
(multiple-value-bind (symbol status) (find-symbol* name from-package)
(note-package-fishiness
:shadow-imported (package-name package) name
(symbol-package-name existing) status shadowing)
- (shadowing-import dummy package)
- (import dummy package)))))))
- (shadow name package))
+ (shadowing-import* dummy package)
+ (import* dummy package)))))))
+ (shadow* name package))
(loop :for (p . syms) :in shadowing-import-from
:for pp = (find-package* p) :do
(dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported)))
(pushnew :gcl2.6 *features*))
(t
(pushnew :gcl2.7 *features*))))
+
+;; Compatibility with whoever calls asdf/package
+(define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package))
;;;; -------------------------------------------------------------------------
;;;; Handle compatibility with multiple implementations.
;;; This file is for papering over the deficiencies and peculiarities
;;; A few functions are defined here, but actually exported from utility;
;;; from this package only common-lisp symbols are exported.
-(asdf/package:define-package :asdf/common-lisp
- (:nicknames :asdf/cl)
- (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package)
+(uiop/package:define-package :uiop/common-lisp
+ (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl)
+ (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package)
(:reexport :common-lisp)
- (:recycle :asdf/common-lisp :asdf)
+ (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf)
#+allegro (:intern #:*acl-warn-save*)
#+cormanlisp (:shadow #:user-homedir-pathname)
#+cormanlisp
#+genera (:shadowing-import-from :scl #:boolean)
#+genera (:export #:boolean #:ensure-directories-exist)
#+mcl (:shadow #:user-homedir-pathname))
-(in-package :asdf/common-lisp)
+(in-package :uiop/common-lisp)
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
(error "ASDF is not supported on your implementation. Please help us port it.")
#+gcl2.6
(eval-when (:compile-toplevel :load-toplevel :execute)
- (shadow 'type-of :asdf/common-lisp)
- (shadowing-import 'system:*load-pathname* :asdf/common-lisp))
+ (shadow 'type-of :uiop/common-lisp)
+ (shadowing-import 'system:*load-pathname* :uiop/common-lisp))
#+gcl2.6
(eval-when (:compile-toplevel :load-toplevel :execute)
- (export 'type-of :asdf/common-lisp)
- (export 'system:*load-pathname* :asdf/common-lisp))
+ (export 'type-of :uiop/common-lisp)
+ (export 'system:*load-pathname* :uiop/common-lisp))
#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
(eval-when (:load-toplevel :compile-toplevel :execute)
;;;; compatfmt: avoid fancy format directives when unsupported
(eval-when (:load-toplevel :compile-toplevel :execute)
- (defun remove-substrings (substrings string)
+ (defun frob-substrings (string substrings &optional frob)
+ (declare (optimize (speed 0) (safety 3) (debug 3)))
(let ((length (length string)) (stream nil))
- (labels ((emit (start end)
- (when (and (zerop start) (= end length))
- (return-from remove-substrings string))
+ (labels ((emit-string (x &optional (start 0) (end (length x)))
(when (< start end)
(unless stream (setf stream (make-string-output-stream)))
- (write-string string stream :start start :end end)))
+ (write-string x stream :start start :end end)))
+ (emit-substring (start end)
+ (when (and (zerop start) (= end length))
+ (return-from frob-substrings string))
+ (emit-string string start end))
(recurse (substrings start end)
(cond
((>= start end))
- ((null substrings) (emit start end))
- (t (let* ((sub (first substrings))
+ ((null substrings) (emit-substring start end))
+ (t (let* ((sub-spec (first substrings))
+ (sub (if (consp sub-spec) (car sub-spec) sub-spec))
+ (fun (if (consp sub-spec) (cdr sub-spec) frob))
(found (search sub string :start2 start :end2 end))
(more (rest substrings)))
(cond
(found
(recurse more start found)
+ (etypecase fun
+ (null)
+ (string (emit-string fun))
+ (function (funcall fun sub #'emit-string)))
(recurse substrings (+ found (length sub)) end))
(t
(recurse more start end))))))))
(defmacro compatfmt (format)
#+(or gcl genera)
- (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format)
+ (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
#-(or gcl genera) format))
;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities for ASDF
-(asdf/package:define-package :asdf/utility
- (:recycle :asdf/utility :asdf)
- (:use :asdf/common-lisp :asdf/package)
+(uiop/package:define-package :uiop/utility
+ (:nicknames :asdf/utility)
+ (:recycle :uiop/utility :asdf/utility :asdf)
+ (:use :uiop/common-lisp :uiop/package)
;; import and reexport a few things defined in :asdf/common-lisp
- (:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings
+ (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
- (:export #:compatfmt #:loop* #:remove-substrings #:compatfmt
+ (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
#+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
(:export
;; magic helper to define debugging functions:
- #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility*
+ #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility*
#:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions
#:if-let ;; basic flow control
- #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists
+ #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists
+ #:remove-plist-keys #:remove-plist-key ;; plists
#:emptyp ;; sequences
- #:strcat #:first-char #:last-char #:split-string ;; strings
+ #:+non-base-chars-exist-p+ ;; characters
+ #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings
+ #:first-char #:last-char #:split-string
#:string-prefix-p #:string-enclosed-p #:string-suffix-p
#:find-class* ;; CLOS
#:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps
#:call-function #:call-functions #:register-hook-function
#:match-condition-p #:match-any-condition-p ;; conditions
#:call-with-muffled-conditions #:with-muffled-conditions
- #:load-string #:load-stream
#:lexicographic< #:lexicographic<=
#:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
-(in-package :asdf/utility)
+(in-package :uiop/utility)
;;;; Defining functions in a way compatible with hot-upgrade:
;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition,
;;; Magic debugging help. See contrib/debug.lisp
(with-upgradability ()
- (defvar *asdf-debug-utility*
+ (defvar *uiop-debug-utility*
'(or (ignore-errors
- (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib/debug.lisp"))
- (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
+ (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp"))
+ (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp"))
"form that evaluates to the pathname to your favorite debugging utilities")
- (defmacro asdf-debug (&rest keys)
+ (defmacro uiop-debug (&rest keys)
`(eval-when (:compile-toplevel :load-toplevel :execute)
- (load-asdf-debug-utility ,@keys)))
+ (load-uiop-debug-utility ,@keys)))
- (defun load-asdf-debug-utility (&key package utility-file)
+ (defun load-uiop-debug-utility (&key package utility-file)
(let* ((*package* (if package (find-package package) *package*))
(keyword (read-from-string
(format nil ":DBG-~:@(~A~)" (package-name *package*)))))
(unless (member keyword *features*)
- (let* ((utility-file (or utility-file *asdf-debug-utility*))
+ (let* ((utility-file (or utility-file *uiop-debug-utility*))
(file (ignore-errors (probe-file (eval utility-file)))))
(if file (load file)
(error "Failed to locate debug utility file: ~S" utility-file)))))))
:for i :downfrom n :do
(cond
((zerop i) (return (null l)))
- ((not (consp l)) (return nil))))))
+ ((not (consp l)) (return nil)))))
+
+ (defun ensure-list (x)
+ (if (listp x) x (list x))))
+
;;; remove a key from a plist, i.e. for keyword argument cleanup
(with-upgradability ()
(or (null x) (and (vectorp x) (zerop (length x))))))
+;;; Characters
+(with-upgradability ()
+ (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char)))
+ (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
+
+
;;; Strings
(with-upgradability ()
+ (defun base-string-p (string)
+ (declare (ignorable string))
+ (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string))))
+
+ (defun strings-common-element-type (strings)
+ (declare (ignorable strings))
+ #-non-base-chars-exist-p 'character
+ #+non-base-chars-exist-p
+ (if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s)))
+ 'base-char 'character))
+
+ (defun reduce/strcat (strings &key key start end)
+ "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE.
+NIL is interpreted as an empty string. A character is interpreted as a string of length one."
+ (when (or start end) (setf strings (subseq strings start end)))
+ (when key (setf strings (mapcar key strings)))
+ (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s)))
+ :element-type (strings-common-element-type strings))
+ :with pos = 0
+ :for input :in strings
+ :do (etypecase input
+ (null)
+ (character (setf (char output pos) input) (incf pos))
+ (string (replace output input :start1 pos) (incf pos (length input))))
+ :finally (return output)))
+
(defun strcat (&rest strings)
- (apply 'concatenate 'string strings))
+ (reduce/strcat strings))
(defun first-char (s)
(and (stringp s) (plusp (length s)) (char s 0)))
(loop
:for start = (if (and max (>= words (1- max)))
(done)
- (position-if #'separatorp string :end end :from-end t)) :do
- (when (null start)
- (done))
- (push (subseq string (1+ start) end) list)
- (incf words)
- (setf end start))))))
+ (position-if #'separatorp string :end end :from-end t))
+ :do (when (null start) (done))
+ (push (subseq string (1+ start) end) list)
+ (incf words)
+ (setf end start))))))
(defun string-prefix-p (prefix string)
"Does STRING begin with PREFIX?"
;;; Condition control
(with-upgradability ()
- (defvar *uninteresting-conditions* nil
- "Uninteresting conditions, as per MATCH-CONDITION-P")
-
(defparameter +simple-condition-format-control-slot+
#+abcl 'system::format-control
#+allegro 'excl::format-control
or a string describing the format-control of a simple-condition."
(etypecase x
(symbol (typep condition x))
- ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
+ ((simple-vector 2)
+ (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil))))
(function (funcall x condition))
(string (and (typep condition 'simple-condition)
;; On SBCL, it's always set and the check triggers a warning
(muffle-warning c)))))
(funcall thunk)))
- (defmacro with-muffled-uninteresting-conditions ((conditions) &body body)
- `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions)))
+ (defmacro with-muffled-conditions ((conditions) &body body)
+ `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions)))
;;;; ---------------------------------------------------------------------------
;;;; Access to the Operating System
-(asdf/package:define-package :asdf/os
- (:recycle :asdf/os :asdf)
- (:use :asdf/common-lisp :asdf/package :asdf/utility)
+(uiop/package:define-package :uiop/os
+ (:nicknames :asdf/os)
+ (:recycle :uiop/os :asdf/os :asdf)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility)
(:export
#:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features
#:getenv #:getenvp ;; environment variables
;; Windows shortcut support
#:read-null-terminated-string #:read-little-endian
#:parse-file-location-info #:parse-windows-shortcut))
-(in-package :asdf/os)
+(in-package :uiop/os)
;;; Features
(with-upgradability ()
(defun os-windows-p ()
(or #+abcl (featurep :windows)
- #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
+ #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
(defun os-genera-p ()
(or #+genera t))
+ (defun os-oldmac-p ()
+ (or #+mcl t))
+
(defun detect-os ()
- (flet ((yes (yes) (pushnew yes *features*))
- (no (no) (setf *features* (remove no *features*))))
- (cond
- ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera))
- ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera))
- ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera))
- (t (error "Congratulations for trying XCVB on an operating system~%~
-that is neither Unix, nor Windows, nor even Genera.~%Now you port it.")))))
+ (loop* :with o
+ :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p)
+ (:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
+ :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*)
+ :else :do (setf *features* (remove feature *features*))
+ :finally
+ (return (or o (error "Congratulations for trying ASDF on an operating system~%~
+that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it.")))))
(detect-os))
(with-upgradability ()
(defun hostname ()
;; Note: untested on RMCL
- #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
+ #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
#+cormanlisp "localhost" ;; is there a better way? Does it matter?
#+allegro (symbol-call :excl.osi :gethostname)
#+clisp (first (split-string (machine-instance) :separator " "))
#+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return?
#+ecl (ext:getcwd)
#+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
- (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines)))
+ (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines)))
#+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
#+lispworks (system:current-directory)
#+mkcl (mk-ext:getcwd)
;;;; Jesse Hager: The Windows Shortcut File Format.
;;;; http://www.wotsit.org/list.asp?fc=13
-(with-upgradability ()
- #-(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 (c)
- (declare (ignore c))
- nil))))))
+#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera.
+(with-upgradability ()
+ (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 (c)
+ (declare (ignore c))
+ nil)))))
;;;; -------------------------------------------------------------------------
;; This layer allows for portable manipulation of pathname objects themselves,
;; which all is necessary prior to any access the filesystem or environment.
-(asdf/package:define-package :asdf/pathname
- (:recycle :asdf/pathname :asdf)
- (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os)
+(uiop/package:define-package :uiop/pathname
+ (:nicknames :asdf/pathname)
+ (:recycle :uiop/pathname :asdf/pathname :asdf)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os)
(:export
;; Making and merging pathnames, portably
#:normalize-pathname-directory-component #:denormalize-pathname-directory-component
#:directory-separator-for-host #:directorize-pathname-host-device
#:translate-pathname*
#:*output-translation-function*))
-(in-package :asdf/pathname)
+(in-package :uiop/pathname)
;;; Normalizing pathnames across implementations
"Takes arguments like CL:MAKE-PATHNAME in the CLHS, and
tries hard to make a pathname that will actually behave as documented,
despite the peculiarities of each implementation"
+ ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults.
(declare (ignorable host device directory name type version defaults))
(apply 'make-pathname
(append
;; see also "valid physical pathname host" in the CLHS glossary, that suggests
;; strings and lists of strings or :unspecific
;; But CMUCL decides to die on NIL.
+ ;; MCL has issues with make-pathname, nil and defaulting
+ (declare (ignorable defaults))
#.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil
:host (or #+cmu lisp::*unix-host*)
#+scl ,@'(:scheme nil :scheme-specific-part nil
:username nil :password nil :parameters nil :query nil :fragment nil)
;; the default shouldn't matter, but we really want something physical
- :defaults defaults))
+ #-mcl ,@'(:defaults defaults)))
(defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname))))
(make-pathname*
:directory (unless file-only (cons relative path))
:name name :type type
- :defaults (or defaults *nil-pathname*))
+ :defaults (or #-mcl defaults *nil-pathname*))
(remove-plist-keys '(:type :dot-dot :defaults) keys))))))
(defun unix-namestring (pathname)
(t
(translate-pathname path absolute-source destination))))
- (defvar *output-translation-function* 'identity)) ; Hook for output translations
+ (defvar *output-translation-function* 'identity
+ "Hook for output translations.
+This function needs to be idempotent, so that actions can work
+whether their inputs were translated or not,
+which they will be if we are composing operations. e.g. if some
+create-lisp-op creates a lisp file from some higher-level input,
+you need to still be able to use compile-op on that lisp file."))
;;;; -------------------------------------------------------------------------
;;;; Portability layer around Common Lisp filesystem access
-(asdf/package:define-package :asdf/filesystem
- (:recycle :asdf/pathname :asdf)
- (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname)
+(uiop/package:define-package :uiop/filesystem
+ (:nicknames :asdf/filesystem)
+ (:recycle :uiop/filesystem :asdf/pathname :asdf)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
(:export
;; Native namestrings
#:native-namestring #:parse-native-namestring
;; Probing the filesystem
- #:truename* #:safe-file-write-date #:probe-file*
+ #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p
#:directory* #:filter-logical-directory-results #:directory-files #:subdirectories
#:collect-sub*directories
;; Resolving symlinks somewhat
;; Simple filesystem operations
#:ensure-all-directories-exist
#:rename-file-overwriting-target
- #:delete-file-if-exists))
-(in-package :asdf/filesystem)
+ #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree))
+(in-package :uiop/filesystem)
;;; Native namestrings, as seen by the operating system calls rather than Lisp
(with-upgradability ()
(null nil)
(string (probe-file* (parse-namestring p) :truename truename))
(pathname
- (handler-case
- (or
- #+allegro
- (probe-file p :follow-symlinks truename)
- #-(or allegro clisp gcl2.6)
- (if truename
- (probe-file p)
- (and (not (wild-pathname-p p))
+ (and (not (wild-pathname-p p))
+ (handler-case
+ (or
+ #+allegro
+ (probe-file p :follow-symlinks truename)
+ #-(or allegro clisp gcl2.6)
+ (if truename
+ (probe-file p)
(ignore-errors
(let ((pp (translate-logical-pathname p)))
- #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
- #+(and lispworks unix) (system:get-file-stat pp)
- #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
- #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)))
- p))
- #+(or clisp gcl2.6)
- #.(flet ((probe (probe)
- `(let ((foundtrue ,probe))
- (cond
- (truename foundtrue)
- (foundtrue p)))))
- #+gcl2.6
- (probe '(or (probe-file p)
- (and (directory-pathname-p p)
- (ignore-errors
- (ensure-directory-pathname
- (truename* (subpathname
- (ensure-directory-pathname p) ".")))))))
- #+clisp
- (let* ((fs (find-symbol* '#:file-stat :posix nil))
- (pp (find-symbol* '#:probe-pathname :ext nil))
- (resolve (if pp
- `(ignore-errors (,pp p))
- '(or (truename* p)
- (truename* (ignore-errors (ensure-directory-pathname p)))))))
- (if fs
- `(if truename
- ,resolve
- (and (ignore-errors (,fs p)) p))
- (probe resolve)))))
- (file-error () nil))))))
+ (and
+ #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp))
+ #+(and lispworks unix) (system:get-file-stat pp)
+ #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp))
+ #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp)
+ p))))
+ #+(or clisp gcl2.6)
+ #.(flet ((probe (probe)
+ `(let ((foundtrue ,probe))
+ (cond
+ (truename foundtrue)
+ (foundtrue p)))))
+ #+gcl2.6
+ (probe '(or (probe-file p)
+ (and (directory-pathname-p p)
+ (ignore-errors
+ (ensure-directory-pathname
+ (truename* (subpathname
+ (ensure-directory-pathname p) ".")))))))
+ #+clisp
+ (let* ((fs (find-symbol* '#:file-stat :posix nil))
+ (pp (find-symbol* '#:probe-pathname :ext nil))
+ (resolve (if pp
+ `(ignore-errors (,pp p))
+ '(or (truename* p)
+ (truename* (ignore-errors (ensure-directory-pathname p)))))))
+ (if fs
+ `(if truename
+ ,resolve
+ (and (ignore-errors (,fs p)) p))
+ (probe resolve)))))
+ (file-error () nil)))))))
+
+ (defun directory-exists-p (x)
+ (let ((p (probe-file* x :truename t)))
+ (and (directory-pathname-p p) p)))
+
+ (defun file-exists-p (x)
+ (let ((p (probe-file* x :truename t)))
+ (and (file-pathname-p p) p)))
(defun directory* (pathname-spec &rest keys &key &allow-other-keys)
(apply 'directory pathname-spec
(append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil)
- #+clozure '(:follow-links nil)
+ #+(or clozure digitool) '(:follow-links nil)
#+clisp '(:circle t :if-does-not-exist :ignore)
#+(or cmu scl) '(:follow-links nil :truenamep nil)
#+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil)
(unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
(error "Invalid file pattern ~S for logical directory ~S" pattern directory))
(setf pattern (make-pathname-logical pattern (pathname-host dir))))
- (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
+ (let* ((pat (merge-pathnames* pattern dir))
+ (entries (append (ignore-errors (directory* pat))
+ #+clisp
+ (when (equal :wild (pathname-type pattern))
+ (ignore-errors (directory* (make-pathname :type nil :defaults pat)))))))
(filter-logical-directory-results
directory entries
#'(lambda (f)
:directory (append prefix (make-pathname-component-logical (last dir)))))))))))
(defun collect-sub*directories (directory collectp recursep collector)
- (when (funcall collectp directory)
- (funcall collector directory))
+ (when (call-function collectp directory)
+ (call-function collector directory))
(dolist (subdir (subdirectories directory))
- (when (funcall recursep subdir)
+ (when (call-function recursep subdir)
(collect-sub*directories subdir collectp recursep collector)))))
;;; Resolving symlinks somewhat
(check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname")
(check want-relative (relative-pathname-p p) "Expected a relative pathname")
(check want-absolute (absolute-pathname-p p) "Expected an absolute pathname")
- (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults))
+ (transform ensure-absolute (not (absolute-pathname-p p))
+ (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?")))
(check ensure-absolute (absolute-pathname-p p)
"Could not make into an absolute pathname even after merging with ~S" defaults)
(check ensure-subpath (absolute-pathname-p defaults)
(loop :for namestring :in (split-string string :separator (string (inter-directory-separator)))
:collect (apply 'parse-native-namestring namestring constraints)))
- (defun getenv-pathname (x &rest constraints &key on-error &allow-other-keys)
+ (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys)
+ ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory
(apply 'parse-native-namestring (getenvp x)
+ :ensure-directory (or ensure-directory want-directory)
:on-error (or on-error
`(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x))
constraints))
(with-upgradability ()
(defun ensure-all-directories-exist (pathnames)
(dolist (pathname pathnames)
- (ensure-directories-exist (translate-logical-pathname pathname))))
+ (when pathname
+ (ensure-directories-exist (translate-logical-pathname pathname)))))
(defun rename-file-overwriting-target (source target)
#+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic
#+clozure :if-exists #+clozure :rename-and-delete))
(defun delete-file-if-exists (x)
- (when x (handler-case (delete-file x) (file-error () nil)))))
-
+ (when x (handler-case (delete-file x) (file-error () nil))))
+
+ (defun delete-empty-directory (directory-pathname)
+ "Delete an empty directory"
+ #+(or abcl digitool gcl) (delete-file directory-pathname)
+ #+allegro (excl:delete-directory directory-pathname)
+ #+clisp (ext:delete-directory directory-pathname)
+ #+clozure (ccl::delete-empty-directory directory-pathname)
+ #+(or cmu scl) (multiple-value-bind (ok errno)
+ (unix:unix-rmdir (native-namestring directory-pathname))
+ (unless ok
+ #+cmu (error "Error number ~A when trying to delete directory ~A"
+ errno directory-pathname)
+ #+scl (error "~@<Error deleting ~S: ~A~@:>"
+ directory-pathname (unix:get-unix-error-msg errno))))
+ #+cormanlisp (win32:delete-directory directory-pathname)
+ #+ecl (si:rmdir directory-pathname)
+ #+lispworks (lw:delete-directory directory-pathname)
+ #+mkcl (mkcl:rmdir directory-pathname)
+ #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
+ `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later
+ `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname)))
+ #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl)
+ (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera xcl
+
+ (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error))
+ "Delete a directory including all its recursive contents, aka rm -rf.
+
+To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be
+a physical non-wildcard directory pathname (not namestring).
+
+If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens:
+if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done.
+
+Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass
+the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument
+which in practice is thus compulsory, and validates by returning a non-NIL result.
+If you're suicidal or extremely confident, just use :VALIDATE T."
+ (check-type if-does-not-exist (member :error :ignore))
+ (cond
+ ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname)
+ (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname))))
+ (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname"
+ 'delete-filesystem-tree directory-pathname))
+ ((not validatep)
+ (error "~S was asked to delete ~S but was not provided a validation predicate"
+ 'delete-filesystem-tree directory-pathname))
+ ((not (call-function validate directory-pathname))
+ (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]"
+ 'delete-filesystem-tree directory-pathname validate))
+ ((not (directory-exists-p directory-pathname))
+ (ecase if-does-not-exist
+ (:error
+ (error "~S was asked to delete ~S but the directory does not exist"
+ 'delete-filesystem-tree directory-pathname))
+ (:ignore nil)))
+ #-(or allegro cmu clozure sbcl scl)
+ ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp,
+ ;; except on implementations where we can prevent DIRECTORY from following symlinks;
+ ;; instead spawn a standard external program to do the dirty work.
+ (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname))))
+ (t
+ ;; On supported implementation, call supported system functions
+ #+allegro (symbol-call :excl.osi :delete-directory-and-files
+ directory-pathname :if-does-not-exist if-does-not-exist)
+ #+clozure (ccl:delete-directory directory-pathname)
+ #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type))
+ #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil))
+ `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later
+ '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree))
+ ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks,
+ ;; do things the hard way.
+ #-(or allegro clozure genera sbcl)
+ (let ((sub*directories
+ (while-collecting (c)
+ (collect-sub*directories directory-pathname t t #'c))))
+ (dolist (d (nreverse sub*directories))
+ (map () 'delete-file (directory-files d))
+ (delete-empty-directory d)))))))
;;;; ---------------------------------------------------------------------------
;;;; Utilities related to streams
-(asdf/package:define-package :asdf/stream
- (:recycle :asdf/stream)
- (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname :asdf/filesystem)
+(uiop/package:define-package :uiop/stream
+ (:nicknames :asdf/stream)
+ (:recycle :uiop/stream :asdf/stream :asdf)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
(:export
#:*default-stream-element-type* #:*stderr* #:setup-stderr
#:detect-encoding #:*encoding-detection-hook* #:always-default-encoding
#:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
#:*default-encoding* #:*utf-8-external-format*
- #:with-safe-io-syntax #:call-with-safe-io-syntax
+ #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
#:with-output #:output-string #:with-input
- #:with-input-file #:call-with-input-file
+ #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file
#:finish-outputs #:format! #:safe-format!
- #:copy-stream-to-stream #:concatenate-files
- #:copy-stream-to-stream-line-by-line
+ #:copy-stream-to-stream #:concatenate-files #:copy-file
#:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line
#:slurp-stream-forms #:slurp-stream-form
#:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form
#:call-with-temporary-file #:with-temporary-file
#:add-pathname-suffix #:tmpize-pathname
#:call-with-staging-pathname #:with-staging-pathname))
-(in-package :asdf/stream)
+(in-package :uiop/stream)
(with-upgradability ()
(defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default)
;;; Encodings (mostly hooks only; full support requires asdf-encodings)
(with-upgradability ()
- (defvar *default-encoding* :default
+ (defparameter *default-encoding*
+ ;; preserve explicit user changes to something other than the legacy default :default
+ (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*)))
+ (unless (eq previous :default) previous))
+ :utf-8)
"Default encoding for source files.
-The default value :default preserves the legacy behavior.
-A future default might be :utf-8 or :autodetect
+The default value :utf-8 is the portable thing.
+The legacy behavior was :default.
+If you (asdf:load-system :asdf-encodings) then
+you will have autodetection via *encoding-detection-hook* below,
reading emacs-style -*- coding: utf-8 -*- specifications,
and falling back to utf-8 or latin1 if nothing is specified.")
and implementation-defined external-format's")
(defun encoding-external-format (encoding)
- (funcall *encoding-external-format-hook* encoding)))
+ (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
;;; Safe syntax
(*read-default-float-format* 'double-float)
(*print-readably* nil)
(*read-eval* nil))
- (funcall thunk)))))
+ (funcall thunk))))
+
+ (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
+ (with-safe-io-syntax (:package package)
+ (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
;;; Output to a stream or string, FORMAT-style
:if-does-not-exist if-does-not-exist)
(funcall thunk s)))
- (defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body)
- (declare (ignore element-type external-format))
- `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
+ (defmacro with-input-file ((var pathname &rest keys
+ &key element-type external-format if-does-not-exist)
+ &body body)
+ (declare (ignore element-type external-format if-does-not-exist))
+ `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))
+
+ (defun call-with-output-file (pathname thunk
+ &key
+ (element-type *default-stream-element-type*)
+ (external-format *utf-8-external-format*)
+ (if-exists :error)
+ (if-does-not-exist :create))
+ "Open FILE for input with given recognizes options, call THUNK with the resulting stream.
+Other keys are accepted but discarded."
+ #+gcl2.6 (declare (ignore external-format))
+ (with-open-file (s pathname :direction :output
+ :element-type element-type
+ #-gcl2.6 :external-format #-gcl2.6 external-format
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)
+ (funcall thunk s)))
+ (defmacro with-output-file ((var pathname &rest keys
+ &key element-type external-format if-exists if-does-not-exist)
+ &body body)
+ (declare (ignore element-type external-format if-exists if-does-not-exist))
+ `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys)))
;;; Ensure output buffers are flushed
(with-upgradability ()
:direction :input :if-does-not-exist :error)
(copy-stream-to-stream i o :element-type '(unsigned-byte 8))))))
+ (defun copy-file (input output)
+ ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f)
+ (concatenate-files (list input) output))
+
(defun slurp-stream-string (input &key (element-type 'character))
"Read the contents of the INPUT stream as a string"
(with-open-stream (input input)
#+gcl2.6 (declare (ignorable external-format))
(check-type direction (member :output :io))
(loop
- :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory))))
+ :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory))
:for counter :from (random (ash 1 32))
:for pathname = (pathname (format nil "~A~36R" prefix counter)) :do
;; TODO: on Unix, do something about umask
;;;; -------------------------------------------------------------------------
;;;; Starting, Stopping, Dumping a Lisp image
-(asdf/package:define-package :asdf/image
- (:recycle :asdf/image :xcvb-driver)
- (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream :asdf/os)
+(uiop/package:define-package :uiop/image
+ (:nicknames :asdf/image)
+ (:recycle :uiop/image :asdf/image :xcvb-driver)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
(:export
#:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
#:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments
#:*lisp-interaction*
- #:fatal-conditions #:fatal-condition-p #:handle-fatal-condition
+ #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition
#:call-with-fatal-condition-handler #:with-fatal-condition-handler
#:*image-restore-hook* #:*image-prelude* #:*image-entry-point*
#:*image-postlude* #:*image-dump-hook*
#:shell-boolean-exit
#:register-image-restore-hook #:register-image-dump-hook
#:call-image-restore-hook #:call-image-dump-hook
- #:initialize-asdf-utilities #:restore-image #:dump-image #:create-image
+ #:restore-image #:dump-image #:create-image
))
-(in-package :asdf/image)
+(in-package :uiop/image)
(with-upgradability ()
(defvar *lisp-interaction* t
(defvar *image-restore-hook* nil
"Functions to call (in reverse order) when the image is restored")
+ (defvar *image-restored-p* nil
+ "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping")
+
(defvar *image-prelude* nil
"a form to evaluate, or string containing forms to read and evaluate
when the image is restarted, but before the entry point is called.")
#+gcl (lisp:quit code)
#+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code)
#+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t)
- #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ?
+ #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ?
#+mkcl (mk-ext:quit :exit-code code)
#+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil))
(quit (find-symbol* :quit :sb-ext nil)))
"Die in error with some error message"
(with-safe-io-syntax ()
(ignore-errors
- (fresh-line *stderr*)
- (apply #'format *stderr* format arguments)
- (format! *stderr* "~&")))
+ (format! *stderr* "~&~?~&" format arguments)))
(quit code))
(defun raw-print-backtrace (&key (stream *debug-io*) count)
(system::print-backtrace :out stream :limit count)
#+(or clozure mcl)
(let ((*debug-io* stream))
- (ccl:print-call-history :count count :start-frame-number 1)
+ #+clozure (ccl:print-call-history :count count :start-frame-number 1)
+ #+mcl (ccl:print-call-history :detailed-p nil)
(finish-output stream))
- #+(or cmucl scl)
+ #+(or cmu scl)
(let ((debug:*debug-print-level* *print-level*)
(debug:*debug-print-length* *print-length*))
(debug:backtrace most-positive-fixnum stream))
#+(or cmu scl) extensions:*command-line-strings*
#+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i))
#+gcl si:*command-args*
- #+genera nil
+ #+(or genera mcl) nil
#+lispworks sys:*line-arguments-list*
#+sbcl sb-ext:*posix-argv*
#+xcl system:*argv*
- #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl)
+ #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl)
(error "raw-command-line-arguments not implemented yet"))
(defun command-line-arguments (&optional (arguments (raw-command-line-arguments)))
((:lisp-interaction *lisp-interaction*) *lisp-interaction*)
((:restore-hook *image-restore-hook*) *image-restore-hook*)
((:prelude *image-prelude*) *image-prelude*)
- ((:entry-point *image-entry-point*) *image-entry-point*))
+ ((:entry-point *image-entry-point*) *image-entry-point*)
+ (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY")))
+ (when *image-restored-p*
+ (if if-already-restored
+ (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t))
+ (return-from restore-image)))
(with-fatal-condition-handler ()
+ (setf *image-restored-p* :in-progress)
(call-image-restore-hook)
(standard-eval-thunk *image-prelude*)
+ (setf *image-restored-p* t)
(let ((results (multiple-value-list
(if *image-entry-point*
(call-function *image-entry-point*)
;;; Dumping an image
(with-upgradability ()
- #-(or ecl mkcl)
(defun dump-image (filename &key output-name executable
((:postlude *image-postlude*) *image-postlude*)
- ((:dump-hook *image-dump-hook*) *image-dump-hook*))
+ ((:dump-hook *image-dump-hook*) *image-dump-hook*)
+ #+clozure prepend-symbols #+clozure (purify t))
(declare (ignorable filename output-name executable))
(setf *image-dumped-p* (if executable :executable t))
+ (setf *image-restored-p* :in-regress)
(standard-eval-thunk *image-postlude*)
(call-image-dump-hook)
+ (setf *image-restored-p* nil)
#-(or clisp clozure cmu lispworks sbcl scl)
(when executable
(error "Dumping an executable is not supported on this implementation! Aborting."))
;; :parse-options nil ;--- requires a non-standard patch to clisp.
:norc t :script nil :init-function #'restore-image)))
#+clozure
- (ccl:save-application filename :prepend-kernel t
- :toplevel-function (when executable #'restore-image))
+ (flet ((dump (prepend-kernel)
+ (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify
+ :toplevel-function (when executable #'restore-image))))
+ ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system))
+ (if prepend-symbols
+ (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path)
+ (require 'elf)
+ (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path)
+ (dump path))
+ (dump t)))
#+(or cmu scl)
(progn
(ext:gc :full t)
:executable t ;--- always include the runtime that goes with the core
(when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
#-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
- (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%"
- filename (nth-value 1 (implementation-type))))
-
+ (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%"
+ 'dump-image filename (nth-value 1 (implementation-type))))
- #+ecl
(defun create-image (destination object-files
&key kind output-name prologue-code epilogue-code
- (prelude () preludep) (entry-point () entry-point-p) build-args)
+ (prelude () preludep) (postlude () postludep)
+ (entry-point () entry-point-p) build-args)
+ (declare (ignorable destination object-files kind output-name prologue-code epilogue-code
+ prelude preludep postlude postludep entry-point entry-point-p build-args))
;; Is it meaningful to run these in the current environment?
;; only if we also track the object files that constitute the "current" image,
;; and otherwise simulate dump-image, including quitting at the end.
- ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook)
- (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
- (apply 'c::builder
- kind (pathname destination)
- :lisp-files object-files
- :init-name (c::compute-init-name (or output-name destination) :kind kind)
- :prologue-code prologue-code
- :epilogue-code
- `(progn
- ,epilogue-code
- ,@(when (eq kind :program)
- `((setf *image-dumped-p* :executable)
- (restore-image ;; default behavior would be (si::top-level)
- ,@(when preludep `(:prelude ',prelude))
- ,@(when entry-point-p `(:entry-point ',entry-point))))))
- build-args)))
+ #-ecl (error "~S not implemented for your implementation (yet)" 'create-image)
+ #+ecl
+ (progn
+ (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program))
+ (apply 'c::builder
+ kind (pathname destination)
+ :lisp-files object-files
+ :init-name (c::compute-init-name (or output-name destination) :kind kind)
+ :prologue-code prologue-code
+ :epilogue-code
+ `(progn
+ ,epilogue-code
+ ,@(when (eq kind :program)
+ `((setf *image-dumped-p* :executable)
+ (restore-image ;; default behavior would be (si::top-level)
+ ,@(when preludep `(:prelude ',prelude))
+ ,@(when entry-point-p `(:entry-point ',entry-point))))))
+ build-args))))
;;; Some universal image restore hooks
;;;; -------------------------------------------------------------------------
;;;; run-program initially from xcvb-driver.
-(asdf/package:define-package :asdf/run-program
- (:recycle :asdf/run-program :xcvb-driver)
- (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/filesystem :asdf/stream)
+(uiop/package:define-package :uiop/run-program
+ (:nicknames :asdf/run-program)
+ (:recycle :uiop/run-program :asdf/run-program :xcvb-driver)
+ (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
(:export
;;; Escaping the command invocation madness
#:easy-sh-character-p #:escape-sh-token #:escape-sh-command
#:subprocess-error
#:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
))
-(in-package :asdf/run-program)
+(in-package :uiop/run-program)
;;;; ----- Escaping strings for the shell -----
(declare (ignorable x))
(slurp-stream-form stream :at at))
+ (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys)
+ (declare (ignorable x))
+ (apply 'slurp-input-stream *standard-output* stream keys))
+
+ (defmethod slurp-input-stream ((pathname pathname) input
+ &key
+ (element-type *default-stream-element-type*)
+ (external-format *utf-8-external-format*)
+ (if-exists :rename-and-delete)
+ (if-does-not-exist :create)
+ buffer-size
+ linewise)
+ (with-output-file (output pathname
+ :element-type element-type
+ :external-format external-format
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)
+ (copy-stream-to-stream
+ input output
+ :element-type element-type :buffer-size buffer-size :linewise linewise)))
+
(defmethod slurp-input-stream (x stream
&key linewise prefix (element-type 'character) buffer-size
&allow-other-keys)
&allow-other-keys)
"Run program specified by COMMAND,
either a list of strings specifying a program and list of arguments,
-or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows);
-have its output processed by the OUTPUT processor function
-as per SLURP-INPUT-STREAM,
-or merely output to the inherited standard output if it's NIL.
+or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows).
+
Always call a shell (rather than directly execute the command)
if FORCE-SHELL is specified.
-Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS
-is specified.
-Return the exit status code of the process that was called.
-Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
+
+Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0),
+unless IGNORE-ERROR-STATUS is specified.
+
+If OUTPUT is either NIL or :INTERACTIVE, then
+return the exit status code of the process that was called.
+if it was NIL, the output is discarded;
+if it was :INTERACTIVE, the output and the input are inherited from the current process.
+
+Otherwise, OUTPUT should be a value that is a suitable first argument to
+SLURP-INPUT-STREAM. In this case, RUN-PROGRAM will create a temporary stream
+for the program output. The program output, in that stream, will be processed
+by SLURP-INPUT-STREAM, according to the using OUTPUT as the first argument.
+RUN-PROGRAM will return whatever SLURP-INPUT-STREAM returns. E.g., using
+:OUTPUT :STRING will have it return the entire output stream as a string. Use
+ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor."
+
+ ;; TODO: The current version does not honor :OUTPUT NIL on Allegro. Setting
+ ;; the :INPUT and :OUTPUT arguments to RUN-SHELL-COMMAND on ACL actually do
+ ;; what :OUTPUT :INTERACTIVE is advertised to do here. To get the behavior
+ ;; specified for :OUTPUT NIL, one would have to grab up the process output
+ ;; into a stream and then throw it on the floor. The consequences of
+ ;; getting this wrong seemed so much worse than having excess output that it
+ ;; is not currently implemented.
+
+ ;; TODO: specially recognize :output pathname ?
(declare (ignorable ignore-error-status element-type external-format))
#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl)
(error "RUN-PROGRAM not implemented for this Lisp")
(excl:run-shell-command
#+os-unix (coerce (cons (first command) command) 'vector)
#+os-windows command
- :input interactive :output (or (and pipe :stream) interactive) :wait wait
- #+os-windows :show-window #+os-windows (and pipe :hide))
+ :input nil
+ :output (and pipe :stream) :wait wait
+ #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide))
#+clisp
(flet ((run (f &rest args)
(apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output
;; note: :external-format requires a recent SBCL
#+sbcl '(:search t :external-format external-format)))))
(process
- #+(or allegro lispworks) (if pipe (third process*) (first process*))
+ #+allegro (if pipe (third process*) (first process*))
#+ecl (third process*)
- #-(or allegro lispworks ecl) (first process*))
+ #-(or allegro ecl) (first process*))
(stream
(when pipe
#+(or allegro lispworks ecl) (first process*)
#+clozure (nth-value 1 (ccl:external-process-status process))
#+(or cmu scl) (ext:process-exit-code process)
#+ecl (nth-value 1 (ext:external-process-status process))
- #+lispworks (if pipe (system:pid-exit-status process :wait t) process)
+ #+lispworks (if pipe (system:pipe-exit-status process :wait t) process)
#+sbcl (sb-ext:process-exit-code process))
(check-result (exit-code process)
#+clisp
(declare (ignorable interactive))
#+(or abcl xcl) (ext:run-shell-command command)
#+allegro
- (excl:run-shell-command command :input interactive :output interactive :wait t)
+ (excl:run-shell-command
+ command
+ :input nil
+ :output nil
+ :error-output :output ; write STDERR to output, too
+ :wait t
+ #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide))
#+(or clisp clozure cmu (and lispworks os-unix) sbcl scl)
(process-result (run-program command :pipe nil :interactive interactive) nil)
#+ecl (ext:system command)
#+gcl (lisp:system command)
#+(and lispworks os-windows)
(system:call-system-showing-output
- command :show-cmd interactive :prefix "" :output-stream nil)
+ command :show-cmd (or interactive (eq output t)) :prefix "" :output-stream nil)
#+mcl (ccl::with-cstrs ((%command command)) (_system %command))
#+mkcl (nth-value 2
(mkcl:run-program #+windows command #+windows ()
;;;; -------------------------------------------------------------------------
;;;; Support to build (compile and load) Lisp files
-(asdf/package:define-package :asdf/lisp-build
- (:recycle :asdf/interface :asdf :asdf/lisp-build)
- (:use :asdf/common-lisp :asdf/package :asdf/utility
- :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
+(uiop/package:define-package :uiop/lisp-build
+ (:nicknames :asdf/lisp-build)
+ (:recycle :uiop/lisp-build :asdf/lisp-build :asdf)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility
+ :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
(:export
;; Variables
#:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour*
#:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error
#:compile-warned-warning #:compile-failed-warning
#:check-lisp-compile-results #:check-lisp-compile-warnings
- #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
+ #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions*
+ ;; Types
+ #+sbcl #:sb-grovel-unknown-constant-condition
;; Functions & Macros
#:get-optimization-settings #:proclaim-optimization-settings
#:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
#:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
#:reify-simple-sexp #:unreify-simple-sexp
- #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings
+ #:reify-deferred-warnings #:unreify-deferred-warnings
#:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
#:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
+ #:enable-deferred-warnings-check #:disable-deferred-warnings-check
#:current-lisp-file-pathname #:load-pathname
#:lispize-pathname #:compile-file-type #:call-around-hook
#:compile-file* #:compile-file-pathname*
#:load* #:load-from-string #:combine-fasls)
(:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
-(in-package :asdf/lisp-build)
+(in-package :uiop/lisp-build)
(with-upgradability ()
(defvar *compile-file-warnings-behaviour*
(defvar *previous-optimization-settings* nil)
(defun get-optimization-settings ()
"Get current compiler optimization settings, ready to PROCLAIM again"
+ #-(or clisp clozure cmu ecl sbcl scl)
+ (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type))
+ #+clozure (ccl:declaration-information 'optimize nil)
+ #+(or clisp cmu ecl sbcl scl)
(let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
- #-(or clisp clozure cmu ecl sbcl scl)
- (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.")
#.`(loop :for x :in settings
- ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*))
- #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
+ ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
#+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
:for y = (or #+clisp (gethash x system::*optimize*)
- #+(or clozure ecl) (symbol-value v)
+ #+(or ecl) (symbol-value v)
#+(or cmu scl) (funcall f c::*default-cookie*)
#+sbcl (cdr (assoc x sb-c::*policy*)))
:when y :collect (list x y))))
(deftype sb-grovel-unknown-constant-condition ()
'(and style-warning (satisfies sb-grovel-unknown-constant-condition-p))))
- (defvar *uninteresting-compiler-conditions*
+ (defvar *usual-uninteresting-conditions*
(append
;;#+clozure '(ccl:compiler-warning)
#+cmu '("Deleting unreachable code.")
#+sbcl
'(sb-c::simple-compiler-note
"&OPTIONAL and &KEY found in the same lambda list: ~S"
- sb-int:package-at-variance
- sb-kernel:uninteresting-redefinition
- sb-kernel:undefined-alien-style-warning
- ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default.
#+sb-eval sb-kernel:lexical-environment-too-complex
+ sb-kernel:undefined-alien-style-warning
sb-grovel-unknown-constant-condition ; defined above.
+ sb-ext:implicit-generic-function-warning ;; Controversial.
+ sb-int:package-at-variance
+ sb-kernel:uninteresting-redefinition
;; BEWARE: the below four are controversial to include here.
sb-kernel:redefinition-with-defun
sb-kernel:redefinition-with-defgeneric
sb-kernel:redefinition-with-defmethod
sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs
'("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop
- "Conditions that may be skipped while compiling")
+ "A suggested value to which to set or bind *uninteresting-conditions*.")
+ (defvar *uninteresting-conditions* '()
+ "Conditions that may be skipped while compiling or loading Lisp code.")
+ (defvar *uninteresting-compiler-conditions* '()
+ "Additional conditions that may be skipped while compiling Lisp code.")
(defvar *uninteresting-loader-conditions*
(append
'("Overwriting already existing readtable ~S." ;; from named-readtables
#(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers
#+clisp '(clos::simple-gf-replacing-method-warning))
- "Additional conditions that may be skipped while loading"))
+ "Additional conditions that may be skipped while loading Lisp code."))
;;;; ----- Filtering conditions while building -----
(with-upgradability ()
(defun call-with-muffled-compiler-conditions (thunk)
(call-with-muffled-conditions
- thunk *uninteresting-compiler-conditions*))
+ thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*)))
(defmacro with-muffled-compiler-conditions ((&optional) &body body)
"Run BODY where uninteresting compiler conditions are muffled"
`(call-with-muffled-compiler-conditions #'(lambda () ,@body)))
(defun call-with-muffled-loader-conditions (thunk)
(call-with-muffled-conditions
- thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*)))
+ thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*)))
(defmacro with-muffled-loader-conditions ((&optional) &body body)
"Run BODY where uninteresting compiler and additional loader conditions are muffled"
`(call-with-muffled-loader-conditions #'(lambda () ,@body))))
(etypecase sexp
(symbol (reify-symbol sexp))
((or number character simple-string pathname) sexp)
- (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))))
+ (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
+ (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
+
(defun unreify-simple-sexp (sexp)
(etypecase sexp
((or symbol number character simple-string pathname) sexp)
(cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp))))
- ((simple-vector 2) (unreify-symbol sexp))))
+ ((simple-vector 2) (unreify-symbol sexp))
+ ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector))))
#+clozure
(progn
(destructuring-bind (&key filename start-pos end-pos source) source-note
(ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
:source (unreify-source-note source)))))
+ (defun unsymbolify-function-name (name)
+ (if-let (setfed (gethash name ccl::%setf-function-name-inverses%))
+ `(setf ,setfed)
+ name))
+ (defun symbolify-function-name (name)
+ (if (and (consp name) (eq (first name) 'setf))
+ (let ((setfed (second name)))
+ (gethash setfed ccl::%setf-function-names%))
+ name))
(defun reify-function-name (function-name)
- (reify-simple-sexp
- (if-let (setfed (gethash function-name ccl::%setf-function-name-inverses%))
- `(setf ,setfed)
- function-name)))
+ (let ((name (or (first function-name) ;; defun: extract the name
+ (let ((sec (second function-name)))
+ (or (and (atom sec) sec) ; scoped method: drop scope
+ (first sec)))))) ; method: keep gf name, drop method specializers
+ (list name)))
(defun unreify-function-name (function-name)
- (let ((name (unreify-simple-sexp function-name)))
- (if (and (consp name) (eq (first name) 'setf))
- (let ((setfed (second name)))
- (gethash setfed ccl::%setf-function-names%))
- name)))
+ function-name)
+ (defun nullify-non-literals (sexp)
+ (typecase sexp
+ ((or number character simple-string symbol pathname) sexp)
+ (cons (cons (nullify-non-literals (car sexp))
+ (nullify-non-literals (cdr sexp))))
+ (t nil)))
(defun reify-deferred-warning (deferred-warning)
(with-accessors ((warning-type ccl::compiler-warning-warning-type)
(args ccl::compiler-warning-args)
(function-name ccl:compiler-warning-function-name)) deferred-warning
(list :warning-type warning-type :function-name (reify-function-name function-name)
:source-note (reify-source-note source-note)
- :args (destructuring-bind (fun . formals) args
- (cons (reify-function-name fun) (reify-simple-sexp formals))))))
+ :args (destructuring-bind (fun &rest more)
+ args
+ (cons (unsymbolify-function-name fun)
+ (nullify-non-literals more))))))
(defun unreify-deferred-warning (reified-deferred-warning)
(destructuring-bind (&key warning-type function-name source-note args)
reified-deferred-warning
:function-name (unreify-function-name function-name)
:source-note (unreify-source-note source-note)
:warning-type warning-type
- :args (destructuring-bind (fun . formals) args
- (cons (unreify-function-name fun) (unreify-simple-sexp formals)))))))
+ :args (destructuring-bind (fun . more) args
+ (cons (symbolify-function-name fun) more))))))
#+(or cmu scl)
(defun reify-undefined-warning (warning)
;; Extracting undefined-warnings from the compilation-unit
using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by
WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF."
#+allegro
- (reify-simple-sexp
- (list :functions-defined excl::.functions-defined.
- :functions-called excl::.functions-called.))
+ (list :functions-defined excl::.functions-defined.
+ :functions-called excl::.functions-called.)
#+clozure
(mapcar 'reify-deferred-warning
(if-let (dw ccl::*outstanding-deferred-warnings*)
(declare (ignorable reified-deferred-warnings))
#+allegro
(destructuring-bind (&key functions-defined functions-called)
- (unreify-simple-sexp reified-deferred-warnings)
+ reified-deferred-warnings
(setf excl::.functions-defined.
(append functions-defined excl::.functions-defined.)
excl::.functions-called.
((:clozure :ccl) "ccl-warnings")
((:scl) "scl-warnings")))
- (defvar *warnings-file-type* (warnings-file-type)
+ (defvar *warnings-file-type* nil
"Type for warnings files")
+ (defun enable-deferred-warnings-check ()
+ (setf *warnings-file-type* (warnings-file-type)))
+
+ (defun disable-deferred-warnings-check ()
+ (setf *warnings-file-type* nil))
+
(defun warnings-file-p (file &optional implementation-type)
(if-let (type (if implementation-type
(warnings-file-type implementation-type)
(unreify-deferred-warnings
(handler-case (safe-read-file-form file)
(error (c)
- (delete-file-if-exists file)
+ ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
(push c file-errors)
nil))))))
(dolist (error file-errors) (error error))
(defun* (compile-file*) (input-file &rest keys
&key compile-check output-file warnings-file
- #+clisp lib-file #+(or ecl mkcl) object-file
+ #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
&allow-other-keys)
"This function provides a portable wrapper around COMPILE-FILE.
It ensures that the OUTPUT-FILE value is only returned and
(or object-file
(compile-file-pathname output-file :fasl-p nil)))
(tmp-file (tmpize-pathname output-file))
+ #+sbcl
+ (cfasl-file (etypecase emit-cfasl
+ (null nil)
+ ((eql t) (make-pathname :type "cfasl" :defaults output-file))
+ (string (parse-namestring emit-cfasl))
+ (pathname emit-cfasl)))
+ #+sbcl
+ (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
#+clisp
(tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
(multiple-value-bind (output-truename warnings-p failure-p)
(with-saved-deferred-warnings (warnings-file)
(with-muffled-compiler-conditions ()
- (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords)
+ (or #-(or ecl mkcl)
+ (apply 'compile-file input-file :output-file tmp-file
+ #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
+ #-sbcl keywords)
#+ecl (apply 'compile-file input-file :output-file
(if object-file
(list* object-file :system-p t keywords)
(delete-file-if-exists output-file)
(when output-truename
#+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
+ #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
(rename-file-overwriting-target output-truename output-file)
(setf output-truename (truename output-file)))
#+clisp (delete-file-if-exists tmp-lib))
(t ;; error or failed check
(delete-file-if-exists output-truename)
+ #+clisp (delete-file-if-exists tmp-lib)
+ #+sbcl (delete-file-if-exists tmp-cfasl)
(setf output-truename nil)))
(values output-truename warnings-p failure-p))))
;;; Links FASLs together
(with-upgradability ()
(defun combine-fasls (inputs output)
- #-(or allegro clisp clozure cmu lispworks sbcl scl xcl)
+ #-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl)
(error "~A does not support ~S~%inputs ~S~%output ~S"
(implementation-type) 'combine-fasls inputs output)
- #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
+ #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0
#+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output)
+ #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede)
#+lispworks
(let (fasls)
(unwind-protect
:for n :from 1
:for f = (add-pathname-suffix
output (format nil "-FASL~D" n))
- :do #-lispworks-personal-edition (lispworks:copy-file i f)
- #+lispworks-personal-edition (concatenate-files (list i) f)
- (push f fasls))
+ :do (copy-file i f)
+ (push f fasls))
(ignore-errors (lispworks:delete-system :fasls-to-concatenate))
(eval `(scm:defsystem :fasls-to-concatenate
(:default-pathname ,(pathname-directory-pathname output))
;;;; ---------------------------------------------------------------------------
;;;; Generic support for configuration files
-(asdf/package:define-package :asdf/configuration
- (:recycle :asdf/configuration :asdf)
- (:use :asdf/common-lisp :asdf/utility
- :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
+(uiop/package:define-package :uiop/configuration
+ (:nicknames :asdf/configuration)
+ (:recycle :uiop/configuration :asdf/configuration :asdf)
+ (:use :uiop/common-lisp :uiop/utility
+ :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build)
(:export
#:get-folder-path
#:user-configuration-directories #:system-configuration-directories
#:in-user-configuration-directory #:in-system-configuration-directory
#:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory
#:configuration-inheritance-directive-p
- #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form*
+ #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache*
#:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook
#:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
#:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
-(in-package :asdf/configuration)
+(in-package :uiop/configuration)
(with-upgradability ()
(define-condition invalid-configuration ()
(if wilden (wilden p) p))))
((eql :home) (user-homedir-pathname))
((eql :here) (resolve-absolute-location
- *here-directory* :ensure-directory t :wilden nil))
+ (or *here-directory* (pathname-directory-pathname (load-pathname)))
+ :ensure-directory t :wilden nil))
((eql :user-cache) (resolve-absolute-location
*user-cache* :ensure-directory t :wilden nil)))
:wilden (and wilden (not (pathnamep x)))
;;;; -------------------------------------------------------------------------
;;; Hacks for backward-compatibility of the driver
-(asdf/package:define-package :asdf/backward-driver
- (:recycle :asdf/backward-driver :asdf)
- (:use :asdf/common-lisp :asdf/package :asdf/utility
- :asdf/pathname :asdf/stream :asdf/os :asdf/image
- :asdf/run-program :asdf/lisp-build
- :asdf/configuration)
+(uiop/package:define-package :uiop/backward-driver
+ (:nicknames :asdf/backward-driver)
+ (:recycle :uiop/backward-driver :asdf/backward-driver :asdf)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility
+ :uiop/pathname :uiop/stream :uiop/os :uiop/image
+ :uiop/run-program :uiop/lisp-build
+ :uiop/configuration)
(:export
#:coerce-pathname #:component-name-to-pathname-components
#+(or ecl mkcl) #:compile-file-keeping-object
))
-(in-package :asdf/backward-driver)
+(in-package :uiop/backward-driver)
;;;; Backward compatibility with various pathname functions.
;;;; ---------------------------------------------------------------------------
;;;; Re-export all the functionality in asdf/driver
-(asdf/package:define-package :asdf/driver
- (:nicknames :asdf-driver :asdf-utils)
- (:use :asdf/common-lisp :asdf/package :asdf/utility
- :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
- :asdf/run-program :asdf/lisp-build
- :asdf/configuration :asdf/backward-driver)
+(uiop/package:define-package :uiop/driver
+ (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils)
+ (:use :uiop/common-lisp :uiop/package :uiop/utility
+ :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
+ :uiop/run-program :uiop/lisp-build
+ :uiop/configuration :uiop/backward-driver)
(:reexport
;; NB: excluding asdf/common-lisp
;; which include all of CL with compatibility modifications on select platforms.
- :asdf/package :asdf/utility
- :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
- :asdf/run-program :asdf/lisp-build
- :asdf/configuration :asdf/backward-driver))
+ :uiop/package :uiop/utility
+ :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
+ :uiop/run-program :uiop/lisp-build
+ :uiop/configuration :uiop/backward-driver))
;;;; -------------------------------------------------------------------------
;;;; Handle upgrade as forward- and backward-compatibly as possible
;; See https://bugs.launchpad.net/asdf/+bug/485687
;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
- (asdf-version "2.29")
+ (asdf-version "3.0.2")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
#:find-system #:system-source-file #:system-relative-pathname ;; system
#:find-component ;; find-component
#:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action
- #:component-depends-on #:component-self-dependencies #:operation-done-p
- #:traverse ;; plan
+ #:component-depends-on #:operation-done-p #:component-depends-on
+ #:traverse ;; backward-interface
#:operate ;; operate
#:parse-component-form ;; defsystem
#:apply-output-translations ;; output-translations
(uninterned-symbols
'(#:*asdf-revision* #:around #:asdf-method-combination
#:split #:make-collector #:do-dep #:do-one-dep
+ #:component-self-dependencies
#:resolve-relative-location-component #:resolve-absolute-location-component
#:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function
(declare (ignorable redefined-functions uninterned-symbols))
- (loop :for name :in (append #-(or ecl) redefined-functions)
+ (loop :for name :in (append redefined-functions)
:for sym = (find-symbol* name :asdf nil) :do
(when sym
- (fmakunbound sym)))
+ ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh.
+ #-clisp (fmakunbound sym)))
(loop :with asdf = (find-package :asdf)
- :for name :in (append #+(or ecl) redefined-functions uninterned-symbols) ;XXX
+ :for name :in uninterned-symbols
:for sym = (find-symbol* name :asdf nil)
:for base-pkg = (and sym (symbol-package sym)) :do
(when sym
(unless (equal old-version new-version)
(push new-version *previous-asdf-versions*)
(when old-version
- (cond
- ((version-compatible-p new-version old-version)
- (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
- old-version new-version))
- ((version-compatible-p 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)))
+ (if (version<= new-version old-version)
+ (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
+ old-version new-version)
+ (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
+ old-version new-version))
(call-functions (reverse *post-upgrade-cleanup-hook*))
t))))
We need do that before we operate on anything that may possibly depend on ASDF."
(let ((*load-print* nil)
(*compile-print* nil))
- (handler-bind (((or style-warning warning) #'muffle-warning))
+ (handler-bind (((or style-warning) #'muffle-warning))
(symbol-call :asdf :load-system :asdf :verbose nil))))
(register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration))
#:file-component
#:source-file #:c-source-file #:java-source-file
#:static-file #:doc-file #:html-file
- #:source-file-type ;; backward-compatibility
- #:component-in-order-to #:component-sibling-dependencies
+ #:file-type
+ #:source-file-type #:source-file-explicit-type ;; backward-compatibility
+ #:component-in-order-to #:component-sideway-dependencies
#:component-if-feature #:around-compile-hook
#:component-description #:component-long-description
#:component-version #:version-satisfies
#:components-by-name #:components
#:children #:children-by-name #:default-component-class
#:author #:maintainer #:licence #:source-file #:defsystem-depends-on
- #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods
+ #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods
#:relative-pathname #:absolute-pathname #:operation-times #:around-compile
#:%encoding #:properties #:component-properties #:parent))
(in-package :asdf/component)
(version :accessor component-version :initarg :version :initform nil)
(description :accessor component-description :initarg :description :initform nil)
(long-description :accessor component-long-description :initarg :long-description :initform nil)
- (sibling-dependencies :accessor component-sibling-dependencies :initform nil)
+ (sideway-dependencies :accessor component-sideway-dependencies :initform nil)
(if-feature :accessor component-if-feature :initform nil :initarg :if-feature)
;; In the ASDF object model, dependencies exist between *actions*,
;; where an action is a pair of an operation and a component.
(defclass file-component (child-component)
((type :accessor file-type :initarg :type))) ; no default
(defclass source-file (file-component)
- ((type :initform nil))) ;; NB: many systems have come to rely on this default.
+ ((type :accessor source-file-explicit-type ;; backward-compatibility
+ :initform nil))) ;; NB: many systems have come to rely on this default.
(defclass c-source-file (source-file)
((type :initform "c")))
(defclass java-source-file (source-file)
(version-satisfies (component-version c) version))
(defmethod version-satisfies ((cver string) version)
- (version-compatible-p cver version)))
+ (version<= version cver)))
;;; all sub-components (of a given type)
(setf (gethash key *asdf-cache*) value-list)
value-list)))
- (defun consult-asdf-cache (key thunk)
+ (defun consult-asdf-cache (key &optional thunk)
(if *asdf-cache*
(multiple-value-bind (results foundp) (gethash key *asdf-cache*)
(if foundp
(apply 'values results)
- (set-asdf-cache-entry key (multiple-value-list (funcall thunk)))))
- (funcall thunk)))
+ (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
+ (call-function thunk)))
(defmacro do-asdf-cache (key &body body)
`(consult-asdf-cache ,key #'(lambda () ,@body)))
:asdf/component :asdf/system :asdf/cache)
(:export
#:remove-entry-from-registry #:coerce-entry-to-directory
- #:coerce-name #:primary-system-name
+ #:coerce-name #:primary-system-name #:coerce-filename
#:find-system #:locate-system #:load-asd #:with-system-definitions
#:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
#:system-definition-error #:missing-component #:missing-requires #:missing-parent
#:*central-registry* #:probe-asd #:sysdef-central-registry-search
#:find-system-if-being-defined #:*systems-being-defined*
#:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed
- #:system-find-preloaded-system #:register-preloaded-system #:*preloaded-systems*
+ #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems*
#:clear-defined-systems #:*defined-systems*
;; defined in source-registry, but specially mentioned here:
#:initialize-source-registry #:sysdef-source-registry-search))
;; the first of the slash-separated components.
(first (split-string (coerce-name name) :separator "/")))
+ (defun coerce-filename (name)
+ (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))
+
(defvar *defined-systems* (make-hash-table :test 'equal)
"This is a hash table whose keys are strings, being the
names of the systems, and whose values are pairs, the first
(setf *defined-systems* (make-hash-table :test 'equal))
(when asdf
(setf (component-version asdf) *asdf-version*)
+ (setf (builtin-system-p asdf) t)
(register-system asdf)))
(values))
(remove-if #'(lambda (x) (member x *system-definition-search-functions*))
'(sysdef-central-registry-search
sysdef-source-registry-search
- sysdef-find-preloaded-systems)))))
+ sysdef-preloaded-system-search)))))
(cleanup-system-definition-search-functions)
(defun search-for-system-definition (system)
(list new)
(subseq *central-registry* (1+ position))))))))))
+ (defvar *preloaded-systems* (make-hash-table :test 'equal))
+
+ (defun make-preloaded-system (name keys)
+ (apply 'make-instance (getf keys :class 'system)
+ :name name :source-file (getf keys :source-file)
+ (remove-plist-keys '(:class :name :source-file) keys)))
+
+ (defun sysdef-preloaded-system-search (requested)
+ (let ((name (coerce-name requested)))
+ (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
+ (when foundp
+ (make-preloaded-system name keys)))))
+
+ (defun register-preloaded-system (system-name &rest keys)
+ (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
+
+ (register-preloaded-system "asdf" :version *asdf-version*)
+ (register-preloaded-system "asdf-driver" :version *asdf-version*)
+
(defmethod find-system ((name null) &optional (error-p t))
(declare (ignorable name))
(when error-p
(let ((*systems-being-defined* (make-hash-table :test 'equal)))
(call-with-asdf-cache thunk))))
+ (defun clear-systems-being-defined ()
+ (when *systems-being-defined*
+ (clrhash *systems-being-defined*)))
+
+ (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined)
+
(defmacro with-system-definitions ((&optional) &body body)
`(call-with-system-definitions #'(lambda () ,@body)))
- (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))))
+ (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*))
;; Tries to load system definition with canonical NAME from PATHNAME.
(with-system-definitions ()
(with-standard-io-syntax
(let ((*package* (find-package :asdf-user))
+ ;; Note that our backward-compatible *readtable* is
+ ;; a global readtable that gets globally side-effected. Ouch.
+ ;; Same for the *print-pprint-dispatch* table.
+ ;; We should do something about that for ASDF3 if possible, or else ASDF4.
+ (*readtable* readtable)
+ (*print-pprint-dispatch* print-pprint-dispatch)
(*print-readably* nil)
(*default-pathname-defaults*
;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings.
(with-muffled-loader-conditions ()
(load* pathname :external-format external-format)))))))
+ (defvar *old-asdf-systems* (make-hash-table :test 'equal))
+
+ (defun check-not-old-asdf-system (name pathname)
+ (or (not (equal name "asdf"))
+ (null pathname)
+ (let* ((version-pathname (subpathname pathname "version.lisp-expr"))
+ (version (and (probe-file* version-pathname :truename nil)
+ (read-file-form version-pathname)))
+ (old-version (asdf-version)))
+ (or (version<= old-version version)
+ (let ((old-pathname
+ (if-let (pair (system-registered-p "asdf"))
+ (system-source-file (cdr pair))))
+ (key (list pathname old-version)))
+ (unless (gethash key *old-asdf-systems*)
+ (setf (gethash key *old-asdf-systems*) t)
+ (warn "~@<~
+ You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
+ or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
+ ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~
+ Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~
+ and having an old version registered is a configuration error. ~
+ ASDF will ignore this configured system rather than downgrade itself. ~
+ In the future, you may want to either: ~
+ (a) upgrade this configured ASDF to a newer version, ~
+ (b) install a newer ASDF and register it in front of the former in your configuration, or ~
+ (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~
+ Note that the older ASDF might be registered implicitly through configuration inherited ~
+ from your system installation, in which case you might have to specify ~
+ :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~
+ or other source-registry configuration file, environment variable or lisp parameter. ~
+ Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~
+ that you might want to upgrade (if a recent enough version is available) ~
+ or else remove altogether (since most implementations ship with a recent asdf); ~
+ if you lack the system administration rights to upgrade or remove this package, ~
+ then you might indeed want to either install and register a more recent version, ~
+ or use :ignore-inherited-configuration to avoid registering the old one. ~
+ Please consult ASDF documentation and/or experts.~@:>~%"
+ old-version old-pathname version pathname)))))))
+
(defun locate-system (name)
"Given a system NAME designator, try to locate where to load the system from.
Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME
(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))))
- (pathname (ensure-pathname (resolve-symlinks* pathname) :want-absolute t))
+ (pathname (ensure-pathname
+ (or (and (typep found '(or pathname string)) (pathname found))
+ (and found-system (system-source-file found-system))
+ (and previous (system-source-file previous)))
+ :want-absolute t :resolve-symlinks *resolve-symlinks*))
(foundp (and (or found-system pathname previous) t)))
(check-type found (or null pathname system))
+ (unless (check-not-old-asdf-system name pathname)
+ (cond
+ (previous (setf found nil pathname nil))
+ (t
+ (setf found (sysdef-preloaded-system-search "asdf"))
+ (assert (typep found 'system))
+ (setf found-system found pathname nil))))
(values foundp found-system pathname previous previous-time)))
(defmethod find-system ((name string) &optional (error-p t))
(translate-logical-pathname pathname)
(translate-logical-pathname previous-pathname))))
(stamp<= stamp previous-time))))))
- ;; only load when it's a pathname that is different or has newer content
+ ;; only load when it's a pathname that is different or has newer content, and not an old asdf
(load-asd pathname :name name)))
(let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
(return
(reinitialize-source-registry-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
- (initialize-source-registry))))))
-
- (defvar *preloaded-systems* (make-hash-table :test 'equal))
-
- (defun sysdef-find-preloaded-systems (requested)
- (let ((name (coerce-name requested)))
- (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
- (when foundp
- (apply 'make-instance 'system :name name :source-file (getf keys :source-file) keys)))))
-
- (defun register-preloaded-system (system-name &rest keys)
- (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
-
- (register-preloaded-system "asdf" :version *asdf-version*)
- (register-preloaded-system "asdf-driver" :version *asdf-version*))
+ (initialize-source-registry)))))))
;;;; -------------------------------------------------------------------------
;;;; Finding components
;;;; Operations
(asdf/package:define-package :asdf/operation
- (:recycle :asdf/operation :asdf)
+ (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
(:export
#:operation
- #:operation-original-initargs ;; backward-compatibility only. DO NOT USE.
+ #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE.
#:build-op ;; THE generic operation
- #:*operations*
- #:make-operation
- #:find-operation))
+ #:*operations* #:make-operation #:find-operation #:feature))
(in-package :asdf/operation)
;;; Operation Classes
(declare (ignorable context))
spec)
(defmethod find-operation (context (spec symbol))
- (apply 'make-operation spec (operation-original-initargs context)))
+ (unless (member spec '(nil feature))
+ ;; NIL designates itself, i.e. absence of operation
+ ;; FEATURE is the ASDF1 misfeature that comes with IF-COMPONENT-DEP-FAILS
+ (apply 'make-operation spec (operation-original-initargs context))))
(defmethod operation-original-initargs ((context symbol))
(declare (ignorable context))
nil)
(:export
#:action #:define-convenience-action-methods
#:explain #:action-description
- #:downward-operation #:upward-operation #:sibling-operation
- #:component-depends-on #:component-self-dependencies
+ #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation
+ #:component-depends-on
#:input-files #:output-files #:output-file #:operation-done-p
#:action-status #:action-stamp #:action-done-p
#:component-operation-time #:mark-operation-done #:compute-action-stamp
- #:perform #:perform-with-restarts #:retry #:accept #:feature
+ #:perform #:perform-with-restarts #:retry #:accept
#:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
#:action-path #:find-action #:stamp #:done-p))
(in-package :asdf/action)
;;;; Convenience methods
(with-upgradability ()
(defmacro define-convenience-action-methods
- (function (operation component &optional keyp)
- &key if-no-operation if-no-component operation-initargs)
+ (function formals &key if-no-operation if-no-component operation-initargs)
(let* ((rest (gensym "REST"))
(found (gensym "FOUND"))
+ (keyp (equal (last formals) '(&key)))
+ (formals-no-key (if keyp (butlast formals) formals))
+ (len (length formals-no-key))
+ (operation 'operation)
+ (component 'component)
+ (opix (position operation formals))
+ (coix (position component formals))
+ (prefix (subseq formals 0 opix))
+ (suffix (subseq formals (1+ coix) len))
(more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
+ (assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
(flet ((next-method (o c)
(if keyp
- `(apply ',function ,o ,c ,rest)
- `(,function ,o ,c))))
+ `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
+ `(,function ,@prefix ,o ,c ,@suffix))))
`(progn
- (defmethod ,function ((,operation symbol) ,component ,@more-args)
+ (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args)
(if ,operation
,(next-method
(if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
`(make-operation ,operation))
`(or (find-component () ,component) ,if-no-component))
,if-no-operation))
- (defmethod ,function ((,operation operation) ,component ,@more-args)
+ (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
(if (typep ,component 'component)
(error "No defined method for ~S on ~/asdf-action:format-action/"
',function (cons ,operation ,component))
- (let ((,found (find-component () ,component)))
- (if ,found
- ,(next-method operation found)
- ,if-no-component)))))))))
+ (if-let (,found (find-component () ,component))
+ ,(next-method operation found)
+ ,if-no-component))))))))
;;;; self-description
;;;; Dependencies
(with-upgradability ()
- (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies
+ (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies
(:documentation
"Returns a list of dependencies needed by the component to perform
the operation. A dependency has one of the following forms:
- (<operation> <component>*), where <operation> is a class
- designator and each <component> is a component
- designator, which means that the component depends on
+ (<operation> <component>*), where <operation> is an operation designator
+ with respect to FIND-OPERATION in the context of the OPERATION argument,
+ and each <component> is a component designator with respect to
+ FIND-COMPONENT in the context of the COMPONENT argument,
+ and means that the component depends on
<operation> having been performed on each <component>; or
(FEATURE <feature>), which means that the component depends
- on <feature>'s presence in *FEATURES*.
+ on the <feature> expression satisfying FEATUREP.
+ (This is DEPRECATED -- use :IF-FEATURE instead.)
Methods specialized on subclasses of existing component types
- should usually append the results of CALL-NEXT-METHOD to the
- list."))
- (defgeneric component-self-dependencies (operation component))
+ should usually append the results of CALL-NEXT-METHOD to the list."))
(define-convenience-action-methods component-depends-on (operation component))
- (define-convenience-action-methods component-self-dependencies (operation component))
+
+ (defmethod component-depends-on :around ((o operation) (c component))
+ (do-asdf-cache `(component-depends-on ,o ,c)
+ (call-next-method)))
(defmethod component-depends-on ((o operation) (c component))
- (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies
+ (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies
- (defmethod component-self-dependencies ((o operation) (c component))
- ;; NB: result in the same format as component-depends-on
- (loop* :for (o-spec . c-spec) :in (component-depends-on o c)
- :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature"
- :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep)))
- :collect (list o-spec c))))
;;;; upward-operation, downward-operation
;; These together handle actions that propagate along the component hierarchy.
(with-upgradability ()
(defclass downward-operation (operation)
((downward-operation
- :initform nil :initarg :downward-operation :reader downward-operation)))
+ :initform nil :initarg :downward-operation :reader downward-operation :allocation :class)))
(defmethod component-depends-on ((o downward-operation) (c parent-component))
`((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method)))
;; Upward operations like prepare-op propagate up the component hierarchy:
;; By default, an operation propagates itself, but it may propagate another one instead.
(defclass upward-operation (operation)
((upward-operation
- :initform nil :initarg :downward-operation :reader upward-operation)))
+ :initform nil :initarg :downward-operation :reader upward-operation :allocation :class)))
;; For backward-compatibility reasons, a system inherits from module and is a child-component
;; so we must guard against this case. ASDF4: remove that.
(defmethod component-depends-on ((o upward-operation) (c child-component))
;; Sibling operations propagate to siblings in the component hierarchy:
;; operation on a child depends-on operation on its parent.
;; By default, an operation propagates itself, but it may propagate another one instead.
- (defclass sibling-operation (operation)
- ((sibling-operation
- :initform nil :initarg :sibling-operation :reader sibling-operation)))
- (defmethod component-depends-on ((o sibling-operation) (c component))
- `((,(or (sibling-operation o) o)
- ,@(loop :for dep :in (component-sibling-dependencies c)
+ (defclass sideway-operation (operation)
+ ((sideway-operation
+ :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class)))
+ (defmethod component-depends-on ((o sideway-operation) (c component))
+ `((,(or (sideway-operation o) o)
+ ,@(loop :for dep :in (component-sideway-dependencies c)
:collect (resolve-dependency-spec c dep)))
+ ,@(call-next-method)))
+ ;; Selfward operations propagate to themselves a sub-operation:
+ ;; they depend on some other operation being acted on the same component.
+ (defclass selfward-operation (operation)
+ ((selfward-operation
+ :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class)))
+ (defmethod component-depends-on ((o selfward-operation) (c component))
+ `(,@(loop :for op :in (ensure-list (selfward-operation o))
+ :collect `(,op ,c))
,@(call-next-method))))
(do-asdf-cache `(input-files ,operation ,component)
(call-next-method)))
- (defmethod input-files ((o operation) (c parent-component))
+ (defmethod input-files ((o operation) (c component))
(declare (ignorable o c))
nil)
- (defmethod input-files ((o operation) (c component))
- (or (loop* :for (dep-o) :in (component-self-dependencies o c)
- :append (or (output-files dep-o c) (input-files dep-o c)))
- ;; no non-trivial previous operations needed?
- ;; I guess we work with the original source file, then
- (if-let ((pathname (component-pathname c)))
- (and (file-pathname-p pathname) (list pathname))))))
+ (defmethod input-files ((o selfward-operation) (c component))
+ `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o))
+ :append (or (output-files dep-o c) (input-files dep-o c)))
+ (if-let ((pathname (component-pathname c)))
+ (and (file-pathname-p pathname) (list pathname))))
+ ,@(call-next-method))))
;;;; Done performing
(:recycle :asdf/lisp-action :asdf)
(:intern #:proclamations #:flags)
(:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action)
+ :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/find-system
+ :asdf/operation :asdf/action)
(:export
#:try-recompiling
#:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
#:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
#:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
#:call-with-around-compile-hook
- #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:flags))
+ #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source
+ #:lisp-compilation-output-files #:flags))
(in-package :asdf/lisp-action)
(defclass basic-load-op (operation) ())
(defclass basic-compile-op (operation)
((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil)
- (flags :initarg :flags :accessor compile-op-flags
- :initform nil))))
+ (flags :initarg :flags :accessor compile-op-flags :initform nil))))
;;; Our default operations: loading into the current lisp image
(with-upgradability ()
- (defclass load-op (basic-load-op downward-operation sibling-operation) ())
- (defclass prepare-op (upward-operation sibling-operation)
- ((sibling-operation :initform 'load-op :allocation :class)))
- (defclass compile-op (basic-compile-op downward-operation)
- ((downward-operation :initform 'load-op :allocation :class)))
+ (defclass prepare-op (upward-operation sideway-operation)
+ ((sideway-operation :initform 'load-op)))
+ (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation)
+ ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p,
+ ;; so we need to directly depend on prepare-op for its side-effects in the current image.
+ ((selfward-operation :initform '(prepare-op compile-op))))
+ (defclass compile-op (basic-compile-op downward-operation selfward-operation)
+ ((selfward-operation :initform 'prepare-op)
+ (downward-operation :initform 'load-op)))
- (defclass load-source-op (basic-load-op downward-operation) ())
- (defclass prepare-source-op (upward-operation sibling-operation)
- ((sibling-operation :initform 'load-source-op :allocation :class)))
+ (defclass prepare-source-op (upward-operation sideway-operation)
+ ((sideway-operation :initform 'load-source-op)))
+ (defclass load-source-op (basic-load-op downward-operation selfward-operation)
+ ((selfward-operation :initform 'prepare-source-op)))
- (defclass test-op (operation) ()))
+ (defclass test-op (selfward-operation)
+ ((selfward-operation :initform 'load-op))))
;;;; prepare-op, compile-op and load-op
"~/asdf-action::format-action/" (list (cons o c))))))
(defun report-file-p (f)
- (equal (pathname-type f) "build-report"))
+ (equalp (pathname-type f) "build-report"))
(defun perform-lisp-warnings-check (o c)
(let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c)))
(actual-warnings-files (loop :for w :in expected-warnings-files
(format s ":success~%"))))))
(defmethod perform ((o compile-op) (c cl-source-file))
(perform-lisp-compilation o c))
- (defmethod output-files ((o compile-op) (c cl-source-file))
- (declare (ignorable o))
+ (defun lisp-compilation-output-files (o c)
(let* ((i (first (input-files o c)))
(f (compile-file-pathname
i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)))
,(compile-file-pathname i :fasl-p nil) ;; object file
,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c))))
`(,(make-pathname :type *warnings-file-type* :defaults f))))))
- (defmethod component-depends-on ((o compile-op) (c component))
- (declare (ignorable o))
- `((prepare-op ,c) ,@(call-next-method)))
+ (defmethod output-files ((o compile-op) (c cl-source-file))
+ (lisp-compilation-output-files o c))
(defmethod perform ((o compile-op) (c static-file))
(declare (ignorable o c))
nil)
(defmethod output-files ((o compile-op) (c system))
(when (and *warnings-file-type* (not (builtin-system-p c)))
(if-let ((pathname (component-pathname c)))
- (list (subpathname pathname (component-name c) :type "build-report"))))))
+ (list (subpathname pathname (coerce-filename c) :type "build-report"))))))
;;; load-op
(with-upgradability ()
(perform-lisp-load-fasl o c))
(defmethod perform ((o load-op) (c static-file))
(declare (ignorable o c))
- nil)
- (defmethod component-depends-on ((o load-op) (c component))
- (declare (ignorable o))
- ;; NB: even though compile-op depends-on on prepare-op,
- ;; it is not needed-in-image-p, whereas prepare-op is,
- ;; so better not omit prepare-op and think it will happen.
- `((prepare-op ,c) (compile-op ,c) ,@(call-next-method))))
+ nil))
;;;; prepare-source-op, load-source-op
(defmethod action-description ((o load-source-op) (c parent-component))
(declare (ignorable o))
(format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c))
- (defmethod component-depends-on ((o load-source-op) (c component))
- (declare (ignorable o))
- `((prepare-source-op ,c) ,@(call-next-method)))
(defun perform-lisp-load-source (o c)
(call-with-around-compile-hook
c #'(lambda ()
(defmethod operation-done-p ((o test-op) (c system))
"Testing a system is _never_ done."
(declare (ignorable o c))
- nil)
- (defmethod component-depends-on ((o test-op) (c system))
- (declare (ignorable o))
- `((load-op ,c) ,@(call-next-method))))
+ nil))
;;;; -------------------------------------------------------------------------
;;;; Plan
#:circular-dependency #:circular-dependency-actions
#:node-for #:needed-in-image-p
#:action-index #:action-planned-p #:action-valid-p
- #:plan-record-dependency #:visiting-action-p
+ #:plan-record-dependency
#:normalize-forced-systems #:action-forced-p #:action-forced-not-p
#:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies
#:visit-dependencies #:compute-action-stamp #:traverse-action
#:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action
- #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p
+ #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
#:planned-p #:index #:forced #:forced-not #:total-action-count
#:planned-action-count #:planned-output-action-count #:visited-actions
#:visiting-action-set #:visiting-action-list #:plan-actions-r
(with-upgradability ()
(defun map-direct-dependencies (operation component fun)
(loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
- :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature
- :do (loop :with dep-o = (find-operation operation dep-o-spec)
- :for dep-c-spec :in dep-c-specs
- :for dep-c = (resolve-dependency-spec component dep-c-spec)
- :do (funcall fun dep-o dep-c))))
+ :for dep-o = (find-operation operation dep-o-spec)
+ :when dep-o
+ :do (loop :for dep-c-spec :in dep-c-specs
+ :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
+ :when dep-c
+ :do (funcall fun dep-o dep-c))))
(defun reduce-direct-dependencies (operation component combinator seed)
(map-direct-dependencies
(in-files (input-files o c))
;; Three kinds of actions:
(out-op (and out-files t)) ; those that create files on the filesystem
- ;(image-op (and in-files (null out-files))) ; those that load stuff into the image
- ;(null-op (and (null out-files) (null in-files))) ; dependency placeholders that do nothing
+ ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image
+ ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing
;; When was the thing last actually done? (Now, or ask.)
(op-time (or just-done (component-operation-time o c)))
;; Accumulated timestamp from dependencies (or T if forced or out-of-date)
(and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c))))
(values done-stamp ;; return the hard-earned timestamp
(or just-done
- (or out-op ;; a file-creating op is done when all files are up to date
- ;; a image-effecting a placeholder op is done when it was actually run,
- (and op-time (eql op-time done-stamp))))) ;; with the matching stamp
+ out-op ;; a file-creating op is done when all files are up to date
+ ;; a image-effecting a placeholder op is done when it was actually run,
+ (and op-time (eql op-time done-stamp)))) ;; with the matching stamp
;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet
(values t nil)))))
:stamp stamp
:done-p (and done-p (not add-to-plan-p))
:planned-p add-to-plan-p
- :index (if status (action-index status) (incf (plan-total-action-count plan)))))
+ :index (if status
+ (action-index status)
+ (incf (plan-total-action-count plan)))))
(when add-to-plan-p
(incf (plan-planned-action-count plan))
(unless aniip
((actions-r :initform nil :accessor plan-actions-r)))
(defgeneric plan-actions (plan))
+ (defmethod plan-actions ((plan list))
+ plan)
(defmethod plan-actions ((plan sequential-plan))
(reverse (plan-actions-r plan)))
;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
(with-upgradability ()
- (defgeneric* (traverse) (operation component &key &allow-other-keys)
+ (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
(: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
-processed in order by OPERATE."))
- (define-convenience-action-methods traverse (operation component &key))
+ "Generate and return a plan for performing OPERATION on COMPONENT."))
+ (define-convenience-action-methods make-plan (plan-class operation component &key))
(defgeneric perform-plan (plan &key))
(defgeneric plan-operates-on-p (plan component))
- (defparameter *default-plan-class* 'sequential-plan)
+ (defvar *default-plan-class* 'sequential-plan)
- (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
+ (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
(let ((plan (apply 'make-instance
(or plan-class *default-plan-class*)
- :system (component-system c) (remove-plist-key :plan-class keys))))
+ :system (component-system c) keys)))
(traverse-action plan o c t)
- (plan-actions plan)))
+ plan))
- (defmethod perform-plan :around (plan &key)
- (declare (ignorable plan))
+ (defmethod perform-plan :around ((plan t) &key)
(let ((*package* *package*)
(*readtable* *readtable*))
(with-compilation-unit () ;; backward-compatibility.
(call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
- (defmethod perform-plan ((steps list) &key)
- (loop* :for (op . component) :in steps :do
- (perform-with-restarts op component)))
+ (defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys)
+ (apply 'perform-plan (plan-actions plan) keys))
+
+ (defmethod perform-plan ((steps list) &key force &allow-other-keys)
+ (loop* :for (o . c) :in steps
+ :when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
+ :do (perform-with-restarts o c)))
+
+ (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list))
+ (plan-operates-on-p (plan-actions plan) component-path))
(defmethod plan-operates-on-p ((plan list) (component-path list))
(find component-path (mapcar 'cdr plan)
(defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys)
(let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
- (loop* :for (o . c) :in actions :do
- (traverse-action plan o c t))
- (plan-actions plan)))
+ (loop* :for (o . c) :in actions :do (traverse-action plan o c t))
+ plan))
- (define-convenience-action-methods traverse-sub-actions (o c &key))
+ (define-convenience-action-methods traverse-sub-actions (operation component &key))
(defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys)
(apply 'traverse-actions (direct-dependencies operation component)
:system (component-system component) keys))
(defmethod plan-actions ((plan filtered-sequential-plan))
(with-slots (keep-operation keep-component) plan
(loop* :for (o . c) :in (call-next-method)
- :when (and (typep o keep-operation)
- (typep c keep-component))
+ :when (and (typep o keep-operation) (typep c keep-component))
:collect (cons o c))))
(defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
(remove-duplicates
- (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys))
+ (mapcar 'cdr (plan-actions
+ (apply 'traverse-sub-actions goal-operation system
+ (remove-plist-key :goal-operation keys))))
:from-end t)))
;;;; -------------------------------------------------------------------------
:asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan)
(:export
#:operate #:oos
- #:*systems-being-operated* #:*asdf-upgrade-already-attempted*
+ #:*systems-being-operated*
#:build-system
#:load-system #:load-systems #:compile-system #:test-system #:require-system
#:*load-system-operation* #:module-provide-asdf
- #:component-loaded-p #:already-loaded-systems
- #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*))
+ #:component-loaded-p #:already-loaded-systems))
(in-package :asdf/operate)
(with-upgradability ()
- (defgeneric* (operate) (operation component &key &allow-other-keys))
- (define-convenience-action-methods
- operate (operation component &key)
- :operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
- :if-no-component (error 'missing-component :requires component))
-
- (defvar *systems-being-operated* nil
- "A boolean indicating that some systems are being operated on")
-
- (defmethod operate :around (operation component
- &key verbose
- (on-warnings *compile-file-warnings-behaviour*)
- (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
- (declare (ignorable operation component))
- ;; Setup proper bindings around any operate call.
- (with-system-definitions ()
- (let* ((*verbose-out* (and verbose *standard-output*))
- (*compile-file-warnings-behaviour* on-warnings)
- (*compile-file-failure-behaviour* on-failure))
- (call-next-method))))
-
- (defmethod operate ((operation operation) (component component)
- &rest args &key version &allow-other-keys)
- "Operate does three things:
+ (defgeneric* (operate) (operation component &key &allow-other-keys)
+ (:documentation
+ "Operate does three things:
1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk).
without recursively forcing the other systems we depend on.
:ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
(SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
-:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."
- (let* (;; I'd like to remove-plist-keys :force :force-not :verbose,
- ;; but swank.asd relies on :force (!).
- (systems-being-operated *systems-being-operated*)
+:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."))
+
+ (define-convenience-action-methods
+ operate (operation component &key)
+ ;; I'd like to at least remove-plist-keys :force :force-not :verbose,
+ ;; but swank.asd relies on :force (!).
+ :operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
+ :if-no-component (error 'missing-component :requires component))
+
+ (defvar *systems-being-operated* nil
+ "A boolean indicating that some systems are being operated on")
+
+ (defmethod operate :around (operation component &rest keys
+ &key verbose
+ (on-warnings *compile-file-warnings-behaviour*)
+ (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
+ (declare (ignorable operation component))
+ (let* ((systems-being-operated *systems-being-operated*)
(*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
- (system (component-system component)))
- (setf (gethash (coerce-name system) *systems-being-operated*) system)
- (unless (version-satisfies component version)
- (error 'missing-component-of-version :requires component :version version))
+ (operation-name (reify-symbol (etypecase operation
+ (operation (type-of operation))
+ (symbol operation))))
+ (component-path (typecase component
+ (component (component-find-path component))
+ (t component))))
;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
(unless systems-being-operated
- (let ((operation-name (reify-symbol (type-of operation)))
- (component-path (component-find-path component)))
- (when (upgrade-asdf)
- ;; If we were upgraded, restart OPERATE the hardest of ways, for
- ;; its function may have been redefined, its symbol uninterned, its package deleted.
- (return-from operate
- (apply (find-symbol* 'operate :asdf)
- (unreify-symbol operation-name)
- component-path args)))))
- (let ((plan (apply 'traverse operation system args)))
- (perform-plan plan)
- (values operation plan))))
+ (when (upgrade-asdf)
+ ;; If we were upgraded, restart OPERATE the hardest of ways, for
+ ;; its function may have been redefined, its symbol uninterned, its package deleted.
+ (return-from operate
+ (apply (find-symbol* 'operate :asdf)
+ (unreify-symbol operation-name)
+ component-path keys))))
+ ;; Setup proper bindings around any operate call.
+ (with-system-definitions ()
+ (let* ((*verbose-out* (and verbose *standard-output*))
+ (*compile-file-warnings-behaviour* on-warnings)
+ (*compile-file-failure-behaviour* on-failure))
+ (call-next-method)))))
+
+ (defmethod operate :before ((operation operation) (component component)
+ &key version &allow-other-keys)
+ (let ((system (component-system component)))
+ (setf (gethash (coerce-name system) *systems-being-operated*) system))
+ (unless (version-satisfies component version)
+ (error 'missing-component-of-version :requires component :version version)))
+
+ (defmethod operate ((operation operation) (component component)
+ &rest keys &key plan-class &allow-other-keys)
+ (let ((plan (apply 'make-plan plan-class operation component keys)))
+ (apply 'perform-plan plan keys)
+ (values operation plan)))
(defun oos (operation component &rest args &key &allow-other-keys)
(apply 'operate operation component args))
(defun require-system (s &rest keys &key &allow-other-keys)
(apply 'load-system s :force-not (already-loaded-systems) keys))
+ (defvar *modules-being-required* nil)
+
+ (defclass require-system (system)
+ ((module :initarg :module :initform nil :accessor required-module)))
+
+ (defmethod perform ((o compile-op) (c require-system))
+ (declare (ignorable o c))
+ nil)
+
+ (defmethod perform ((o load-op) (s require-system))
+ (declare (ignorable o))
+ (let* ((module (or (required-module s) (coerce-name s)))
+ (*modules-being-required* (cons module *modules-being-required*)))
+ (assert (null (component-children s)))
+ (require module)))
+
+ (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
+ (declare (ignorable component combinator))
+ (unless (length=n-p arguments 1)
+ (error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes only one argument~@:>")
+ (cons combinator arguments) component combinator))
+ (let* ((module (car arguments))
+ (name (string-downcase module))
+ (system (find-system name nil)))
+ (assert module)
+ ;;(unless (typep system '(or null require-system))
+ ;; (warn "~S depends on ~S but ~S is registered as a ~S"
+ ;; component (cons combinator arguments) module (type-of system)))
+ (or system (let ((system (make-instance 'require-system :name name)))
+ (register-system system)
+ system))))
+
(defun module-provide-asdf (name)
- (handler-bind
- ((style-warning #'muffle-warning)
- (missing-component (constantly nil))
- (error #'(lambda (e)
- (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
- name e))))
- (let ((*verbose-out* (make-broadcast-stream))
- (system (find-system (string-downcase name) nil)))
- (when system
- (require-system system :verbose nil)
- t)))))
+ (let ((module (string-downcase name)))
+ (unless (member module *modules-being-required* :test 'equal)
+ (let ((*modules-being-required* (cons module *modules-being-required*))
+ #+sbcl (sb-impl::*requiring* (remove module sb-impl::*requiring* :test 'equal)))
+ (handler-bind
+ ((style-warning #'muffle-warning)
+ (missing-component (constantly nil))
+ (error #'(lambda (e)
+ (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
+ name e))))
+ (let ((*verbose-out* (make-broadcast-stream)))
+ (let ((system (find-system module nil)))
+ (when system
+ (require-system system :verbose nil)
+ t)))))))))
;;;; Some upgrade magic
(clrhash *systems-being-defined*)
(dolist (s l) (find-system s nil)))))
- (pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*))
-
+ (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf))
-;;;; ---------------------------------------------------------------------------
-;;;; asdf-output-translations
-(asdf/package:define-package :asdf/output-translations
- (:recycle :asdf/output-translations :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
- (:export
- #:*output-translations* #:*output-translations-parameter*
- #:invalid-output-translation
- #:output-translations #:output-translations-initialized-p
- #:initialize-output-translations #:clear-output-translations
- #:disable-output-translations #:ensure-output-translations
- #:apply-output-translations
- #:validate-output-translations-directive #:validate-output-translations-form
- #:validate-output-translations-file #:validate-output-translations-directory
- #:parse-output-translations-string #:wrapping-output-translations
- #:user-output-translations-pathname #:system-output-translations-pathname
- #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
- #:environment-output-translations #:process-output-translations
- #:compute-output-translations
- #+abcl #:translate-jar-pathname
- ))
-(in-package :asdf/output-translations)
+;;;; -------------------------------------------------------------------------
+;;; Internal hacks for backward-compatibility
-(when-upgrading () (undefine-function '(setf output-translations)))
+(asdf/package:define-package :asdf/backward-internals
+ (:recycle :asdf/backward-internals :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ :asdf/system :asdf/component :asdf/operation
+ :asdf/find-system :asdf/action :asdf/lisp-action)
+ (:export ;; for internal use
+ #:load-sysdef #:make-temporary-package
+ #:%refresh-component-inline-methods
+ #:%resolve-if-component-dep-fails
+ #:make-sub-operation
+ #:load-sysdef #:make-temporary-package))
+(in-package :asdf/backward-internals)
+;;;; Backward compatibility with "inline methods"
(with-upgradability ()
- (define-condition invalid-output-translation (invalid-configuration warning)
- ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-
- (defvar *output-translations* ()
- "Either NIL (for uninitialized), or a list of one element,
-said element itself being a sorted list of mappings.
-Each mapping is a pair of a source pathname and destination pathname,
-and the order is by decreasing length of namestring of the source pathname.")
+ (defparameter +asdf-methods+
+ '(perform-with-restarts perform explain output-files operation-done-p))
- (defun output-translations ()
- (car *output-translations*))
+ (defun %remove-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
+ ;; But this is hardly performance-critical
+ #'(lambda (m)
+ (remove-method (symbol-function name) m))
+ (component-inline-methods component)))
+ (component-inline-methods component) nil)
- (defun set-output-translations (new-value)
- (setf *output-translations*
- (list
- (stable-sort (copy-list new-value) #'>
- :key #'(lambda (x)
- (etypecase (car x)
- ((eql t) -1)
- (pathname
- (let ((directory (pathname-directory (car x))))
- (if (listp directory) (length directory) 0))))))))
- new-value)
- (defsetf output-translations set-output-translations) ; works with gcl 2.6
+ (defun %define-component-inline-methods (ret rest)
+ (loop* :for (key value) :on rest :by #'cddr
+ :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=))
+ :when name :do
+ (destructuring-bind (op &rest body) value
+ (loop :for arg = (pop body)
+ :while (atom arg)
+ :collect arg :into qualifiers
+ :finally
+ (destructuring-bind (o c) arg
+ (pushnew
+ (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body))
+ (component-inline-methods ret)))))))
- (defun output-translations-initialized-p ()
- (and *output-translations* t))
-
- (defun clear-output-translations ()
- "Undoes any initialization of the output translations."
- (setf *output-translations* '())
- (values))
- (register-clear-configuration-hook 'clear-output-translations)
-
- (defun validate-output-translations-directive (directive)
- (or (member directive '(:enable-user-cache :disable-cache nil))
- (and (consp directive)
- (or (and (length=n-p directive 2)
- (or (and (eq (first directive) :include)
- (typep (second directive) '(or string pathname null)))
- (and (location-designator-p (first directive))
- (or (location-designator-p (second directive))
- (location-function-p (second directive))))))
- (and (length=n-p directive 1)
- (location-designator-p (first directive)))))))
-
- (defun validate-output-translations-form (form &key location)
- (validate-configuration-form
- form
- :output-translations
- 'validate-output-translations-directive
- :location location :invalid-form-reporter 'invalid-output-translation))
-
- (defun validate-output-translations-file (file)
- (validate-configuration-file
- file 'validate-output-translations-form :description "output translations"))
-
- (defun validate-output-translations-directory (directory)
- (validate-configuration-directory
- directory :output-translations 'validate-output-translations-directive
- :invalid-form-reporter 'invalid-output-translation))
-
- (defun parse-output-translations-string (string &key location)
- (cond
- ((or (null string) (equal string ""))
- '(:output-translations :inherit-configuration))
- ((not (stringp string))
- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
- ((eql (char string 0) #\")
- (parse-output-translations-string (read-from-string string) :location location))
- ((eql (char string 0) #\()
- (validate-output-translations-form (read-from-string string) :location location))
- (t
- (loop
- :with inherit = nil
- :with directives = ()
- :with start = 0
- :with end = (length string)
- :with source = nil
- :with separator = (inter-directory-separator)
- :for i = (or (position separator string :start start) end) :do
- (let ((s (subseq string start i)))
- (cond
- (source
- (push (list source (if (equal "" s) nil s)) directives)
- (setf source nil))
- ((equal "" s)
- (when inherit
- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
- string))
- (setf inherit t)
- (push :inherit-configuration directives))
- (t
- (setf source s)))
- (setf start (1+ i))
- (when (> start end)
- (when source
- (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
- string))
- (unless inherit
- (push :ignore-inherited-configuration directives))
- (return `(:output-translations ,@(nreverse directives)))))))))
-
- (defparameter *default-output-translations*
- '(environment-output-translations
- user-output-translations-pathname
- user-output-translations-directory-pathname
- system-output-translations-pathname
- system-output-translations-directory-pathname))
-
- (defun wrapping-output-translations ()
- `(:output-translations
- ;; Some implementations have precompiled ASDF systems,
- ;; so we must disable translations for implementation paths.
- #+(or #|clozure|# ecl mkcl sbcl)
- ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
- (when h `(((,h ,*wild-path*) ()))))
- #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
- ;; All-import, here is where we want user stuff to be:
- :inherit-configuration
- ;; These are for convenience, and can be overridden by the user:
- #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
- #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
- ;; We enable the user cache by default, and here is the place we do:
- :enable-user-cache))
-
- (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
- (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
-
- (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"))
-
- (defgeneric process-output-translations (spec &key inherit collect))
-
- (defun inherit-output-translations (inherit &key collect)
- (when inherit
- (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
-
- (defun* (process-output-translations-directive) (directive &key inherit collect)
- (if (atom directive)
- (ecase directive
- ((:enable-user-cache)
- (process-output-translations-directive '(t :user-cache) :collect collect))
- ((:disable-cache)
- (process-output-translations-directive '(t t) :collect collect))
- ((:inherit-configuration)
- (inherit-output-translations inherit :collect collect))
- ((:ignore-inherited-configuration :ignore-invalid-entries nil)
- nil))
- (let ((src (first directive))
- (dst (second directive)))
- (if (eq src :include)
- (when dst
- (process-output-translations (pathname dst) :inherit nil :collect collect))
- (when src
- (let ((trusrc (or (eql src t)
- (let ((loc (resolve-location src :ensure-directory t :wilden t)))
- (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
- (cond
- ((location-function-p dst)
- (funcall collect
- (list trusrc
- (if (symbolp (second dst))
- (fdefinition (second dst))
- (eval (second dst))))))
- ((eq dst t)
- (funcall collect (list trusrc t)))
- (t
- (let* ((trudst (if dst
- (resolve-location dst :ensure-directory t :wilden t)
- trusrc)))
- (funcall collect (list trudst t))
- (funcall collect (list trusrc trudst)))))))))))
-
- (defmethod process-output-translations ((x symbol) &key
- (inherit *default-output-translations*)
- collect)
- (process-output-translations (funcall x) :inherit inherit :collect collect))
- (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
- (cond
- ((directory-pathname-p pathname)
- (process-output-translations (validate-output-translations-directory pathname)
- :inherit inherit :collect collect))
- ((probe-file* pathname :truename *resolve-symlinks*)
- (process-output-translations (validate-output-translations-file pathname)
- :inherit inherit :collect collect))
- (t
- (inherit-output-translations inherit :collect collect))))
- (defmethod process-output-translations ((string string) &key inherit collect)
- (process-output-translations (parse-output-translations-string string)
- :inherit inherit :collect collect))
- (defmethod process-output-translations ((x null) &key inherit collect)
- (declare (ignorable x))
- (inherit-output-translations inherit :collect collect))
- (defmethod process-output-translations ((form cons) &key inherit collect)
- (dolist (directive (cdr (validate-output-translations-form form)))
- (process-output-translations-directive directive :inherit inherit :collect collect)))
-
- (defun compute-output-translations (&optional parameter)
- "read the configuration, return it"
- (remove-duplicates
- (while-collecting (c)
- (inherit-output-translations
- `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
- :test 'equal :from-end t))
-
- (defvar *output-translations-parameter* nil)
-
- (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
- "read the configuration, initialize the internal configuration variable,
-return the configuration"
- (setf *output-translations-parameter* parameter
- (output-translations) (compute-output-translations parameter)))
-
- (defun disable-output-translations ()
- "Initialize output translations in a way that maps every file to itself,
-effectively disabling the output translation facility."
- (initialize-output-translations
- '(:output-translations :disable-cache :ignore-inherited-configuration)))
-
- ;; 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-output-translations ()
- (if (output-translations-initialized-p)
- (output-translations)
- (initialize-output-translations)))
-
- (defun* (apply-output-translations) (path)
- #+cormanlisp (resolve-symlinks* path) #-cormanlisp
- (etypecase path
- (logical-pathname
- path)
- ((or pathname string)
- (ensure-output-translations)
- (loop* :with p = (resolve-symlinks* path)
- :for (source destination) :in (car *output-translations*)
- :for root = (when (or (eq source t)
- (and (pathnamep source)
- (not (absolute-pathname-p source))))
- (pathname-root p))
- :for absolute-source = (cond
- ((eq source t) (wilden root))
- (root (merge-pathnames* source root))
- (t source))
- :when (or (eq source t) (pathname-match-p p absolute-source))
- :return (translate-pathname* p absolute-source destination root source)
- :finally (return p)))))
-
- ;; Hook into asdf/driver's output-translation mechanism
- (setf *output-translation-function* 'apply-output-translations)
-
- #+abcl
- (defun translate-jar-pathname (source wildcard)
- (declare (ignore wildcard))
- (flet ((normalize-device (pathname)
- (if (find :windows *features*)
- pathname
- (make-pathname :defaults pathname :device :unspecific))))
- (let* ((jar
- (pathname (first (pathname-device source))))
- (target-root-directory-namestring
- (format nil "/___jar___file___root___/~@[~A/~]"
- (and (find :windows *features*)
- (pathname-device jar))))
- (relative-source
- (relativize-pathname-directory source))
- (relative-jar
- (relativize-pathname-directory (ensure-directory-pathname jar)))
- (target-root-directory
- (normalize-device
- (pathname-directory-pathname
- (parse-namestring target-root-directory-namestring))))
- (target-root
- (merge-pathnames* relative-jar target-root-directory))
- (target
- (merge-pathnames* relative-source target-root)))
- (normalize-device (apply-output-translations target))))))
-
-;;;; -----------------------------------------------------------------
-;;;; Source Registry Configuration, by Francois-Rene Rideau
-;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
-
-(asdf/package:define-package :asdf/source-registry
- (:recycle :asdf/source-registry :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
- (:export
- #:*source-registry* #:*source-registry-parameter* #:*default-source-registries*
- #:invalid-source-registry
- #:source-registry #:source-registry-initialized-p
- #:initialize-source-registry #:clear-source-registry #:*source-registry*
- #:disable-source-registry #:ensure-source-registry #:*source-registry-parameter*
- #:*default-source-registry-exclusions* #:*source-registry-exclusions*
- #:*wild-asd* #:directory-asd-files #:register-asd-directory
- #:collect-asds-in-directory #:collect-sub*directories-asd-files
- #:validate-source-registry-directive #:validate-source-registry-form
- #:validate-source-registry-file #:validate-source-registry-directory
- #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
- #:user-source-registry #:system-source-registry
- #:user-source-registry-directory #:system-source-registry-directory
- #:environment-source-registry #:process-source-registry
- #:compute-source-registry #:flatten-source-registry
- #:sysdef-source-registry-search))
-(in-package :asdf/source-registry)
-
-(with-upgradability ()
- (define-condition invalid-source-registry (invalid-configuration warning)
- ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-
- ;; Using ack 1.2 exclusions
- (defvar *default-source-registry-exclusions*
- '(".bzr" ".cdv"
- ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
- ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
- "_sgbak" "autom4te.cache" "cover_db" "_build"
- "debian")) ;; debian often builds stuff under the debian directory... BAD.
-
- (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
-
- (defvar *source-registry* nil
- "Either NIL (for uninitialized), or an equal hash-table, mapping
-system names to pathnames of .asd files")
-
- (defun source-registry-initialized-p ()
- (typep *source-registry* 'hash-table))
-
- (defun clear-source-registry ()
- "Undoes any initialization of the source registry."
- (setf *source-registry* nil)
- (values))
- (register-clear-configuration-hook 'clear-source-registry)
-
- (defparameter *wild-asd*
- (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
-
- (defun directory-asd-files (directory)
- (directory-files directory *wild-asd*))
-
- (defun collect-asds-in-directory (directory collect)
- (map () collect (directory-asd-files directory)))
-
- (defun collect-sub*directories-asd-files
- (directory &key (exclude *default-source-registry-exclusions*) collect)
- (collect-sub*directories
- directory
- (constantly t)
- #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
- #'(lambda (dir) (collect-asds-in-directory dir collect))))
-
- (defun validate-source-registry-directive (directive)
- (or (member directive '(:default-registry))
- (and (consp directive)
- (let ((rest (rest directive)))
- (case (first directive)
- ((:include :directory :tree)
- (and (length=n-p rest 1)
- (location-designator-p (first rest))))
- ((:exclude :also-exclude)
- (every #'stringp rest))
- ((:default-registry)
- (null rest)))))))
-
- (defun validate-source-registry-form (form &key location)
- (validate-configuration-form
- form :source-registry 'validate-source-registry-directive
- :location location :invalid-form-reporter 'invalid-source-registry))
-
- (defun validate-source-registry-file (file)
- (validate-configuration-file
- file 'validate-source-registry-form :description "a source registry"))
-
- (defun validate-source-registry-directory (directory)
- (validate-configuration-directory
- directory :source-registry 'validate-source-registry-directive
- :invalid-form-reporter 'invalid-source-registry))
-
- (defun parse-source-registry-string (string &key location)
- (cond
- ((or (null string) (equal string ""))
- '(:source-registry :inherit-configuration))
- ((not (stringp string))
- (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
- ((find (char string 0) "\"(")
- (validate-source-registry-form (read-from-string string) :location location))
- (t
- (loop
- :with inherit = nil
- :with directives = ()
- :with start = 0
- :with end = (length string)
- :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)
- (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
- dir))
- (cond
- ((equal "" s) ; empty element: inherit
- (when inherit
- (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
- string))
- (setf inherit t)
- (push ':inherit-configuration directives))
- ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
- (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
- (t
- (push `(:directory ,(check s)) directives))))
- (cond
- (pos
- (setf start (1+ pos)))
- (t
- (unless inherit
- (push '(:ignore-inherited-configuration) directives))
- (return `(:source-registry ,@(nreverse directives))))))))))
-
- (defun register-asd-directory (directory &key recurse exclude collect)
- (if (not recurse)
- (collect-asds-in-directory directory collect)
- (collect-sub*directories-asd-files
- directory :exclude exclude :collect collect)))
-
- (defparameter *default-source-registries*
- '(environment-source-registry
- user-source-registry
- user-source-registry-directory
- system-source-registry
- system-source-registry-directory
- default-source-registry))
-
- (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
- (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
-
- (defun wrapping-source-registry ()
- `(:source-registry
- #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
- #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
- :inherit-configuration
- #+cmu (:tree #p"modules:")
- #+scl (:tree #p"file://modules/")))
- (defun default-source-registry ()
- `(:source-registry
- #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
- ,@(loop :for dir :in
- `(,@(when (os-unix-p)
- `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
- (subpathname (user-homedir-pathname) ".local/share/"))
- ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
- '("/usr/local/share" "/usr/share"))))
- ,@(when (os-windows-p)
- (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
- :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
- :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
- :inherit-configuration))
- (defun user-source-registry (&key (direction :input))
- (in-user-configuration-directory *source-registry-file* :direction direction))
- (defun system-source-registry (&key (direction :input))
- (in-system-configuration-directory *source-registry-file* :direction direction))
- (defun user-source-registry-directory (&key (direction :input))
- (in-user-configuration-directory *source-registry-directory* :direction direction))
- (defun system-source-registry-directory (&key (direction :input))
- (in-system-configuration-directory *source-registry-directory* :direction direction))
- (defun environment-source-registry ()
- (getenv "CL_SOURCE_REGISTRY"))
-
- (defgeneric* (process-source-registry) (spec &key inherit register))
-
- (defun* (inherit-source-registry) (inherit &key register)
- (when inherit
- (process-source-registry (first inherit) :register register :inherit (rest inherit))))
-
- (defun* (process-source-registry-directive) (directive &key inherit register)
- (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
- (ecase kw
- ((:include)
- (destructuring-bind (pathname) rest
- (process-source-registry (resolve-location pathname) :inherit nil :register register)))
- ((:directory)
- (destructuring-bind (pathname) rest
- (when pathname
- (funcall register (resolve-location pathname :ensure-directory t)))))
- ((:tree)
- (destructuring-bind (pathname) rest
- (when pathname
- (funcall register (resolve-location pathname :ensure-directory t)
- :recurse t :exclude *source-registry-exclusions*))))
- ((:exclude)
- (setf *source-registry-exclusions* rest))
- ((:also-exclude)
- (appendf *source-registry-exclusions* rest))
- ((:default-registry)
- (inherit-source-registry '(default-source-registry) :register register))
- ((:inherit-configuration)
- (inherit-source-registry inherit :register register))
- ((:ignore-inherited-configuration)
- nil)))
- nil)
-
- (defmethod process-source-registry ((x symbol) &key inherit register)
- (process-source-registry (funcall x) :inherit inherit :register register))
- (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
- (cond
- ((directory-pathname-p pathname)
- (let ((*here-directory* (resolve-symlinks* pathname)))
- (process-source-registry (validate-source-registry-directory pathname)
- :inherit inherit :register register)))
- ((probe-file* pathname :truename *resolve-symlinks*)
- (let ((*here-directory* (pathname-directory-pathname pathname)))
- (process-source-registry (validate-source-registry-file pathname)
- :inherit inherit :register register)))
- (t
- (inherit-source-registry inherit :register register))))
- (defmethod process-source-registry ((string string) &key inherit register)
- (process-source-registry (parse-source-registry-string string)
- :inherit inherit :register register))
- (defmethod process-source-registry ((x null) &key inherit register)
- (declare (ignorable x))
- (inherit-source-registry inherit :register register))
- (defmethod process-source-registry ((form cons) &key inherit register)
- (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
- (dolist (directive (cdr (validate-source-registry-form form)))
- (process-source-registry-directive directive :inherit inherit :register register))))
-
- (defun flatten-source-registry (&optional parameter)
- (remove-duplicates
- (while-collecting (collect)
- (with-pathname-defaults () ;; be location-independent
- (inherit-source-registry
- `(wrapping-source-registry
- ,parameter
- ,@*default-source-registries*)
- :register #'(lambda (directory &key recurse exclude)
- (collect (list directory :recurse recurse :exclude exclude))))))
- :test 'equal :from-end t))
-
- ;; Will read the configuration and initialize all internal variables.
- (defun compute-source-registry (&optional parameter (registry *source-registry*))
- (dolist (entry (flatten-source-registry parameter))
- (destructuring-bind (directory &key recurse exclude) entry
- (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
- (register-asd-directory
- directory :recurse recurse :exclude exclude :collect
- #'(lambda (asd)
- (let* ((name (pathname-name asd))
- (name (if (typep asd 'logical-pathname)
- ;; logical pathnames are upper-case,
- ;; at least in the CLHS and on SBCL,
- ;; yet (coerce-name :foo) is lower-case.
- ;; won't work well with (load-system "Foo")
- ;; instead of (load-system 'foo)
- (string-downcase name)
- name)))
- (cond
- ((gethash name registry) ; already shadowed by something else
- nil)
- ((gethash name h) ; conflict at current level
- (when *verbose-out*
- (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
- found several entries for ~A - picking ~S over ~S~:>")
- directory recurse name (gethash name h) asd)))
- (t
- (setf (gethash name registry) asd)
- (setf (gethash name h) asd))))))
- h)))
- (values))
-
- (defvar *source-registry-parameter* nil)
-
- (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
- ;; Record the parameter used to configure the registry
- (setf *source-registry-parameter* parameter)
- ;; Clear the previous registry database:
- (setf *source-registry* (make-hash-table :test 'equal))
- ;; Do it!
- (compute-source-registry parameter))
-
- ;; 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) to make sure the source registry is initialized.
- ;; However, it will do so *without* a parameter, at which point it
- ;; will be too late to provide a parameter to this function, though
- ;; you may override the configuration explicitly by calling
- ;; initialize-source-registry directly with your parameter.
- (defun ensure-source-registry (&optional parameter)
- (unless (source-registry-initialized-p)
- (initialize-source-registry parameter))
- (values))
-
- (defun sysdef-source-registry-search (system)
- (ensure-source-registry)
- (values (gethash (primary-system-name system) *source-registry*))))
-
-
-;;;; -------------------------------------------------------------------------
-;;; Internal hacks for backward-compatibility
-
-(asdf/package:define-package :asdf/backward-internals
- (:recycle :asdf/backward-internals :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/system :asdf/component :asdf/operation
- :asdf/find-system :asdf/action :asdf/lisp-action)
- (:export ;; for internal use
- #:load-sysdef #:make-temporary-package
- #:%refresh-component-inline-methods
- #:%resolve-if-component-dep-fails
- #:make-sub-operation
- #:load-sysdef #:make-temporary-package))
-(in-package :asdf/backward-internals)
-
-;;;; Backward compatibility with "inline methods"
-(with-upgradability ()
- (defparameter +asdf-methods+
- '(perform-with-restarts perform explain output-files operation-done-p))
-
- (defun %remove-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
- ;; But this is hardly performance-critical
- #'(lambda (m)
- (remove-method (symbol-function name) m))
- (component-inline-methods component)))
- (component-inline-methods component) nil)
-
- (defun %define-component-inline-methods (ret rest)
- (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? &rest rest) value
- (multiple-value-bind (qual args-and-body)
- (if (symbolp qual?)
- (values (list qual?) rest)
- (values nil (cons qual? rest)))
- (destructuring-bind ((o c) &body body) args-and-body
- (pushnew
- (eval `(defmethod ,name ,@qual ((,o ,op) (,c (eql ,ret)))
- ,@body))
- (component-inline-methods ret)))))))))
-
- (defun %refresh-component-inline-methods (component rest)
- ;; clear methods, then add the new ones
- (%remove-component-inline-methods component)
- (%define-component-inline-methods component rest)))
+ (defun %refresh-component-inline-methods (component rest)
+ ;; clear methods, then add the new ones
+ (%remove-component-inline-methods component)
+ (%define-component-inline-methods component rest)))
;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute
;; and the companion asdf:feature pseudo-dependency.
#:defsystem #:register-system-definition
#:class-for-type #:*default-component-class*
#:determine-system-directory #:parse-component-form
- #:duplicate-names #:sysdef-error-component #:check-component-input))
+ #:duplicate-names #:non-toplevel-system #:non-system-system
+ #:sysdef-error-component #:check-component-input))
(in-package :asdf/defsystem)
;;; Pathname
(or (loop :for symbol :in (list
type
(find-symbol* type *package* nil)
- (find-symbol* type :asdf/interface nil))
- :for class = (and symbol (find-class* symbol nil))
+ (find-symbol* type :asdf/interface nil)
+ (and (stringp type) (safe-read-from-string type :package :asdf/interface)))
+ :for class = (and symbol (symbolp symbol) (find-class* symbol nil))
:when (and class
(#-cormanlisp subtypep #+cormanlisp cl::subclassp
class (find-class* 'component)))
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
(:report (lambda (c s)
- (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
+ (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
(duplicate-names-name c)))))
+ (define-condition non-system-system (system-definition-error)
+ ((name :initarg :name :reader non-system-system-name)
+ (class-name :initarg :class-name :reader non-system-system-class-name))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>")
+ (non-system-system-name c) (non-system-system-class-name c) 'system))))
+
+ (define-condition non-toplevel-system (system-definition-error)
+ ((parent :initarg :parent :reader non-toplevel-system-parent)
+ (name :initarg :name :reader non-toplevel-system-name))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>")
+ (non-toplevel-system-parent c) (non-toplevel-system-name c)))))
+
(defun sysdef-error-component (msg type name value)
(sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>"))
type name value))
(sysdef-error-component ":components must be NIL or a list of components."
type name components)))
- (defun normalize-version (form pathname)
- (etypecase form
- ((or string null) form)
- (real
- (asdf-message "Invalid use of real number ~D as :version in ~S. Substituting a string."
- form pathname)
- (format nil "~D" form)) ;; 1.0 is "1.0"
- (cons
- (ecase (first form)
- ((:read-file-form)
- (destructuring-bind (subpath &key (at 0)) (rest form)
- (safe-read-file-form (subpathname pathname subpath) :at at))))))))
+ (defun* (normalize-version) (form &key pathname component parent)
+ (labels ((invalid (&optional (continuation "using NIL instead"))
+ (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
+ form component parent pathname continuation))
+ (invalid-parse (control &rest args)
+ (unless (builtin-system-p (find-component parent component))
+ (apply 'warn control args)
+ (invalid))))
+ (if-let (v (typecase form
+ ((or string null) form)
+ (real
+ (invalid "Substituting a string")
+ (format nil "~D" form)) ;; 1.0 becomes "1.0"
+ (cons
+ (case (first form)
+ ((:read-file-form)
+ (destructuring-bind (subpath &key (at 0)) (rest form)
+ (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user)))
+ ((:read-file-line)
+ (destructuring-bind (subpath &key (at 0)) (rest form)
+ (read-file-lines (subpathname pathname subpath) :at at)))
+ (otherwise
+ (invalid))))
+ (t
+ (invalid))))
+ (if-let (pv (parse-version v #'invalid-parse))
+ (unparse-version pv)
+ (invalid))))))
;;; Main parsing function
;; remove-plist-keys form. important to keep them in sync
components pathname perform explain output-files operation-done-p
weakly-depends-on depends-on serial
- do-first if-component-dep-fails (version nil versionp)
+ do-first if-component-dep-fails version
;; list ends
&allow-other-keys) options
(declare (ignorable perform explain output-files operation-done-p builtin-system-p))
(class-for-type parent type))))
(error 'duplicate-names :name name))
(when do-first (error "DO-FIRST is not supported anymore as of ASDF 3"))
- (let* ((args `(:name ,(coerce-name name)
+ (let* ((name (coerce-name name))
+ (args `(:name ,name
:pathname ,pathname
,@(when parent `(:parent ,parent))
,@(remove-plist-keys
:perform :explain :output-files :operation-done-p
:weakly-depends-on :depends-on :serial)
rest)))
- (component (find-component parent name)))
- (when weakly-depends-on
- ;; ASDF4: deprecate this feature and remove it.
- (appendf depends-on
- (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
- (when previous-serial-component
- (push previous-serial-component depends-on))
+ (component (find-component parent name))
+ (class (class-for-type parent type)))
+ (when (and parent (subtypep class 'system))
+ (error 'non-toplevel-system :parent parent :name name))
(if component ; preserve identity
(apply 'reinitialize-instance component args)
- (setf component (apply 'make-instance (class-for-type parent type) args)))
+ (setf component (apply 'make-instance class args)))
(component-pathname component) ; eagerly compute the absolute pathname
- (let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous
+ (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
(when (and (typep component 'system) (not bspp))
- (setf (builtin-system-p component) (lisp-implementation-pathname-p sysdir)))
- (setf version (normalize-version version sysdir)))
- (when (and versionp version (not (parse-version version nil)))
- (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
- version name parent))
+ (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
+ (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
;; A better fix is required.
(setf (slot-value component 'version) version)
:collect c
:when serial :do (setf previous-component name)))
(compute-children-by-name component))
+ (when previous-serial-component
+ (push previous-serial-component depends-on))
+ (when weakly-depends-on
+ ;; ASDF4: deprecate this feature and remove it.
+ (appendf depends-on
+ (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on)))
;; Used by POIU. ASDF4: rename to component-depends-on?
- (setf (component-sibling-dependencies component) depends-on)
+ (setf (component-sideway-dependencies component) depends-on)
(%refresh-component-inline-methods component rest)
(when if-component-dep-fails
(%resolve-if-component-dep-fails if-component-dep-fails component))
(component-options (remove-plist-key :class options))
(defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
(resolve-dependency-spec nil spec))))
+ (setf (gethash name *systems-being-defined*) system)
(apply 'load-systems defsystem-dependencies)
;; We change-class AFTER we loaded the defsystem-depends-on
;; since the class might be defined as part of those.
(let ((class (class-for-type nil class)))
+ (unless (subtypep class 'system)
+ (error 'non-system-system :name name :class-name (class-name class)))
(unless (eq (type-of system) class)
(change-class system class)))
(parse-component-form
:pathname (determine-system-directory pathname)
component-options)))))
- (defmacro defsystem (name &body options)
- `(apply 'register-system-definition ',name ',options)))
-;;;; -------------------------------------------------------------------------
-;;;; ASDF-Bundle
+ (defmacro defsystem (name &body options)
+ `(apply 'register-system-definition ',name ',options)))
+;;;; -------------------------------------------------------------------------
+;;;; ASDF-Bundle
+
+(asdf/package:define-package :asdf/bundle
+ (:recycle :asdf/bundle :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
+ :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
+ (:export
+ #:bundle-op #:bundle-op-build-args #:bundle-type
+ #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files
+ #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p
+ #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
+ #:lib-op #:monolithic-lib-op
+ #:dll-op #:monolithic-dll-op
+ #:binary-op #:monolithic-binary-op
+ #:program-op #:compiled-file #:precompiled-system #:prebuilt-system
+ #:user-system-p #:user-system #:trivial-system-p
+ #+ecl #:make-build
+ #:register-pre-built-system
+ #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
+(in-package :asdf/bundle)
+
+(with-upgradability ()
+ (defclass bundle-op (operation)
+ ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
+ (name-suffix :initarg :name-suffix :initform nil)
+ (bundle-type :initform :no-output-file :reader bundle-type)
+ #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
+ #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
+ #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
+
+ (defclass bundle-compile-op (bundle-op basic-compile-op)
+ ()
+ (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files"))
+
+ ;; create a single fasl for the entire library
+ (defclass basic-fasl-op (bundle-compile-op)
+ ((bundle-type :initform :fasl)))
+ (defclass prepare-fasl-op (sideway-operation)
+ ((sideway-operation :initform 'load-fasl-op)))
+ (defclass fasl-op (basic-fasl-op selfward-operation)
+ ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op))))
+ (defclass load-fasl-op (basic-load-op selfward-operation)
+ ((selfward-operation :initform '(prepare-op fasl-op))))
+
+ ;; NB: since the monolithic-op's can't be sideway-operation's,
+ ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's,
+ ;; we'd have to have the monolithic-op not inherit from the main op,
+ ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above.
+
+ (defclass no-ld-flags-op (operation) ())
+
+ (defclass lib-op (bundle-compile-op no-ld-flags-op)
+ ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
+ (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it."
+ #-(or ecl mkcl) "just compile the system"))
+
+ (defclass dll-op (bundle-compile-op selfward-operation no-ld-flags-op)
+ ((bundle-type :initform :dll))
+ (:documentation "compile the system and produce dynamic (.so/.dll) library for it."))
+
+ (defclass binary-op (basic-compile-op selfward-operation)
+ ((selfward-operation :initform '(fasl-op lib-op)))
+ (:documentation "produce fasl and asd files for the system"))
+
+ (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
+
+ (defclass monolithic-bundle-op (monolithic-op bundle-op)
+ ((prologue-code :accessor monolithic-op-prologue-code)
+ (epilogue-code :accessor monolithic-op-epilogue-code)))
+
+ (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op)
+ ()
+ (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems"))
+
+ (defclass monolithic-binary-op (monolithic-op binary-op)
+ ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op)))
+ (:documentation "produce fasl and asd files for combined system and dependencies."))
+
+ (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) ()
+ (:documentation "Create a single fasl for the system and its dependencies."))
+
+ (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op no-ld-flags-op)
+ ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))
+ (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies."
+ #-(or ecl mkcl) "Compile a system and its dependencies."))
+
+ (defclass monolithic-dll-op (monolithic-bundle-compile-op sideway-operation selfward-operation no-ld-flags-op)
+ ((bundle-type :initform :dll))
+ (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies."))
+
+ (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op)
+ #-(or mkcl ecl) (monolithic-bundle-op selfward-operation)
+ ((bundle-type :initform :program)
+ #-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op))
+ (:documentation "create an executable file from the system and its dependencies"))
+
+ (defun bundle-pathname-type (bundle-type)
+ (etypecase bundle-type
+ ((eql :no-output-file) nil) ;; should we error out instead?
+ ((or null string) bundle-type)
+ ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
+ #+ecl
+ ((member :binary :dll :lib :shared-library :static-library :program :object :program)
+ (compile-file-type :type bundle-type))
+ ((eql :binary) "image")
+ ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
+ ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
+ ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
+
+ (defun bundle-output-files (o c)
+ (when (input-files o c)
+ (let ((bundle-type (bundle-type o)))
+ (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
+ (let ((name (or (component-build-pathname c)
+ (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
+ (type (bundle-pathname-type bundle-type)))
+ (values (list (subpathname (component-pathname c) name :type type))
+ (eq (type-of o) (component-build-operation c))))))))
+
+ (defmethod output-files ((o bundle-op) (c system))
+ (bundle-output-files o c))
+
+ #-(or ecl mkcl)
+ (defmethod perform ((o program-op) (c system))
+ (let ((output-file (output-file o c)))
+ (setf *image-entry-point* (ensure-function (component-entry-point c)))
+ (dump-image output-file :executable t)))
+
+ (defclass compiled-file (file-component)
+ ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
+
+ (defclass precompiled-system (system)
+ ((build-pathname :initarg :fasl)))
+
+ (defclass prebuilt-system (system)
+ ((build-pathname :initarg :static-library :initarg :lib
+ :accessor prebuilt-system-static-library))))
+
+
+;;;
+;;; BUNDLE-OP
+;;;
+;;; This operation takes all components from one or more systems and
+;;; creates a single output file, which may be
+;;; a FASL, a statically linked library, a shared library, etc.
+;;; The different targets are defined by specialization.
+;;;
+(with-upgradability ()
+ (defun operation-monolithic-p (op)
+ (typep op 'monolithic-op))
+
+ (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
+ &key (name-suffix nil name-suffix-p)
+ &allow-other-keys)
+ (declare (ignorable initargs name-suffix))
+ (unless name-suffix-p
+ (setf (slot-value instance 'name-suffix)
+ (unless (typep instance 'program-op)
+ (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames
+ (when (typep instance 'monolithic-bundle-op)
+ (destructuring-bind (&rest original-initargs
+ &key lisp-files prologue-code epilogue-code
+ &allow-other-keys)
+ (operation-original-initargs instance)
+ (setf (operation-original-initargs instance)
+ (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
+ (monolithic-op-prologue-code instance) prologue-code
+ (monolithic-op-epilogue-code instance) epilogue-code)
+ #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
+ #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
+ (setf (bundle-op-build-args instance)
+ (remove-plist-keys '(:type :monolithic :name-suffix)
+ (operation-original-initargs instance))))
+
+ (defmethod bundle-op-build-args :around ((o no-ld-flags-op))
+ (declare (ignorable o))
+ (let ((args (call-next-method)))
+ (remf args :ld-flags)
+ args))
+
+ (defun bundlable-file-p (pathname)
+ (let ((type (pathname-type pathname)))
+ (declare (ignorable type))
+ (or #+ecl (or (equalp type (compile-file-type :type :object))
+ (equalp type (compile-file-type :type :static-library)))
+ #+mkcl (equalp type (compile-file-type :fasl-p nil))
+ #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
+
+ (defgeneric* (trivial-system-p) (component))
+
+ (defun user-system-p (s)
+ (and (typep s 'system)
+ (not (builtin-system-p s))
+ (not (trivial-system-p s)))))
+
+(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
+ (deftype user-system () '(and system (satisfies user-system-p))))
+
+;;;
+;;; First we handle monolithic bundles.
+;;; These are standalone systems which contain everything,
+;;; including other ASDF systems required by the current one.
+;;; A PROGRAM is always monolithic.
+;;;
+;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
+;;;
+(with-upgradability ()
+ (defmethod component-depends-on ((o bundle-compile-op) (c system))
+ `(,(if (operation-monolithic-p o)
+ `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op
+ ,@(required-components c :other-systems t :component-type 'system
+ :goal-operation (find-operation o 'load-op)
+ :keep-operation 'compile-op))
+ `(compile-op
+ ,@(required-components c :other-systems nil :component-type '(not system)
+ :goal-operation (find-operation o 'load-op)
+ :keep-operation 'compile-op)))
+ ,@(call-next-method)))
+
+ (defmethod component-depends-on :around ((o bundle-op) (c component))
+ (declare (ignorable o c))
+ (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
+ `((,op ,c))
+ (call-next-method)))
+
+ (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
+ ;; This file selects output files from direct dependencies;
+ ;; your component-depends-on method better gathered the correct dependencies in the correct order.
+ (while-collecting (collect)
+ (map-direct-dependencies
+ o c #'(lambda (sub-o sub-c)
+ (loop :for f :in (funcall key sub-o sub-c)
+ :when (funcall test f) :do (collect f))))))
+
+ (defmethod input-files ((o bundle-compile-op) (c system))
+ (unless (eq (bundle-type o) :no-output-file)
+ (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)))
+
+ (defun select-bundle-operation (type &optional monolithic)
+ (ecase type
+ ((:binary)
+ (if monolithic 'monolithic-binary-op 'binary-op))
+ ((:dll :shared-library)
+ (if monolithic 'monolithic-dll-op 'dll-op))
+ ((:lib :static-library)
+ (if monolithic 'monolithic-lib-op 'lib-op))
+ ((:fasl)
+ (if monolithic 'monolithic-fasl-op 'fasl-op))
+ ((:program)
+ 'program-op)))
+
+ (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
+ (move-here nil move-here-p)
+ &allow-other-keys)
+ (let* ((operation-name (select-bundle-operation type monolithic))
+ (move-here-path (if (and move-here
+ (typep move-here '(or pathname string)))
+ (pathname move-here)
+ (system-relative-pathname system "asdf-output/")))
+ (operation (apply #'operate operation-name
+ system
+ (remove-plist-keys '(:monolithic :type :move-here) args)))
+ (system (find-system system))
+ (files (and system (output-files operation system))))
+ (if (or move-here (and (null move-here-p)
+ (member operation-name '(:program :binary))))
+ (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
+ :for f :in files
+ :for new-f = (make-pathname :name (pathname-name f)
+ :type (pathname-type f)
+ :defaults dest-path)
+ :do (rename-file-overwriting-target f new-f)
+ :collect new-f)
+ files))))
+
+;;;
+;;; LOAD-FASL-OP
+;;;
+;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
+;;;
+(with-upgradability ()
+ (defmethod component-depends-on ((o load-fasl-op) (c system))
+ (declare (ignorable o))
+ `((,o ,@(loop :for dep :in (component-sideway-dependencies c)
+ :collect (resolve-dependency-spec c dep)))
+ (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
+ ,@(call-next-method)))
+
+ (defmethod input-files ((o load-fasl-op) (c system))
+ (when (user-system-p c)
+ (output-files (find-operation o 'fasl-op) c)))
+
+ (defmethod perform ((o load-fasl-op) c)
+ (declare (ignorable o c))
+ nil)
+
+ (defmethod perform ((o load-fasl-op) (c system))
+ (when (input-files o c)
+ (perform-lisp-load-fasl o c)))
+
+ (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
+ (mark-operation-done (find-operation o 'load-op) c)))
+
+;;;
+;;; PRECOMPILED FILES
+;;;
+;;; This component can be used to distribute ASDF systems in precompiled form.
+;;; Only useful when the dependencies have also been precompiled.
+;;;
+(with-upgradability ()
+ (defmethod trivial-system-p ((s system))
+ (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
+
+ (defmethod output-files (o (c compiled-file))
+ (declare (ignorable o c))
+ nil)
+ (defmethod input-files (o (c compiled-file))
+ (declare (ignorable o))
+ (component-pathname c))
+ (defmethod perform ((o load-op) (c compiled-file))
+ (perform-lisp-load-fasl o c))
+ (defmethod perform ((o load-source-op) (c compiled-file))
+ (perform (find-operation o 'load-op) c))
+ (defmethod perform ((o load-fasl-op) (c compiled-file))
+ (perform (find-operation o 'load-op) c))
+ (defmethod perform ((o operation) (c compiled-file))
+ (declare (ignorable o c))
+ nil))
+
+;;;
+;;; Pre-built systems
+;;;
+(with-upgradability ()
+ (defmethod trivial-system-p ((s prebuilt-system))
+ (declare (ignorable s))
+ t)
+
+ (defmethod perform ((o lib-op) (c prebuilt-system))
+ (declare (ignorable o c))
+ nil)
+
+ (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
+ (declare (ignorable o c))
+ nil)
+
+ (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
+ (declare (ignorable o))
+ nil))
-(asdf/package:define-package :asdf/bundle
- (:recycle :asdf/bundle :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation
- :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate)
- (:export
- #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type
- #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
- #:monolithic-op #:monolithic-bundle-op #:direct-dependency-files
- #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
- #:program-op
- #:compiled-file #:precompiled-system #:prebuilt-system
- #:operation-monolithic-p
- #:user-system-p #:user-system #:trivial-system-p
- #+ecl #:make-build
- #:register-pre-built-system
- #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library))
-(in-package :asdf/bundle)
+;;;
+;;; PREBUILT SYSTEM CREATOR
+;;;
(with-upgradability ()
- (defclass bundle-op (operation)
- ((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
- (name-suffix :initarg :name-suffix :initform nil)
- (bundle-type :initform :no-output-file :reader bundle-type)
- #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
- #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
- #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
+ (defmethod output-files ((o binary-op) (s system))
+ (list (make-pathname :name (component-name s) :type "asd"
+ :defaults (component-pathname s))))
- (defclass fasl-op (bundle-op)
- ;; create a single fasl for the entire library
- ((bundle-type :initform :fasl)))
+ (defmethod perform ((o binary-op) (s system))
+ (let* ((inputs (input-files o s))
+ (fasl (first inputs))
+ (library (second inputs))
+ (asd (first (output-files o s)))
+ (name (if (and fasl asd) (pathname-name asd) (return-from perform)))
+ (dependencies
+ (if (operation-monolithic-p o)
+ (remove-if-not 'builtin-system-p
+ (required-components s :component-type 'system
+ :keep-operation 'load-op))
+ (while-collecting (x) ;; resolve the sideway-dependencies of s
+ (map-direct-dependencies
+ 'load-op s
+ #'(lambda (o c)
+ (when (and (typep o 'load-op) (typep c 'system))
+ (x c)))))))
+ (depends-on (mapcar 'coerce-name dependencies)))
+ (when (pathname-equal asd (system-source-file s))
+ (cerror "overwrite the asd file"
+ "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations."
+ (cons o s) asd))
+ (with-open-file (s asd :direction :output :if-exists :supersede
+ :if-does-not-exist :create)
+ (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%"
+ (operation-monolithic-p o) name)
+ (format s ";;; Built for ~A ~A on a ~A/~A ~A~%"
+ (lisp-implementation-type)
+ (lisp-implementation-version)
+ (software-type)
+ (machine-type)
+ (software-version))
+ (let ((*package* (find-package :asdf-user)))
+ (pprint `(defsystem ,name
+ :class prebuilt-system
+ :depends-on ,depends-on
+ :components ((:compiled-file ,(pathname-name fasl)))
+ ,@(when library `(:lib ,(file-namestring library))))
+ s)
+ (terpri s)))))
- (defclass load-fasl-op (basic-load-op)
- ;; load a single fasl for the entire library
- ())
+ #-(or ecl mkcl)
+ (defmethod perform ((o bundle-compile-op) (c system))
+ (let* ((input-files (input-files o c))
+ (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
+ (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
+ (output-files (output-files o c))
+ (output-file (first output-files)))
+ (assert (eq (not input-files) (not output-files)))
+ (when input-files
+ (when non-fasl-files
+ (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
+ (implementation-type) non-fasl-files))
+ (when (and (typep o 'monolithic-bundle-op)
+ (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
+ (error "prologue-code and epilogue-code are not supported on ~A"
+ (implementation-type)))
+ (with-staging-pathname (output-file)
+ (combine-fasls fasl-files output-file)))))
- (defclass lib-op (bundle-op)
- ;; On ECL: compile the system and produce linkable .a library for it.
- ;; On others: just compile the system.
- ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)))
+ (defmethod input-files ((o load-op) (s precompiled-system))
+ (declare (ignorable o))
+ (bundle-output-files (find-operation o 'fasl-op) s))
- (defclass dll-op (bundle-op)
- ;; Link together all the dynamic library used by this system into a single one.
- ((bundle-type :initform :dll)))
+ (defmethod perform ((o load-op) (s precompiled-system))
+ (perform-lisp-load-fasl o s))
- (defclass binary-op (bundle-op)
- ;; On ECL: produce lib and fasl for the system.
- ;; On "normal" Lisps: produce just the fasl.
- ())
+ (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
+ (declare (ignorable o))
+ `((load-op ,s) ,@(call-next-method))))
- (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies
+ #| ;; Example use:
+(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
+(asdf:load-system :precompiled-asdf-utils)
+|#
- (defclass monolithic-bundle-op (monolithic-op bundle-op)
- ((prologue-code :accessor monolithic-op-prologue-code)
- (epilogue-code :accessor monolithic-op-epilogue-code)))
+#+(or ecl mkcl)
+(with-upgradability ()
+ (defun uiop-library-file ()
+ (or (and (find-system :uiop nil)
+ (system-source-directory :uiop)
+ (progn
+ (operate 'lib-op :uiop)
+ (output-file 'lib-op :uiop)))
+ (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib))))
+ (defmethod input-files :around ((o program-op) (c system))
+ (let ((files (call-next-method))
+ (plan (traverse-sub-actions o c :plan-class 'sequential-plan)))
+ (unless (or (and (find-system :uiop nil)
+ (system-source-directory :uiop)
+ (plan-operates-on-p plan '("uiop")))
+ (and (system-source-directory :asdf)
+ (plan-operates-on-p plan '("asdf"))))
+ (pushnew (uiop-library-file) files :test 'pathname-equal))
+ files))
- (defclass monolithic-binary-op (binary-op monolithic-bundle-op)
- ;; On ECL: produce lib and fasl for combined system and dependencies.
- ;; On "normal" Lisps: produce an image file from system and dependencies.
- ())
+ (defun register-pre-built-system (name)
+ (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
- (defclass monolithic-fasl-op (monolithic-bundle-op fasl-op)
- ;; Create a single fasl for the system and its dependencies.
- ())
+#+ecl
+(with-upgradability ()
+ (defmethod perform ((o bundle-compile-op) (c system))
+ (let* ((object-files (input-files o c))
+ (output (output-files o c))
+ (bundle (first output))
+ (kind (bundle-type o)))
+ (when output
+ (create-image
+ bundle (append object-files (bundle-op-lisp-files o))
+ :kind kind
+ :entry-point (component-entry-point c)
+ :prologue-code
+ (when (typep o 'monolithic-bundle-op)
+ (monolithic-op-prologue-code o))
+ :epilogue-code
+ (when (typep o 'monolithic-bundle-op)
+ (monolithic-op-epilogue-code o))
+ :build-args (bundle-op-build-args o))))))
- (defclass monolithic-lib-op (monolithic-bundle-op lib-op)
- ;; ECL: Create a single linkable library for the system and its dependencies.
- ((bundle-type :initform :lib)))
+#+mkcl
+(with-upgradability ()
+ (defmethod perform ((o lib-op) (s system))
+ (apply #'compiler::build-static-library (output-file o c)
+ :lisp-object-files (input-files o s) (bundle-op-build-args o)))
- (defclass monolithic-dll-op (monolithic-bundle-op dll-op)
- ((bundle-type :initform :dll)))
+ (defmethod perform ((o basic-fasl-op) (s system))
+ (apply #'compiler::build-bundle (output-file o c) ;; second???
+ :lisp-object-files (input-files o s) (bundle-op-build-args o)))
- (defclass program-op (monolithic-bundle-op)
- ;; All: create an executable file from the system and its dependencies
- ((bundle-type :initform :program)))
+ (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
+ (declare (ignore force verbose version))
+ (apply #'operate 'binary-op system args)))
+;;;; -------------------------------------------------------------------------
+;;;; Concatenate-source
- (defun bundle-pathname-type (bundle-type)
- (etypecase bundle-type
- ((eql :no-output-file) nil) ;; should we error out instead?
- ((or null string) bundle-type)
- ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")
- #+ecl
- ((member :binary :dll :lib :static-library :program :object :program)
- (compile-file-type :type bundle-type))
- ((eql :binary) "image")
- ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll")))
- ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
- ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
+(asdf/package:define-package :asdf/concatenate-source
+ (:recycle :asdf/concatenate-source :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
+ :asdf/component :asdf/operation
+ :asdf/system :asdf/find-system :asdf/defsystem
+ :asdf/action :asdf/lisp-action :asdf/bundle)
+ (:export
+ #:concatenate-source-op
+ #:load-concatenated-source-op
+ #:compile-concatenated-source-op
+ #:load-compiled-concatenated-source-op
+ #:monolithic-concatenate-source-op
+ #:monolithic-load-concatenated-source-op
+ #:monolithic-compile-concatenated-source-op
+ #:monolithic-load-compiled-concatenated-source-op))
+(in-package :asdf/concatenate-source)
- (defun bundle-output-files (o c)
- (let ((bundle-type (bundle-type o)))
- (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type.
- (let ((name (or (component-build-pathname c)
- (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix))))
- (type (bundle-pathname-type bundle-type)))
- (values (list (subpathname (component-pathname c) name :type type))
- (eq (type-of o) (component-build-operation c)))))))
+;;;
+;;; Concatenate sources
+;;;
+(with-upgradability ()
+ (defclass basic-concatenate-source-op (bundle-op)
+ ((bundle-type :initform "lisp")))
+ (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ())
+ (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ())
+ (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ())
+
+ (defclass concatenate-source-op (basic-concatenate-source-op) ())
+ (defclass load-concatenated-source-op (basic-load-concatenated-source-op)
+ ((selfward-operation :initform '(prepare-op concatenate-source-op))))
+ (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op)
+ ((selfward-operation :initform '(prepare-op concatenate-source-op))))
+ (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
+ ((selfward-operation :initform '(prepare-op compile-concatenated-source-op))))
+
+ (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ())
+ (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op)
+ ((selfward-operation :initform 'monolithic-concatenate-source-op)))
+ (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op)
+ ((selfward-operation :initform 'monolithic-concatenate-source-op)))
+ (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op)
+ ((selfward-operation :initform 'monolithic-compile-concatenated-source-op)))
+
+ (defmethod input-files ((operation basic-concatenate-source-op) (s system))
+ (loop :with encoding = (or (component-encoding s) *default-encoding*)
+ :with other-encodings = '()
+ :with around-compile = (around-compile-hook s)
+ :with other-around-compile = '()
+ :for c :in (required-components
+ s :goal-operation 'compile-op
+ :keep-operation 'compile-op
+ :other-systems (operation-monolithic-p operation))
+ :append
+ (when (typep c 'cl-source-file)
+ (let ((e (component-encoding c)))
+ (unless (equal e encoding)
+ (pushnew e other-encodings :test 'equal)))
+ (let ((a (around-compile-hook c)))
+ (unless (equal a around-compile)
+ (pushnew a other-around-compile :test 'equal)))
+ (input-files (make-operation 'compile-op) c)) :into inputs
+ :finally
+ (when other-encodings
+ (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
+ operation encoding other-encodings))
+ (when other-around-compile
+ (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
+ operation around-compile other-around-compile))
+ (return inputs)))
+ (defmethod output-files ((o basic-compile-concatenated-source-op) (s system))
+ (lisp-compilation-output-files o s))
- (defmethod output-files ((o bundle-op) (c system))
- (bundle-output-files o c))
+ (defmethod perform ((o basic-concatenate-source-op) (s system))
+ (let ((inputs (input-files o s))
+ (output (output-file o s)))
+ (concatenate-files inputs output)))
+ (defmethod perform ((o basic-load-concatenated-source-op) (s system))
+ (perform-lisp-load-source o s))
+ (defmethod perform ((o basic-compile-concatenated-source-op) (s system))
+ (perform-lisp-compilation o s))
+ (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system))
+ (perform-lisp-load-fasl o s)))
- #-(or ecl mkcl)
- (progn
- (defmethod perform ((o program-op) (c system))
- (let ((output-file (output-file o c)))
- (setf *image-entry-point* (ensure-function (component-entry-point c)))
- (dump-image output-file :executable t)))
+;;;; ---------------------------------------------------------------------------
+;;;; asdf-output-translations
- (defmethod perform ((o monolithic-binary-op) (c system))
- (let ((output-file (output-file o c)))
- (dump-image output-file))))
+(asdf/package:define-package :asdf/output-translations
+ (:recycle :asdf/output-translations :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
+ (:export
+ #:*output-translations* #:*output-translations-parameter*
+ #:invalid-output-translation
+ #:output-translations #:output-translations-initialized-p
+ #:initialize-output-translations #:clear-output-translations
+ #:disable-output-translations #:ensure-output-translations
+ #:apply-output-translations
+ #:validate-output-translations-directive #:validate-output-translations-form
+ #:validate-output-translations-file #:validate-output-translations-directory
+ #:parse-output-translations-string #:wrapping-output-translations
+ #:user-output-translations-pathname #:system-output-translations-pathname
+ #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname
+ #:environment-output-translations #:process-output-translations
+ #:compute-output-translations
+ #+abcl #:translate-jar-pathname
+ ))
+(in-package :asdf/output-translations)
- (defclass compiled-file (file-component)
- ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb")))
+(when-upgrading () (undefine-function '(setf output-translations)))
- (defclass precompiled-system (system)
- ((build-pathname :initarg :fasl)))
+(with-upgradability ()
+ (define-condition invalid-output-translation (invalid-configuration warning)
+ ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
- (defclass prebuilt-system (system)
- ((build-pathname :initarg :static-library :initarg :lib
- :accessor prebuilt-system-static-library))))
+ (defvar *output-translations* ()
+ "Either NIL (for uninitialized), or a list of one element,
+said element itself being a sorted list of mappings.
+Each mapping is a pair of a source pathname and destination pathname,
+and the order is by decreasing length of namestring of the source pathname.")
+ (defun output-translations ()
+ (car *output-translations*))
-;;;
-;;; BUNDLE-OP
-;;;
-;;; This operation takes all components from one or more systems and
-;;; creates a single output file, which may be
-;;; a FASL, a statically linked library, a shared library, etc.
-;;; The different targets are defined by specialization.
-;;;
-(with-upgradability ()
- (defun operation-monolithic-p (op)
- (typep op 'monolithic-op))
+ (defun set-output-translations (new-value)
+ (setf *output-translations*
+ (list
+ (stable-sort (copy-list new-value) #'>
+ :key #'(lambda (x)
+ (etypecase (car x)
+ ((eql t) -1)
+ (pathname
+ (let ((directory (pathname-directory (car x))))
+ (if (listp directory) (length directory) 0))))))))
+ new-value)
+ #-gcl2.6
+ (defun* ((setf output-translations)) (new-value) (set-output-translations new-value))
+ #+gcl2.6
+ (defsetf output-translations set-output-translations)
+
+ (defun output-translations-initialized-p ()
+ (and *output-translations* t))
+
+ (defun clear-output-translations ()
+ "Undoes any initialization of the output translations."
+ (setf *output-translations* '())
+ (values))
+ (register-clear-configuration-hook 'clear-output-translations)
+
+ (defun validate-output-translations-directive (directive)
+ (or (member directive '(:enable-user-cache :disable-cache nil))
+ (and (consp directive)
+ (or (and (length=n-p directive 2)
+ (or (and (eq (first directive) :include)
+ (typep (second directive) '(or string pathname null)))
+ (and (location-designator-p (first directive))
+ (or (location-designator-p (second directive))
+ (location-function-p (second directive))))))
+ (and (length=n-p directive 1)
+ (location-designator-p (first directive)))))))
+
+ (defun validate-output-translations-form (form &key location)
+ (validate-configuration-form
+ form
+ :output-translations
+ 'validate-output-translations-directive
+ :location location :invalid-form-reporter 'invalid-output-translation))
+
+ (defun validate-output-translations-file (file)
+ (validate-configuration-file
+ file 'validate-output-translations-form :description "output translations"))
- (defmethod initialize-instance :after ((instance bundle-op) &rest initargs
- &key (name-suffix nil name-suffix-p)
- &allow-other-keys)
- (declare (ignorable initargs name-suffix))
- (unless name-suffix-p
- (setf (slot-value instance 'name-suffix)
- (unless (typep instance 'program-op)
- (if (operation-monolithic-p instance) ".all-systems" #-ecl ".system"))))
- (when (typep instance 'monolithic-bundle-op)
- (destructuring-bind (&rest original-initargs
- &key lisp-files prologue-code epilogue-code
- &allow-other-keys)
- (operation-original-initargs instance)
- (setf (operation-original-initargs instance)
- (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs)
- (monolithic-op-prologue-code instance) prologue-code
- (monolithic-op-epilogue-code instance) epilogue-code)
- #-ecl (assert (null (or lisp-files epilogue-code prologue-code)))
- #+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
- (setf (bundle-op-build-args instance)
- (remove-plist-keys '(:type :monolithic :name-suffix)
- (operation-original-initargs instance))))
+ (defun validate-output-translations-directory (directory)
+ (validate-configuration-directory
+ directory :output-translations 'validate-output-translations-directive
+ :invalid-form-reporter 'invalid-output-translation))
- (defmethod bundle-op-build-args :around ((o lib-op))
- (declare (ignorable o))
- (let ((args (call-next-method)))
- (remf args :ld-flags)
- args))
+ (defun parse-output-translations-string (string &key location)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:output-translations :inherit-configuration))
+ ((not (stringp string))
+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
+ ((eql (char string 0) #\")
+ (parse-output-translations-string (read-from-string string) :location location))
+ ((eql (char string 0) #\()
+ (validate-output-translations-form (read-from-string string) :location location))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :with source = nil
+ :with separator = (inter-directory-separator)
+ :for i = (or (position separator string :start start) end) :do
+ (let ((s (subseq string start i)))
+ (cond
+ (source
+ (push (list source (if (equal "" s) nil s)) directives)
+ (setf source nil))
+ ((equal "" s)
+ (when inherit
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
+ (setf inherit t)
+ (push :inherit-configuration directives))
+ (t
+ (setf source s)))
+ (setf start (1+ i))
+ (when (> start end)
+ (when source
+ (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>")
+ string))
+ (unless inherit
+ (push :ignore-inherited-configuration directives))
+ (return `(:output-translations ,@(nreverse directives)))))))))
- (defun bundlable-file-p (pathname)
- (let ((type (pathname-type pathname)))
- (declare (ignorable type))
- (or #+ecl (or (equal type (compile-file-type :type :object))
- (equal type (compile-file-type :type :static-library)))
- #+mkcl (equal type (compile-file-type :fasl-p nil))
- #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type)))))
+ (defparameter *default-output-translations*
+ '(environment-output-translations
+ user-output-translations-pathname
+ user-output-translations-directory-pathname
+ system-output-translations-pathname
+ system-output-translations-directory-pathname))
- (defgeneric* (trivial-system-p) (component))
+ (defun wrapping-output-translations ()
+ `(:output-translations
+ ;; Some implementations have precompiled ASDF systems,
+ ;; so we must disable translations for implementation paths.
+ #+(or #|clozure|# ecl mkcl sbcl)
+ ,@(let ((h (resolve-symlinks* (lisp-implementation-directory))))
+ (when h `(((,h ,*wild-path*) ()))))
+ #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
+ ;; All-import, here is where we want user stuff to be:
+ :inherit-configuration
+ ;; These are for convenience, and can be overridden by the user:
+ #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*"))
+ #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
+ ;; We enable the user cache by default, and here is the place we do:
+ :enable-user-cache))
- (defun user-system-p (s)
- (and (typep s 'system)
- (not (builtin-system-p s))
- (not (trivial-system-p s)))))
+ (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf"))
+ (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/"))
-(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute)
- (deftype user-system () '(and system (satisfies user-system-p))))
+ (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"))
-;;;
-;;; First we handle monolithic bundles.
-;;; These are standalone systems which contain everything,
-;;; including other ASDF systems required by the current one.
-;;; A PROGRAM is always monolithic.
-;;;
-;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL
-;;;
-(with-upgradability ()
- (defmethod component-depends-on ((o monolithic-lib-op) (c system))
- (declare (ignorable o))
- `((lib-op ,@(required-components c :other-systems t :component-type 'system
- :goal-operation 'load-op
- :keep-operation 'compile-op))))
+ (defgeneric process-output-translations (spec &key inherit collect))
- (defmethod component-depends-on ((o monolithic-fasl-op) (c system))
- (declare (ignorable o))
- `((fasl-op ,@(required-components c :other-systems t :component-type 'system
- :goal-operation 'load-fasl-op
- :keep-operation 'fasl-op))))
+ (defun inherit-output-translations (inherit &key collect)
+ (when inherit
+ (process-output-translations (first inherit) :collect collect :inherit (rest inherit))))
- (defmethod component-depends-on ((o program-op) (c system))
- (declare (ignorable o))
- #+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op) c)
- #-(or ecl mkcl) `((load-op ,c)))
+ (defun* (process-output-translations-directive) (directive &key inherit collect)
+ (if (atom directive)
+ (ecase directive
+ ((:enable-user-cache)
+ (process-output-translations-directive '(t :user-cache) :collect collect))
+ ((:disable-cache)
+ (process-output-translations-directive '(t t) :collect collect))
+ ((:inherit-configuration)
+ (inherit-output-translations inherit :collect collect))
+ ((:ignore-inherited-configuration :ignore-invalid-entries nil)
+ nil))
+ (let ((src (first directive))
+ (dst (second directive)))
+ (if (eq src :include)
+ (when dst
+ (process-output-translations (pathname dst) :inherit nil :collect collect))
+ (when src
+ (let ((trusrc (or (eql src t)
+ (let ((loc (resolve-location src :ensure-directory t :wilden t)))
+ (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc)))))
+ (cond
+ ((location-function-p dst)
+ (funcall collect
+ (list trusrc
+ (if (symbolp (second dst))
+ (fdefinition (second dst))
+ (eval (second dst))))))
+ ((eq dst t)
+ (funcall collect (list trusrc t)))
+ (t
+ (let* ((trudst (if dst
+ (resolve-location dst :ensure-directory t :wilden t)
+ trusrc)))
+ (funcall collect (list trudst t))
+ (funcall collect (list trusrc trudst)))))))))))
- (defmethod component-depends-on ((o binary-op) (c system))
- (declare (ignorable o))
- `((fasl-op ,c)
- (lib-op ,c)))
+ (defmethod process-output-translations ((x symbol) &key
+ (inherit *default-output-translations*)
+ collect)
+ (process-output-translations (funcall x) :inherit inherit :collect collect))
+ (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect)
+ (cond
+ ((directory-pathname-p pathname)
+ (process-output-translations (validate-output-translations-directory pathname)
+ :inherit inherit :collect collect))
+ ((probe-file* pathname :truename *resolve-symlinks*)
+ (process-output-translations (validate-output-translations-file pathname)
+ :inherit inherit :collect collect))
+ (t
+ (inherit-output-translations inherit :collect collect))))
+ (defmethod process-output-translations ((string string) &key inherit collect)
+ (process-output-translations (parse-output-translations-string string)
+ :inherit inherit :collect collect))
+ (defmethod process-output-translations ((x null) &key inherit collect)
+ (declare (ignorable x))
+ (inherit-output-translations inherit :collect collect))
+ (defmethod process-output-translations ((form cons) &key inherit collect)
+ (dolist (directive (cdr (validate-output-translations-form form)))
+ (process-output-translations-directive directive :inherit inherit :collect collect)))
- (defmethod component-depends-on ((o monolithic-binary-op) (c system))
- `((,(find-operation o 'monolithic-fasl-op) ,c)
- (,(find-operation o 'monolithic-lib-op) ,c)))
+ (defun compute-output-translations (&optional parameter)
+ "read the configuration, return it"
+ (remove-duplicates
+ (while-collecting (c)
+ (inherit-output-translations
+ `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
+ :test 'equal :from-end t))
- (defmethod component-depends-on ((o lib-op) (c system))
- (declare (ignorable o))
- `((compile-op ,@(required-components c :other-systems nil :component-type '(not system)
- :goal-operation 'load-op
- :keep-operation 'compile-op))))
+ (defvar *output-translations-parameter* nil)
- (defmethod component-depends-on ((o fasl-op) (c system))
- (declare (ignorable o))
- #+ecl `((lib-op ,c))
- #-ecl
- (component-depends-on (find-operation o 'lib-op) c))
+ (defun initialize-output-translations (&optional (parameter *output-translations-parameter*))
+ "read the configuration, initialize the internal configuration variable,
+return the configuration"
+ (setf *output-translations-parameter* parameter
+ (output-translations) (compute-output-translations parameter)))
- (defmethod component-depends-on ((o dll-op) c)
- (component-depends-on (find-operation o 'lib-op) c))
+ (defun disable-output-translations ()
+ "Initialize output translations in a way that maps every file to itself,
+effectively disabling the output translation facility."
+ (initialize-output-translations
+ '(:output-translations :disable-cache :ignore-inherited-configuration)))
- (defmethod component-depends-on ((o bundle-op) c)
- (declare (ignorable o c))
- nil)
+ ;; 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-output-translations ()
+ (if (output-translations-initialized-p)
+ (output-translations)
+ (initialize-output-translations)))
- (defmethod component-depends-on :around ((o bundle-op) (c component))
- (declare (ignorable o c))
- (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c)))
- `((,op ,c))
- (call-next-method)))
+ (defun* (apply-output-translations) (path)
+ (etypecase path
+ (logical-pathname
+ path)
+ ((or pathname string)
+ (ensure-output-translations)
+ (loop* :with p = (resolve-symlinks* path)
+ :for (source destination) :in (car *output-translations*)
+ :for root = (when (or (eq source t)
+ (and (pathnamep source)
+ (not (absolute-pathname-p source))))
+ (pathname-root p))
+ :for absolute-source = (cond
+ ((eq source t) (wilden root))
+ (root (merge-pathnames* source root))
+ (t source))
+ :when (or (eq source t) (pathname-match-p p absolute-source))
+ :return (translate-pathname* p absolute-source destination root source)
+ :finally (return p)))))
- (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys)
- (while-collecting (collect)
- (map-direct-dependencies
- o c #'(lambda (sub-o sub-c)
- (loop :for f :in (funcall key sub-o sub-c)
- :when (funcall test f) :do (collect f))))))
+ ;; Hook into asdf/driver's output-translation mechanism
+ #-cormanlisp
+ (setf *output-translation-function* 'apply-output-translations)
- (defmethod input-files ((o bundle-op) (c system))
- (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))
+ #+abcl
+ (defun translate-jar-pathname (source wildcard)
+ (declare (ignore wildcard))
+ (flet ((normalize-device (pathname)
+ (if (find :windows *features*)
+ pathname
+ (make-pathname :defaults pathname :device :unspecific))))
+ (let* ((jar
+ (pathname (first (pathname-device source))))
+ (target-root-directory-namestring
+ (format nil "/___jar___file___root___/~@[~A/~]"
+ (and (find :windows *features*)
+ (pathname-device jar))))
+ (relative-source
+ (relativize-pathname-directory source))
+ (relative-jar
+ (relativize-pathname-directory (ensure-directory-pathname jar)))
+ (target-root-directory
+ (normalize-device
+ (pathname-directory-pathname
+ (parse-namestring target-root-directory-namestring))))
+ (target-root
+ (merge-pathnames* relative-jar target-root-directory))
+ (target
+ (merge-pathnames* relative-source target-root)))
+ (normalize-device (apply-output-translations target))))))
- (defun select-bundle-operation (type &optional monolithic)
- (ecase type
- ((:binary)
- (if monolithic 'monolithic-binary-op 'binary-op))
- ((:dll :shared-library)
- (if monolithic 'monolithic-dll-op 'dll-op))
- ((:lib :static-library)
- (if monolithic 'monolithic-lib-op 'lib-op))
- ((:fasl)
- (if monolithic 'monolithic-fasl-op 'fasl-op))
- ((:program)
- 'program-op)))
+;;;; -------------------------------------------------------------------------
+;;; Backward-compatible interfaces
- (defun make-build (system &rest args &key (monolithic nil) (type :fasl)
- (move-here nil move-here-p)
- &allow-other-keys)
- (let* ((operation-name (select-bundle-operation type monolithic))
- (move-here-path (if (and move-here
- (typep move-here '(or pathname string)))
- (pathname move-here)
- (system-relative-pathname system "asdf-output/")))
- (operation (apply #'operate operation-name
- system
- (remove-plist-keys '(:monolithic :type :move-here) args)))
- (system (find-system system))
- (files (and system (output-files operation system))))
- (if (or move-here (and (null move-here-p)
- (member operation-name '(:program :binary))))
- (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path))
- :for f :in files
- :for new-f = (make-pathname :name (pathname-name f)
- :type (pathname-type f)
- :defaults dest-path)
- :do (rename-file-overwriting-target f new-f)
- :collect new-f)
- files))))
+(asdf/package:define-package :asdf/backward-interface
+ (:recycle :asdf/backward-interface :asdf)
+ (:use :uiop/common-lisp :uiop :asdf/upgrade
+ :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
+ :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
+ (:export
+ #:*asdf-verbose*
+ #:operation-error #:compile-error #:compile-failed #:compile-warned
+ #:error-component #:error-operation #:traverse
+ #:component-load-dependencies
+ #:enable-asdf-binary-locations-compatibility
+ #:operation-forced
+ #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings
+ #:component-property
+ #:run-shell-command
+ #:system-definition-pathname))
+(in-package :asdf/backward-interface)
-;;;
-;;; LOAD-FASL-OP
-;;;
-;;; This is like ASDF's LOAD-OP, but using monolithic fasl files.
-;;;
(with-upgradability ()
- (defmethod component-depends-on ((o load-fasl-op) (c system))
- (declare (ignorable o))
- `((,o ,@(loop :for dep :in (component-sibling-dependencies c)
- :collect (resolve-dependency-spec c dep)))
- (,(if (user-system-p c) 'fasl-op 'load-op) ,c)
- ,@(call-next-method)))
+ (define-condition operation-error (error) ;; Bad, backward-compatible name
+ ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
+ ((component :reader error-component :initarg :component)
+ (operation :reader error-operation :initarg :operation))
+ (:report (lambda (c s)
+ (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
+ (type-of c) (error-operation c) (error-component c)))))
+ (define-condition compile-error (operation-error) ())
+ (define-condition compile-failed (compile-error) ())
+ (define-condition compile-warned (compile-error) ())
- (defmethod input-files ((o load-fasl-op) (c system))
- (when (user-system-p c)
- (output-files (find-operation o 'fasl-op) c)))
+ (defun component-load-dependencies (component)
+ ;; Old deprecated name for the same thing. Please update your software.
+ (component-sideway-dependencies component))
- (defmethod perform ((o load-fasl-op) c)
- (declare (ignorable o c))
- nil)
+ (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
+ (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
- (defmethod perform ((o load-fasl-op) (c system))
- (perform-lisp-load-fasl o c))
+ (defgeneric operation-on-warnings (operation))
+ (defgeneric operation-on-failure (operation))
+ #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
+ #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
+ (defmethod operation-on-warnings ((o operation))
+ (declare (ignorable o)) *compile-file-warnings-behaviour*)
+ (defmethod operation-on-failure ((o operation))
+ (declare (ignorable o)) *compile-file-failure-behaviour*)
+ (defmethod (setf operation-on-warnings) (x (o operation))
+ (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
+ (defmethod (setf operation-on-failure) (x (o operation))
+ (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
- (defmethod mark-operation-done :after ((o load-fasl-op) (c system))
- (mark-operation-done (find-operation o 'load-op) c)))
+ (defun system-definition-pathname (x)
+ ;; As of 2.014.8, we mean to make this function obsolete,
+ ;; but that won't happen until all clients have been updated.
+ ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
+ "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
+It used to expose ASDF internals with subtle differences with respect to
+user expectations, that have been refactored away since.
+We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
+for a mostly compatible replacement that we're supporting,
+or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
+if that's whay you mean." ;;)
+ (system-source-file x))
-;;;
-;;; PRECOMPILED FILES
-;;;
-;;; This component can be used to distribute ASDF systems in precompiled form.
-;;; Only useful when the dependencies have also been precompiled.
-;;;
-(with-upgradability ()
- (defmethod trivial-system-p ((s system))
- (every #'(lambda (c) (typep c 'compiled-file)) (component-children s)))
+ (defgeneric* (traverse) (operation component &key &allow-other-keys)
+ (:documentation
+ "Generate and return a plan for performing OPERATION on COMPONENT.
- (defmethod output-files (o (c compiled-file))
- (declare (ignorable o c))
- nil)
- (defmethod input-files (o (c compiled-file))
- (declare (ignorable o))
- (component-pathname c))
- (defmethod perform ((o load-op) (c compiled-file))
- (perform-lisp-load-fasl o c))
- (defmethod perform ((o load-source-op) (c compiled-file))
- (perform (find-operation o 'load-op) c))
- (defmethod perform ((o load-fasl-op) (c compiled-file))
- (perform (find-operation o 'load-op) c))
- (defmethod perform (o (c compiled-file))
- (declare (ignorable o c))
- nil))
+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
+processed in order by OPERATE."))
+ (define-convenience-action-methods traverse (operation component &key))
-;;;
-;;; Pre-built systems
-;;;
-(with-upgradability ()
- (defmethod trivial-system-p ((s prebuilt-system))
- (declare (ignorable s))
- t)
+ (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
+ (plan-actions (apply 'make-plan plan-class o c keys))))
- (defmethod perform ((o lib-op) (c prebuilt-system))
- (declare (ignorable o c))
- nil)
- (defmethod component-depends-on ((o lib-op) (c prebuilt-system))
- (declare (ignorable o c))
- nil)
+;;;; ASDF-Binary-Locations compatibility
+;; This remains supported for legacy user, but not recommended for new users.
+(with-upgradability ()
+ (defun enable-asdf-binary-locations-compatibility
+ (&key
+ (centralize-lisp-binaries nil)
+ (default-toplevel-directory
+ (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
+ (include-per-user-information nil)
+ (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
+ (source-to-target-mappings nil)
+ (file-types `(,(compile-file-type)
+ "build-report"
+ #+ecl (compile-file-type :type :object)
+ #+mkcl (compile-file-type :fasl-p nil)
+ #+clisp "lib" #+sbcl "cfasl"
+ #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
+ #+(or clisp ecl mkcl)
+ (when (null map-all-source-files)
+ (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
+ (let* ((patterns (if map-all-source-files (list *wild-file*)
+ (loop :for type :in file-types
+ :collect (make-pathname :type type :defaults *wild-file*))))
+ (destination-directory
+ (if centralize-lisp-binaries
+ `(,default-toplevel-directory
+ ,@(when include-per-user-information
+ (cdr (pathname-directory (user-homedir-pathname))))
+ :implementation ,*wild-inferiors*)
+ `(:root ,*wild-inferiors* :implementation))))
+ (initialize-output-translations
+ `(:output-translations
+ ,@source-to-target-mappings
+ #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
+ #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
+ ,@(loop :for pattern :in patterns
+ :collect `((:root ,*wild-inferiors* ,pattern)
+ (,@destination-directory ,pattern)))
+ (t t)
+ :ignore-inherited-configuration))))
- (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
- (declare (ignorable o))
- nil))
+ (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
+ (declare (ignorable operation-class system args))
+ (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
+ (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
+ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
+which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
+and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
+In case you insist on preserving your previous A-B-L configuration, but
+do not know how to achieve the same effect with A-O-T, you may use function
+ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
+call that function where you would otherwise have loaded and configured A-B-L."))))
-;;;
-;;; PREBUILT SYSTEM CREATOR
-;;;
+;;; run-shell-command
+;; WARNING! The function below is not just deprecated but also dysfunctional.
+;; Please use asdf/run-program:run-program instead.
(with-upgradability ()
- (defmethod output-files ((o binary-op) (s system))
- (list (make-pathname :name (component-name s) :type "asd"
- :defaults (component-pathname s))))
+ (defun run-shell-command (control-string &rest args)
+ "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *VERBOSE-OUT*. Returns the shell's exit code.
- (defmethod perform ((o binary-op) (s system))
- (let* ((dependencies (component-depends-on o s))
- (fasl (first (apply #'output-files (first dependencies))))
- (library (first (apply #'output-files (second dependencies))))
- (asd (first (output-files o s)))
- (name (pathname-name asd))
- (name-keyword (intern (string name) (find-package :keyword))))
- (with-open-file (s asd :direction :output :if-exists :supersede
- :if-does-not-exist :create)
- (format s ";;; Prebuilt ASDF definition for system ~A" name)
- (format s ";;; Built for ~A ~A on a ~A/~A ~A"
- (lisp-implementation-type)
- (lisp-implementation-version)
- (software-type)
- (machine-type)
- (software-version))
- (let ((*package* (find-package :keyword)))
- (pprint `(defsystem ,name-keyword
- :class prebuilt-system
- :components ((:compiled-file ,(pathname-name fasl)))
- :lib ,(and library (file-namestring library)))
- s)))))
+PLEASE DO NOT USE.
+Deprecated function, for backward-compatibility only.
+Please use UIOP:RUN-PROGRAM instead."
+ (let ((command (apply 'format nil control-string args)))
+ (asdf-message "; $ ~A~%" command)
+ (handler-case
+ (progn
+ (run-program command :force-shell t :ignore-error-status nil :output *verbose-out*)
+ 0)
+ (subprocess-error (c)
+ (let ((code (subprocess-error-code c)))
+ (typecase code
+ (integer code)
+ (t 255))))))))
- #-(or ecl mkcl)
- (defmethod perform ((o fasl-op) (c system))
- (let* ((input-files (input-files o c))
- (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'string=))
- (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=))
- (output-files (output-files o c))
- (output-file (first output-files)))
- (unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
- (when input-files
- (assert output-files)
- (when non-fasl-files
- (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S"
- (implementation-type) non-fasl-files))
- (when (and (typep o 'monolithic-bundle-op)
- (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o)))
- (error "prologue-code and epilogue-code are not supported on ~A"
- (implementation-type)))
- (with-staging-pathname (output-file)
- (combine-fasls fasl-files output-file)))))
+(with-upgradability ()
+ (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
+
+;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
+(with-upgradability ()
+ (defgeneric component-property (component property))
+ (defgeneric (setf component-property) (new-value component property))
- (defmethod input-files ((o load-op) (s precompiled-system))
- (declare (ignorable o))
- (bundle-output-files (find-operation o 'fasl-op) s))
+ (defmethod component-property ((c component) property)
+ (cdr (assoc property (slot-value c 'properties) :test #'equal)))
- (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
- (declare (ignorable o))
- `((load-op ,s) ,@(call-next-method))))
+ (defmethod (setf component-property) (new-value (c component) property)
+ (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
+ (if a
+ (setf (cdr a) new-value)
+ (setf (slot-value c 'properties)
+ (acons property new-value (slot-value c 'properties)))))
+ new-value))
+;;;; -----------------------------------------------------------------
+;;;; Source Registry Configuration, by Francois-Rene Rideau
+;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918
- #| ;; Example use:
-(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl")))
-(asdf:load-system :precompiled-asdf-utils)
-|#
+(asdf/package:define-package :asdf/source-registry
+ (:recycle :asdf/source-registry :asdf)
+ (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system)
+ (:export
+ #:*source-registry-parameter* #:*default-source-registries*
+ #:invalid-source-registry
+ #:source-registry-initialized-p
+ #:initialize-source-registry #:clear-source-registry #:*source-registry*
+ #:ensure-source-registry #:*source-registry-parameter*
+ #:*default-source-registry-exclusions* #:*source-registry-exclusions*
+ #:*wild-asd* #:directory-asd-files #:register-asd-directory
+ #:collect-asds-in-directory #:collect-sub*directories-asd-files
+ #:validate-source-registry-directive #:validate-source-registry-form
+ #:validate-source-registry-file #:validate-source-registry-directory
+ #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry
+ #:user-source-registry #:system-source-registry
+ #:user-source-registry-directory #:system-source-registry-directory
+ #:environment-source-registry #:process-source-registry
+ #:compute-source-registry #:flatten-source-registry
+ #:sysdef-source-registry-search))
+(in-package :asdf/source-registry)
-#+ecl
(with-upgradability ()
- (defmethod perform ((o bundle-op) (c system))
- (let* ((object-files (input-files o c))
- (output (output-files o c))
- (bundle (first output))
- (kind (bundle-type o)))
- (create-image
- bundle (append object-files (bundle-op-lisp-files o))
- :kind kind
- :entry-point (component-entry-point c)
- :prologue-code
- (when (typep o 'monolithic-bundle-op)
- (monolithic-op-prologue-code o))
- :epilogue-code
- (when (typep o 'monolithic-bundle-op)
- (monolithic-op-epilogue-code o))
- :build-args (bundle-op-build-args o)))))
+ (define-condition invalid-source-registry (invalid-configuration warning)
+ ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>"))))
-#+mkcl
-(with-upgradability ()
- (defmethod perform ((o lib-op) (s system))
- (apply #'compiler::build-static-library (first output)
- :lisp-object-files (input-files o s) (bundle-op-build-args o)))
+ ;; Using ack 1.2 exclusions
+ (defvar *default-source-registry-exclusions*
+ '(".bzr" ".cdv"
+ ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards
+ ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs"
+ "_sgbak" "autom4te.cache" "cover_db" "_build"
+ "debian")) ;; debian often builds stuff under the debian directory... BAD.
- (defmethod perform ((o fasl-op) (s system))
- (apply #'compiler::build-bundle (second output)
- :lisp-object-files (input-files o s) (bundle-op-build-args o)))
+ (defvar *source-registry-exclusions* *default-source-registry-exclusions*)
- (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
- (declare (ignore force verbose version))
- (apply #'operate 'binary-op system args)))
+ (defvar *source-registry* nil
+ "Either NIL (for uninitialized), or an equal hash-table, mapping
+system names to pathnames of .asd files")
-#+(or ecl mkcl)
-(with-upgradability ()
- (defun register-pre-built-system (name)
- (register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
+ (defun source-registry-initialized-p ()
+ (typep *source-registry* 'hash-table))
-;;;; -------------------------------------------------------------------------
-;;;; Concatenate-source
+ (defun clear-source-registry ()
+ "Undoes any initialization of the source registry."
+ (setf *source-registry* nil)
+ (values))
+ (register-clear-configuration-hook 'clear-source-registry)
-(asdf/package:define-package :asdf/concatenate-source
- (:recycle :asdf/concatenate-source :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/operation
- :asdf/system :asdf/find-system :asdf/defsystem
- :asdf/action :asdf/lisp-action :asdf/bundle)
- (:export
- #:concatenate-source-op
- #:load-concatenated-source-op
- #:compile-concatenated-source-op
- #:load-compiled-concatenated-source-op
- #:monolithic-concatenate-source-op
- #:monolithic-load-concatenated-source-op
- #:monolithic-compile-concatenated-source-op
- #:monolithic-load-compiled-concatenated-source-op
- #:component-concatenated-source-file
- #:concatenated-source-file))
-(in-package :asdf/concatenate-source)
+ (defparameter *wild-asd*
+ (make-pathname* :directory nil :name *wild* :type "asd" :version :newest))
-;;;
-;;; Concatenate sources
-;;;
-(with-upgradability ()
- (defclass concatenate-source-op (bundle-op)
- ((bundle-type :initform "lisp")))
- (defclass load-concatenated-source-op (basic-load-op operation)
- ((bundle-type :initform :no-output-file)))
- (defclass compile-concatenated-source-op (basic-compile-op bundle-op)
- ((bundle-type :initform :fasl)))
- (defclass load-compiled-concatenated-source-op (basic-load-op operation)
- ((bundle-type :initform :no-output-file)))
+ (defun directory-asd-files (directory)
+ (directory-files directory *wild-asd*))
- (defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ())
- (defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ())
- (defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ())
- (defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ())
+ (defun collect-asds-in-directory (directory collect)
+ (map () collect (directory-asd-files directory)))
- (defmethod input-files ((operation concatenate-source-op) (s system))
- (loop :with encoding = (or (component-encoding s) *default-encoding*)
- :with other-encodings = '()
- :with around-compile = (around-compile-hook s)
- :with other-around-compile = '()
- :for c :in (required-components
- s :goal-operation 'compile-op
- :keep-operation 'compile-op
- :other-systems (operation-monolithic-p operation))
- :append
- (when (typep c 'cl-source-file)
- (let ((e (component-encoding c)))
- (unless (equal e encoding)
- (pushnew e other-encodings :test 'equal)))
- (let ((a (around-compile-hook c)))
- (unless (equal a around-compile)
- (pushnew a other-around-compile :test 'equal)))
- (input-files (make-operation 'compile-op) c)) :into inputs
- :finally
- (when other-encodings
- (warn "~S uses encoding ~A but has sources that use these encodings: ~A"
- operation encoding other-encodings))
- (when other-around-compile
- (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A"
- operation around-compile other-around-compile))
- (return inputs)))
+ (defun collect-sub*directories-asd-files
+ (directory &key (exclude *default-source-registry-exclusions*) collect)
+ (collect-sub*directories
+ directory
+ (constantly t)
+ #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal)))
+ #'(lambda (dir) (collect-asds-in-directory dir collect))))
- (defmethod input-files ((o load-concatenated-source-op) (s system))
- (direct-dependency-files o s))
- (defmethod input-files ((o compile-concatenated-source-op) (s system))
- (direct-dependency-files o s))
- (defmethod output-files ((o compile-concatenated-source-op) (s system))
- (let ((input (first (input-files o s))))
- (list (compile-file-pathname input))))
- (defmethod input-files ((o load-compiled-concatenated-source-op) (s system))
- (direct-dependency-files o s))
-
- (defmethod perform ((o concatenate-source-op) (s system))
- (let ((inputs (input-files o s))
- (output (output-file o s)))
- (concatenate-files inputs output)))
- (defmethod perform ((o load-concatenated-source-op) (s system))
- (perform-lisp-load-source o s))
- (defmethod perform ((o compile-concatenated-source-op) (s system))
- (perform-lisp-compilation o s))
- (defmethod perform ((o load-compiled-concatenated-source-op) (s system))
- (perform-lisp-load-fasl o s))
+ (defun validate-source-registry-directive (directive)
+ (or (member directive '(:default-registry))
+ (and (consp directive)
+ (let ((rest (rest directive)))
+ (case (first directive)
+ ((:include :directory :tree)
+ (and (length=n-p rest 1)
+ (location-designator-p (first rest))))
+ ((:exclude :also-exclude)
+ (every #'stringp rest))
+ ((:default-registry)
+ (null rest)))))))
- (defmethod component-depends-on ((o concatenate-source-op) (s system))
- (declare (ignorable o s)) nil)
- (defmethod component-depends-on ((o load-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s)))
- (defmethod component-depends-on ((o compile-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((concatenate-source-op ,s)))
- (defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((compile-concatenated-source-op ,s)))
-
- (defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system))
- (declare (ignorable o s)) nil)
- (defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
- (defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s)))
- (defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system))
- (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s))))
+ (defun validate-source-registry-form (form &key location)
+ (validate-configuration-form
+ form :source-registry 'validate-source-registry-directive
+ :location location :invalid-form-reporter 'invalid-source-registry))
-;;;; -------------------------------------------------------------------------
-;;; Backward-compatible interfaces
+ (defun validate-source-registry-file (file)
+ (validate-configuration-file
+ file 'validate-source-registry-form :description "a source registry"))
-(asdf/package:define-package :asdf/backward-interface
- (:recycle :asdf/backward-interface :asdf)
- (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
- :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
- :asdf/lisp-build :asdf/operate :asdf/output-translations)
- (:export
- #:*asdf-verbose*
- #:operation-error #:compile-error #:compile-failed #:compile-warned
- #:error-component #:error-operation
- #:component-load-dependencies
- #:enable-asdf-binary-locations-compatibility
- #:operation-forced
- #:operation-on-failure
- #:operation-on-warnings
- #:component-property
- #:run-shell-command
- #:system-definition-pathname))
-(in-package :asdf/backward-interface)
+ (defun validate-source-registry-directory (directory)
+ (validate-configuration-directory
+ directory :source-registry 'validate-source-registry-directive
+ :invalid-form-reporter 'invalid-source-registry))
-(with-upgradability ()
- (define-condition operation-error (error) ;; Bad, backward-compatible name
- ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
- ((component :reader error-component :initarg :component)
- (operation :reader error-operation :initarg :operation))
- (:report (lambda (c s)
- (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
- (type-of c) (error-operation c) (error-component c)))))
- (define-condition compile-error (operation-error) ())
- (define-condition compile-failed (compile-error) ())
- (define-condition compile-warned (compile-error) ())
+ (defun parse-source-registry-string (string &key location)
+ (cond
+ ((or (null string) (equal string ""))
+ '(:source-registry :inherit-configuration))
+ ((not (stringp string))
+ (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string))
+ ((find (char string 0) "\"(")
+ (validate-source-registry-form (read-from-string string) :location location))
+ (t
+ (loop
+ :with inherit = nil
+ :with directives = ()
+ :with start = 0
+ :with end = (length string)
+ :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)
+ (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string))
+ dir))
+ (cond
+ ((equal "" s) ; empty element: inherit
+ (when inherit
+ (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>")
+ string))
+ (setf inherit t)
+ (push ':inherit-configuration directives))
+ ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
+ (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
+ (t
+ (push `(:directory ,(check s)) directives))))
+ (cond
+ (pos
+ (setf start (1+ pos)))
+ (t
+ (unless inherit
+ (push '(:ignore-inherited-configuration) directives))
+ (return `(:source-registry ,@(nreverse directives))))))))))
- (defun component-load-dependencies (component)
- ;; Old deprecated name for the same thing. Please update your software.
- (component-sibling-dependencies component))
+ (defun register-asd-directory (directory &key recurse exclude collect)
+ (if (not recurse)
+ (collect-asds-in-directory directory collect)
+ (collect-sub*directories-asd-files
+ directory :exclude exclude :collect collect)))
+
+ (defparameter *default-source-registries*
+ '(environment-source-registry
+ user-source-registry
+ user-source-registry-directory
+ system-source-registry
+ system-source-registry-directory
+ default-source-registry))
+
+ (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf"))
+ (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/"))
- (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader.
- (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))
+ (defun wrapping-source-registry ()
+ `(:source-registry
+ #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
+ #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
+ :inherit-configuration
+ #+cmu (:tree #p"modules:")
+ #+scl (:tree #p"file://modules/")))
+ (defun default-source-registry ()
+ `(:source-registry
+ #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/"))
+ ,@(loop :for dir :in
+ `(,@(when (os-unix-p)
+ `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
+ (subpathname (user-homedir-pathname) ".local/share/"))
+ ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
+ '("/usr/local/share" "/usr/share"))))
+ ,@(when (os-windows-p)
+ (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
+ :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+ :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+ :inherit-configuration))
+ (defun user-source-registry (&key (direction :input))
+ (in-user-configuration-directory *source-registry-file* :direction direction))
+ (defun system-source-registry (&key (direction :input))
+ (in-system-configuration-directory *source-registry-file* :direction direction))
+ (defun user-source-registry-directory (&key (direction :input))
+ (in-user-configuration-directory *source-registry-directory* :direction direction))
+ (defun system-source-registry-directory (&key (direction :input))
+ (in-system-configuration-directory *source-registry-directory* :direction direction))
+ (defun environment-source-registry ()
+ (getenv "CL_SOURCE_REGISTRY"))
- (defgeneric operation-on-warnings (operation))
- (defgeneric operation-on-failure (operation))
- #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation))
- #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation))
- (defmethod operation-on-warnings ((o operation))
- (declare (ignorable o)) *compile-file-warnings-behaviour*)
- (defmethod operation-on-failure ((o operation))
- (declare (ignorable o)) *compile-file-failure-behaviour*)
- (defmethod (setf operation-on-warnings) (x (o operation))
- (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
- (defmethod (setf operation-on-failure) (x (o operation))
- (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))
+ (defgeneric* (process-source-registry) (spec &key inherit register))
- (defun system-definition-pathname (x)
- ;; As of 2.014.8, we mean to make this function obsolete,
- ;; but that won't happen until all clients have been updated.
- ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
- "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
-It used to expose ASDF internals with subtle differences with respect to
-user expectations, that have been refactored away since.
-We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
-for a mostly compatible replacement that we're supporting,
-or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
-if that's whay you mean." ;;)
- (system-source-file x)))
+ (defun* (inherit-source-registry) (inherit &key register)
+ (when inherit
+ (process-source-registry (first inherit) :register register :inherit (rest inherit))))
+ (defun* (process-source-registry-directive) (directive &key inherit register)
+ (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive))
+ (ecase kw
+ ((:include)
+ (destructuring-bind (pathname) rest
+ (process-source-registry (resolve-location pathname) :inherit nil :register register)))
+ ((:directory)
+ (destructuring-bind (pathname) rest
+ (when pathname
+ (funcall register (resolve-location pathname :ensure-directory t)))))
+ ((:tree)
+ (destructuring-bind (pathname) rest
+ (when pathname
+ (funcall register (resolve-location pathname :ensure-directory t)
+ :recurse t :exclude *source-registry-exclusions*))))
+ ((:exclude)
+ (setf *source-registry-exclusions* rest))
+ ((:also-exclude)
+ (appendf *source-registry-exclusions* rest))
+ ((:default-registry)
+ (inherit-source-registry '(default-source-registry) :register register))
+ ((:inherit-configuration)
+ (inherit-source-registry inherit :register register))
+ ((:ignore-inherited-configuration)
+ nil)))
+ nil)
-;;;; ASDF-Binary-Locations compatibility
-;; This remains supported for legacy user, but not recommended for new users.
-(with-upgradability ()
- (defun enable-asdf-binary-locations-compatibility
- (&key
- (centralize-lisp-binaries nil)
- (default-toplevel-directory
- (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
- (include-per-user-information nil)
- (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
- (source-to-target-mappings nil)
- (file-types `(,(compile-file-type)
- "build-report"
- #+ecl (compile-file-type :type :object)
- #+mkcl (compile-file-type :fasl-p nil)
- #+clisp "lib" #+sbcl "cfasl"
- #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
- #+(or clisp ecl mkcl)
- (when (null map-all-source-files)
- (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
- (let* ((patterns (if map-all-source-files (list *wild-file*)
- (loop :for type :in file-types
- :collect (make-pathname :type type :defaults *wild-file*))))
- (destination-directory
- (if centralize-lisp-binaries
- `(,default-toplevel-directory
- ,@(when include-per-user-information
- (cdr (pathname-directory (user-homedir-pathname))))
- :implementation ,*wild-inferiors*)
- `(:root ,*wild-inferiors* :implementation))))
- (initialize-output-translations
- `(:output-translations
- ,@source-to-target-mappings
- #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
- #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
- ,@(loop :for pattern :in patterns
- :collect `((:root ,*wild-inferiors* ,pattern)
- (,@destination-directory ,pattern)))
- (t t)
- :ignore-inherited-configuration))))
+ (defmethod process-source-registry ((x symbol) &key inherit register)
+ (process-source-registry (funcall x) :inherit inherit :register register))
+ (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register)
+ (cond
+ ((directory-pathname-p pathname)
+ (let ((*here-directory* (resolve-symlinks* pathname)))
+ (process-source-registry (validate-source-registry-directory pathname)
+ :inherit inherit :register register)))
+ ((probe-file* pathname :truename *resolve-symlinks*)
+ (let ((*here-directory* (pathname-directory-pathname pathname)))
+ (process-source-registry (validate-source-registry-file pathname)
+ :inherit inherit :register register)))
+ (t
+ (inherit-source-registry inherit :register register))))
+ (defmethod process-source-registry ((string string) &key inherit register)
+ (process-source-registry (parse-source-registry-string string)
+ :inherit inherit :register register))
+ (defmethod process-source-registry ((x null) &key inherit register)
+ (declare (ignorable x))
+ (inherit-source-registry inherit :register register))
+ (defmethod process-source-registry ((form cons) &key inherit register)
+ (let ((*source-registry-exclusions* *default-source-registry-exclusions*))
+ (dolist (directive (cdr (validate-source-registry-form form)))
+ (process-source-registry-directive directive :inherit inherit :register register))))
- (defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
- (declare (ignorable operation-class system args))
- (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
- (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
-ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
-which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
-and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
-In case you insist on preserving your previous A-B-L configuration, but
-do not know how to achieve the same effect with A-O-T, you may use function
-ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
-call that function where you would otherwise have loaded and configured A-B-L."))))
+ (defun flatten-source-registry (&optional parameter)
+ (remove-duplicates
+ (while-collecting (collect)
+ (with-pathname-defaults () ;; be location-independent
+ (inherit-source-registry
+ `(wrapping-source-registry
+ ,parameter
+ ,@*default-source-registries*)
+ :register #'(lambda (directory &key recurse exclude)
+ (collect (list directory :recurse recurse :exclude exclude))))))
+ :test 'equal :from-end t))
+ ;; Will read the configuration and initialize all internal variables.
+ (defun compute-source-registry (&optional parameter (registry *source-registry*))
+ (dolist (entry (flatten-source-registry parameter))
+ (destructuring-bind (directory &key recurse exclude) entry
+ (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates
+ (register-asd-directory
+ directory :recurse recurse :exclude exclude :collect
+ #'(lambda (asd)
+ (let* ((name (pathname-name asd))
+ (name (if (typep asd 'logical-pathname)
+ ;; logical pathnames are upper-case,
+ ;; at least in the CLHS and on SBCL,
+ ;; yet (coerce-name :foo) is lower-case.
+ ;; won't work well with (load-system "Foo")
+ ;; instead of (load-system 'foo)
+ (string-downcase name)
+ name)))
+ (cond
+ ((gethash name registry) ; already shadowed by something else
+ nil)
+ ((gethash name h) ; conflict at current level
+ (when *verbose-out*
+ (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~
+ found several entries for ~A - picking ~S over ~S~:>")
+ directory recurse name (gethash name h) asd)))
+ (t
+ (setf (gethash name registry) asd)
+ (setf (gethash name h) asd))))))
+ h)))
+ (values))
-;;; run-shell-command
-;; WARNING! The function below is not just deprecated but also dysfunctional.
-;; Please use asdf/run-program:run-program instead.
-(with-upgradability ()
- (defun run-shell-command (control-string &rest args)
- "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
-synchronously execute the result using a Bourne-compatible shell, with
-output to *VERBOSE-OUT*. Returns the shell's exit code.
+ (defvar *source-registry-parameter* nil)
-PLEASE DO NOT USE.
-Deprecated function, for backward-compatibility only.
-Please use ASDF-DRIVER:RUN-PROGRAM instead."
- (let ((command (apply 'format nil control-string args)))
- (asdf-message "; $ ~A~%" command)
- (run-program command :force-shell t :ignore-error-status t :output *verbose-out*))))
+ (defun initialize-source-registry (&optional (parameter *source-registry-parameter*))
+ ;; Record the parameter used to configure the registry
+ (setf *source-registry-parameter* parameter)
+ ;; Clear the previous registry database:
+ (setf *source-registry* (make-hash-table :test 'equal))
+ ;; Do it!
+ (compute-source-registry parameter))
-(with-upgradability ()
- (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused.
+ ;; 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) to make sure the source registry is initialized.
+ ;; However, it will do so *without* a parameter, at which point it
+ ;; will be too late to provide a parameter to this function, though
+ ;; you may override the configuration explicitly by calling
+ ;; initialize-source-registry directly with your parameter.
+ (defun ensure-source-registry (&optional parameter)
+ (unless (source-registry-initialized-p)
+ (initialize-source-registry parameter))
+ (values))
-;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
-(with-upgradability ()
- (defgeneric component-property (component property))
- (defgeneric (setf component-property) (new-value component property))
+ (defun sysdef-source-registry-search (system)
+ (ensure-source-registry)
+ (values (gethash (primary-system-name system) *source-registry*))))
- (defmethod component-property ((c component) property)
- (cdr (assoc property (slot-value c 'properties) :test #'equal)))
- (defmethod (setf component-property) (new-value (c component) property)
- (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
- (if a
- (setf (cdr a) new-value)
- (setf (slot-value c 'properties)
- (acons property new-value (slot-value c 'properties)))))
- new-value))
;;;; ---------------------------------------------------------------------------
;;;; Handle ASDF package upgrade, including implementation-dependent magic.
;; TODO: automatically generate interface with reexport?
(:export
#:defsystem #:find-system #:locate-system #:coerce-name
- #:oos #:operate #:traverse #:perform-plan
+ #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
#:system-definition-pathname #:with-system-definitions
#:search-for-system-definition #:find-component #:component-find-path
#:compile-system #:load-system #:load-systems
#:require-system #:test-system #:clear-system
- #:operation #:upward-operation #:downward-operation #:make-operation
+ #:operation #:make-operation #:find-operation
+ #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation
#:build-system #:build-op
#:load-op #:prepare-op #:compile-op
#:prepare-source-op #:load-source-op #:test-op
#:feature #:version #:version-satisfies #:upgrade-asdf
#:implementation-identifier #:implementation-type #:hostname
#:input-files #:output-files #:output-file #:perform
- #:operation-done-p #:explain #:action-description #:component-sibling-dependencies
+ #:operation-done-p #:explain #:action-description #:component-sideway-dependencies
#:needed-in-image-p
;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT.
#:component-load-dependencies #:run-shell-command ; deprecated, do not use
- #:bundle-op #:precompiled-system #:compiled-file #:bundle-system
+ #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system
#+ecl #:make-build
- #:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op
+ #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op
+ #:lib-op #:dll-op #:binary-op #:program-op
+ #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op
#:concatenate-source-op
#:load-concatenated-source-op
#:compile-concatenated-source-op
#:monolithic-load-compiled-concatenated-source-op
#:operation-monolithic-p
#:required-components
+ #:component-loaded-p
#:component #:parent-component #:child-component #:system #:module
#:file-component #:source-file #:c-source-file #:java-source-file
#:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
- #:static-file #:doc-file #:html-file :text-file
+ #:static-file #:doc-file #:html-file
+ #:file-type
#:source-file-type
#:component-children ; component accessors
#:module-components ; backward-compatibility
#:operation-on-warnings #:operation-on-failure ; backward-compatibility
#:component-property ; backward-compatibility
+ #:traverse ; backward-compatibility
#:system-description
#:system-long-description
#:system-source-directory
#:system-relative-pathname
#:system-homepage
+ #:system-mailto
#:system-bug-tracker
- #:system-developers-email
#:system-long-name
#:system-source-control
#:map-systems
#:missing-dependency
#:missing-dependency-of-version
#:circular-dependency ; errors
- #:duplicate-names
+ #:duplicate-names #:non-toplevel-system #:non-system-system
#:try-recompiling
#:retry
#:apply-output-translations
#:compile-file*
#:compile-file-pathname*
- #:*warnings-file-type*
+ #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check
#:enable-asdf-binary-locations-compatibility
#:*default-source-registries*
#:*source-registry-parameter*
#:system-registered-p #:registered-systems #:already-loaded-systems
#:resolve-location
#:asdf-message
+ #:*user-cache*
#:user-output-translations-pathname
#:system-output-translations-pathname
#:user-output-translations-directory-pathname
(setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
(loop :for f :in #+ecl ext:*module-provider-functions*
#+mkcl mk-ext::*module-provider-functions*
- :unless (eq f 'module-provide-asdf)
- :collect #'(lambda (name)
- (let ((l (multiple-value-list (funcall f name))))
- (and (first l) (register-pre-built-system (coerce-name name)))
- (values-list l)))))))
+ :collect
+ (if (eq f 'module-provide-asdf) f
+ #'(lambda (name)
+ (let ((l (multiple-value-list (funcall f name))))
+ (and (first l) (register-pre-built-system (coerce-name name)))
+ (values-list l))))))))
+
+#+cmu
+(with-upgradability ()
+ (defun herald-asdf (stream)
+ (format stream " ASDF ~A" (asdf-version)))
+ (setf (getf ext:*herald-items* :asdf) `(herald-asdf)))
;;;; Done!
(asdf-message ";; ASDF, version ~a~%" (asdf-version)))
-;;; Local Variables:
-;;; mode: lisp
-;;; End:
projects / sbcl.git / blobdiff