diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp index d3c63b25be86782ee791db56cb28fd52a3a41f0e..88949ea67b55181367ca6a8923f6a972984a8b30 100644 --- a/src/contrib/asdf/asdf.lisp +++ b/src/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.32: Another System Definition Facility. +;;; This is ASDF 3.0.1: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. @@ -71,10 +71,10 @@ (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 - (or #+abcl 2.25 #+cmu 2.018 2.27))) + (or #+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. @@ -1014,12 +1014,15 @@ or when loading the package is optional." #+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 @@ -1092,22 +1095,22 @@ or when loading the package is optional." ;;; 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 "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))))))) @@ -1156,7 +1159,11 @@ Returns two values: \(A B C\) and \(1 2 3\)." :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 () @@ -1180,10 +1187,42 @@ Returns two values: \(A B C\) and \(1 2 3\)." (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))) @@ -1204,12 +1243,11 @@ starting the separation from the end, e.g. when called with arguments (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?" @@ -1419,7 +1457,8 @@ a simple vector of length 2, arguments to find-symbol* with result as above, 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 @@ -2427,8 +2466,14 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of 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 @@ -2441,7 +2486,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." ;; 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 @@ -2456,7 +2501,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." ;; Simple filesystem operations #:ensure-all-directories-exist #:rename-file-overwriting-target - #:delete-file-if-exists)) + #: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 @@ -2564,10 +2609,18 @@ or the original (parsed) pathname if it is false (the default)." (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) @@ -2602,7 +2655,11 @@ or the original (parsed) pathname if it is false (the default)." (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) @@ -2649,10 +2706,10 @@ or the original (parsed) pathname if it is false (the default)." :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 @@ -2790,7 +2847,8 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (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) @@ -2850,8 +2908,10 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (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)) @@ -2907,8 +2967,85 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." #+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 @@ -2924,9 +3061,9 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." #:*default-encoding* #:*utf-8-external-format* #: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 #: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 @@ -3098,10 +3235,33 @@ Other keys are accepted but discarded." :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 () @@ -3158,6 +3318,10 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." :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) @@ -3308,7 +3472,7 @@ If a string, repeatedly read and evaluate from it, returning the last values." #+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 @@ -3410,6 +3574,9 @@ For the latter case, we ought pick random suffix and atomically open it." (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.") @@ -3602,10 +3769,17 @@ if we are not called from a directly executable image." ((: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*) @@ -3618,14 +3792,16 @@ if we are not called from a directly executable image." ;;; 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.")) @@ -3644,8 +3820,16 @@ if we are not called from a directly executable image." ;; :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) @@ -3669,33 +3853,36 @@ if we are not called from a directly executable image." :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) + &key kind output-name prologue-code epilogue-code + (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 @@ -3842,7 +4029,7 @@ by /bin/sh in POSIX" ;;;; Slurping a stream, typically the output of another program (with-upgradability () (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys)) - + #-(or gcl2.6 genera) (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys) (funcall function input-stream)) @@ -3881,6 +4068,27 @@ by /bin/sh in POSIX" (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) @@ -3918,16 +4126,24 @@ by /bin/sh in POSIX" &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. + +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, the output will be processed by SLURP-INPUT-STREAM, +using OUTPUT as the first argument, and return whatever it 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: 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") @@ -3969,7 +4185,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process #+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)) + #+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 @@ -3995,9 +4211,9 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process ;; 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*) @@ -4020,7 +4236,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT 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 @@ -4059,7 +4275,9 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process (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 interactive :output interactive :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) @@ -4067,7 +4285,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process #+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 () @@ -4109,13 +4327,15 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process #: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 @@ -4146,15 +4366,16 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (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)))) @@ -4179,7 +4400,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (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.") @@ -4188,38 +4409,42 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when #+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)))) @@ -4322,10 +4547,18 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when name)) (defun reify-function-name (function-name) (let ((name (or (first function-name) ;; defun: extract the name - (first (second function-name))))) ;; defmethod: keep gf name, drop method specializers + (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) 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) @@ -4333,11 +4566,10 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (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 env) args - (declare (ignorable env)) - (list (unsymbolify-function-name fun) - (mapcar (constantly nil) formals) - nil))))) + :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 @@ -4346,8 +4578,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when :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 (symbolify-function-name fun) 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 @@ -4753,11 +4985,12 @@ it will filter them appropriately." ;;; 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 @@ -4766,9 +4999,8 @@ it will filter them appropriately." :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)) @@ -4786,7 +5018,7 @@ it will filter them appropriately." (: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/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) (:export #:get-folder-path #:user-configuration-directories #:system-configuration-directories @@ -4794,7 +5026,7 @@ it will filter them appropriately." #: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)) @@ -5012,7 +5244,8 @@ directive.") (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))) @@ -5188,7 +5421,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ;; "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.32") + (asdf-version "3.0.1") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -5205,7 +5438,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO #: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 + #:component-depends-on #:operation-done-p #:component-depends-on #:traverse ;; plan #:operate ;; operate #:parse-component-form ;; defsystem @@ -5219,15 +5452,17 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO (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 @@ -5289,7 +5524,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO #:static-file #:doc-file #:html-file #:file-type #:source-file-type #:source-file-explicit-type ;; backward-compatibility - #:component-in-order-to #:component-sibling-dependencies + #:component-in-order-to #:component-sideway-dependencies #:component-if-feature #:around-compile-hook #:component-description #:component-long-description #:component-version #:version-satisfies @@ -5308,7 +5543,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO #: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) @@ -5352,7 +5587,7 @@ another pathname in a degenerate way.")) (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. @@ -5547,7 +5782,7 @@ another pathname in a degenerate way.")) (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) @@ -6288,7 +6523,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (: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 #:feature)) (in-package :asdf/operation) @@ -6354,8 +6589,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (: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 @@ -6433,7 +6668,7 @@ You can put together sentences using this phrase.")) ;;;; 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: @@ -6451,19 +6686,15 @@ You can put together sentences using this phrase.")) 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)) (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. @@ -6473,7 +6704,7 @@ You can put together sentences using this phrase.")) (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: @@ -6481,7 +6712,7 @@ You can put together sentences using this phrase.")) ;; 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)) @@ -6490,13 +6721,22 @@ You can put together sentences using this phrase.")) ;; 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)))) @@ -6546,17 +6786,16 @@ You can put together sentences using this phrase.")) (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 @@ -6663,7 +6902,8 @@ in some previous image, or T if it needs to be done.") #: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) @@ -6687,17 +6927,23 @@ in some previous image, or T if it needs to be done.") ;;; 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 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 @@ -6773,8 +7019,7 @@ in some previous image, or T if it needs to be done.") (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))) @@ -6788,9 +7033,8 @@ in some previous image, or T if it needs to be done.") ,(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) @@ -6840,13 +7084,7 @@ in some previous image, or T if it needs to be done.") (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 @@ -6874,9 +7112,6 @@ in some previous image, or T if it needs to be done.") (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 () @@ -6902,11 +7137,7 @@ in some previous image, or T if it needs to be done.") (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 @@ -7151,9 +7382,9 @@ the action of OPERATION on COMPONENT in the PLAN")) (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))))) @@ -7280,7 +7511,7 @@ processed in order by OPERATE.")) (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) (let ((plan (apply 'make-instance @@ -7296,9 +7527,10 @@ processed in order by OPERATE.")) (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 ((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 list) (component-path list)) (find component-path (mapcar 'cdr plan) @@ -7347,7 +7579,8 @@ processed in order by OPERATE.")) (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 (apply 'traverse-sub-actions goal-operation system + (remove-plist-key :goal-operation keys))) :from-end t))) ;;;; ------------------------------------------------------------------------- @@ -7440,7 +7673,7 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: (defmethod operate ((operation operation) (component component) &rest keys &key &allow-other-keys) (let ((plan (apply 'traverse operation component keys))) - (perform-plan plan) + (apply 'perform-plan plan keys) (values operation plan))) (defun oos (operation component &rest args &key &allow-other-keys) @@ -7563,1685 +7796,1705 @@ for how to load or compile stuff") (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 %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 clear-output-translations () - "Undoes any initialization of the output translations." - (setf *output-translations* '()) - (values)) - (register-clear-configuration-hook 'clear-output-translations) +;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute +;; and the companion asdf:feature pseudo-dependency. +;; This won't recurse into dependencies to accumulate feature conditions. +;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL +;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles. +(with-upgradability () + (defun %resolve-if-component-dep-fails (if-component-dep-fails component) + (asdf-message "The system definition for ~S uses deprecated ~ + ASDF option :IF-COMPONENT-DEP-DAILS. ~ + Starting with ASDF 3, please use :IF-FEATURE instead" + (coerce-name (component-system component))) + ;; This only supports the pattern of use of the "feature" seen in the wild + (check-type component parent-component) + (check-type if-component-dep-fails (member :fail :ignore :try-next)) + (unless (eq if-component-dep-fails :fail) + (loop :with o = (make-operation 'compile-op) + :for c :in (component-children component) :do + (loop* :for (feature? feature) :in (component-depends-on o c) + :when (eq feature? 'feature) :do + (setf (component-if-feature c) feature)))))) - (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))))))) +(when-upgrading (:when (fboundp 'make-sub-operation)) + (defun make-sub-operation (c o dep-c dep-o) + (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) - (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")) +;;;; load-sysdef +(with-upgradability () + (defun load-sysdef (name pathname) + (load-asd pathname :name name)) - (defun validate-output-translations-directory (directory) - (validate-configuration-directory - directory :output-translations 'validate-output-translations-directive - :invalid-form-reporter 'invalid-output-translation)) + (defun make-temporary-package () + ;; For loading a .asd file, we dont't make a temporary package anymore, + ;; but use ASDF-USER. I'd like to have this function do this, + ;; but since whoever uses it is likely to delete-package the result afterwards, + ;; this would be a bad idea, so preserve the old behavior. + (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf)))) - (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)) +;;;; ------------------------------------------------------------------------- +;;;; Defsystem - (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/")) +(asdf/package:define-package :asdf/defsystem + (:recycle :asdf/defsystem :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/cache + :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate + :asdf/backward-internals) + (:export + #:defsystem #:register-system-definition + #:class-for-type #:*default-component-class* + #:determine-system-directory #:parse-component-form + #:duplicate-names #:non-toplevel-system #:non-system-system + #:sysdef-error-component #:check-component-input)) +(in-package :asdf/defsystem) - (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")) +;;; Pathname +(with-upgradability () + (defun determine-system-directory (pathname) + ;; The defsystem macro calls this function to determine + ;; the pathname of a system as follows: + ;; 1. if the pathname argument is an pathname object (NOT a namestring), + ;; that is already an absolute pathname, return it. + ;; 2. otherwise, the directory containing the LOAD-PATHNAME + ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and + ;; if it is indeed available and an absolute pathname, then + ;; the PATHNAME argument is normalized to a relative pathname + ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) + ;; and merged into that DIRECTORY as per SUBPATHNAME. + ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded, + ;; and may be from within the EVAL-WHEN of a file compilation. + ;; If no absolute pathname was found, we return NIL. + (check-type pathname (or null string pathname)) + (pathname-directory-pathname + (resolve-symlinks* + (ensure-absolute-pathname + (parse-unix-namestring pathname :type :directory) + #'(lambda () (ensure-absolute-pathname + (load-pathname) 'get-pathname-defaults nil)) + nil))))) - (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)))) +;;; Component class +(with-upgradability () + (defvar *default-component-class* 'cl-source-file) - (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))))))))))) + (defun class-for-type (parent type) + (or (loop :for symbol :in (list + type + (find-symbol* type *package* 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))) + :return class) + (and (eq type :file) + (find-class* + (or (loop :for p = parent :then (component-parent p) :while p + :thereis (module-default-component-class p)) + *default-component-class*) nil)) + (sysdef-error "don't recognize component type ~A" type)))) - (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)) +;;; Check inputs +(with-upgradability () + (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 ~S~@:>") + (duplicate-names-name c))))) - (defvar *output-translations-parameter* nil) + (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)))) - (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))) + (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 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))) + (defun sysdef-error-component (msg type name value) + (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) + type name value)) - ;; 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 check-component-input (type name weakly-depends-on + depends-on components) + "A partial test of the values of a component." + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components))) - (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* (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)))))) - ;; Hook into asdf/driver's output-translation mechanism - #-cormanlisp - (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-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) +;;; Main parsing function (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")) + (defun* (parse-component-form) (parent options &key previous-serial-component) + (destructuring-bind + (type name &rest rest &key + (builtin-system-p () bspp) + ;; the following list of keywords is reproduced below in the + ;; 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 + ;; list ends + &allow-other-keys) options + (declare (ignorable perform explain output-files operation-done-p builtin-system-p)) + (check-component-input type name weakly-depends-on depends-on components) + (when (and parent + (find-component parent name) + (not ;; ignore the same object when rereading the defsystem + (typep (find-component parent name) + (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* ((name (coerce-name name)) + (args `(:name ,name + :pathname ,pathname + ,@(when parent `(:parent ,parent)) + ,@(remove-plist-keys + '(:components :pathname :if-component-dep-fails :version + :perform :explain :output-files :operation-done-p + :weakly-depends-on :depends-on :serial) + rest))) + (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 args))) + (component-pathname component) ; eagerly compute the absolute pathname + (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 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) + (when (typep component 'parent-component) + (setf (component-children component) + (loop + :with previous-component = nil + :for c-form :in components + :for c = (parse-component-form component c-form + :previous-serial-component previous-component) + :for name = (component-name c) + :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-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))) - (defgeneric* (process-source-registry) (spec &key inherit register)) + (defun register-system-definition + (name &rest options &key pathname (class 'system) (source-file () sfp) + defsystem-depends-on &allow-other-keys) + ;; The system must be registered before we parse the body, + ;; otherwise we recur when trying to find an existing system + ;; of the same name to reuse options (e.g. pathname) from. + ;; To avoid infinite recursion in cases where you defsystem a system + ;; that is registered to a different location to find-system, + ;; we also need to remember it in a special variable *systems-being-defined*. + (with-system-definitions () + (let* ((name (coerce-name name)) + (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) + (registered (system-registered-p name)) + (registered! (if registered + (rplaca registered (get-file-stamp source-file)) + (register-system + (make-instance 'system :name name :source-file source-file)))) + (system (reset-system (cdr registered!) + :name name :source-file source-file)) + (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 + nil (list* + :module name + :pathname (determine-system-directory pathname) + component-options))))) - (defun* (inherit-source-registry) (inherit &key register) - (when inherit - (process-source-registry (first inherit) :register register :inherit (rest inherit)))) + (defmacro defsystem (name &body options) + `(apply 'register-system-definition ',name ',options))) +;;;; ------------------------------------------------------------------------- +;;;; ASDF-Bundle - (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/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) - (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)))) +(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))) - (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)) + (defclass bundle-compile-op (bundle-op basic-compile-op) + () + (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files")) - ;; 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)) + ;; 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 lib-op (bundle-compile-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-op basic-compile-op) + ((bundle-type :initform :dll)) + (:documentation "Link together all the dynamic library used by this system into a single one.")) + + (defclass binary-op (basic-compile-op selfward-operation) + ((selfward-operation :initform '(fasl-op lib-op))) + (:documentation "produce fasl and asd files for the system")) - (defvar *source-registry-parameter* nil) + (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies - (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)) + (defclass monolithic-bundle-op (monolithic-op bundle-op) + ((prologue-code :accessor monolithic-op-prologue-code) + (epilogue-code :accessor monolithic-op-epilogue-code))) - ;; 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)) + (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")) - (defun sysdef-source-registry-search (system) - (ensure-source-registry) - (values (gethash (primary-system-name system) *source-registry*)))) + (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.")) -;;;; ------------------------------------------------------------------------- -;;; Internal hacks for backward-compatibility + (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-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.")) -(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) + (defclass monolithic-dll-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation) + ((bundle-type :initform :dll) + (selfward-operation :initform 'dll-op) + (sideway-operation :initform 'dll-op))) -;;;; Backward compatibility with "inline methods" -(with-upgradability () - (defparameter +asdf-methods+ - '(perform-with-restarts perform explain output-files operation-done-p)) + (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 %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 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"))))) - (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 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)))))))) - (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))) + (defmethod output-files ((o bundle-op) (c system)) + (bundle-output-files o c)) -;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute -;; and the companion asdf:feature pseudo-dependency. -;; This won't recurse into dependencies to accumulate feature conditions. -;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL -;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles. + #-(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 %resolve-if-component-dep-fails (if-component-dep-fails component) - (asdf-message "The system definition for ~S uses deprecated ~ - ASDF option :IF-COMPONENT-DEP-DAILS. ~ - Starting with ASDF 3, please use :IF-FEATURE instead" - (coerce-name (component-system component))) - ;; This only supports the pattern of use of the "feature" seen in the wild - (check-type component parent-component) - (check-type if-component-dep-fails (member :fail :ignore :try-next)) - (unless (eq if-component-dep-fails :fail) - (loop :with o = (make-operation 'compile-op) - :for c :in (component-children component) :do - (loop* :for (feature? feature) :in (component-depends-on o c) - :when (eq feature? 'feature) :do - (setf (component-if-feature c) feature)))))) + (defun operation-monolithic-p (op) + (typep op 'monolithic-op)) -(when-upgrading (:when (fboundp 'make-sub-operation)) - (defun make-sub-operation (c o dep-c dep-o) - (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) + (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 lib-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)) -;;;; load-sysdef + (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 () - (defun load-sysdef (name pathname) - (load-asd pathname :name name)) + (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))) - (defun make-temporary-package () - ;; For loading a .asd file, we dont't make a temporary package anymore, - ;; but use ASDF-USER. I'd like to have this function do this, - ;; but since whoever uses it is likely to delete-package the result afterwards, - ;; this would be a bad idea, so preserve the old behavior. - (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf)))) + (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))) -;;;; ------------------------------------------------------------------------- -;;;; Defsystem + (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))) -(asdf/package:define-package :asdf/defsystem - (:recycle :asdf/defsystem :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system :asdf/cache - :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate - :asdf/backward-internals) - (:export - #:defsystem #:register-system-definition - #:class-for-type #:*default-component-class* - #:determine-system-directory #:parse-component-form - #:duplicate-names #:sysdef-error-component #:check-component-input)) -(in-package :asdf/defsystem) + (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))) -;;; Pathname -(with-upgradability () - (defun determine-system-directory (pathname) - ;; The defsystem macro calls this function to determine - ;; the pathname of a system as follows: - ;; 1. if the pathname argument is an pathname object (NOT a namestring), - ;; that is already an absolute pathname, return it. - ;; 2. otherwise, the directory containing the LOAD-PATHNAME - ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and - ;; if it is indeed available and an absolute pathname, then - ;; the PATHNAME argument is normalized to a relative pathname - ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) - ;; and merged into that DIRECTORY as per SUBPATHNAME. - ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded, - ;; and may be from within the EVAL-WHEN of a file compilation. - ;; If no absolute pathname was found, we return NIL. - (check-type pathname (or null string pathname)) - (pathname-directory-pathname - (resolve-symlinks* - (ensure-absolute-pathname - (parse-unix-namestring pathname :type :directory) - #'(lambda () (ensure-absolute-pathname - (load-pathname) 'get-pathname-defaults nil)) - nil))))) + (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))) -;;; Component class -(with-upgradability () - (defvar *default-component-class* 'cl-source-file) + (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) + (mark-operation-done (find-operation o 'load-op) c))) - (defun class-for-type (parent type) - (or (loop :for symbol :in (list - type - (find-symbol* type *package* 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))) - :return class) - (and (eq type :file) - (find-class* - (or (loop :for p = parent :then (component-parent p) :while p - :thereis (module-default-component-class p)) - *default-component-class*) nil)) - (sysdef-error "don't recognize component type ~A" type)))) +;;; +;;; 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)) -;;; Check inputs +;;; +;;; Pre-built systems +;;; (with-upgradability () - (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 ~S~@:>") - (duplicate-names-name c))))) + (defmethod trivial-system-p ((s prebuilt-system)) + (declare (ignorable s)) + t) - (defun sysdef-error-component (msg type name value) - (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) - type name value)) + (defmethod perform ((o lib-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) - (defun check-component-input (type name weakly-depends-on - depends-on components) - "A partial test of the values of a component." - (unless (listp depends-on) - (sysdef-error-component ":depends-on must be a list." - type name depends-on)) - (unless (listp weakly-depends-on) - (sysdef-error-component ":weakly-depends-on must be a list." - type name weakly-depends-on)) - (unless (listp components) - (sysdef-error-component ":components must be NIL or a list of components." - type name components))) + (defmethod component-depends-on ((o lib-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) - (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)))))) + (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system)) + (declare (ignorable o)) + nil)) -;;; Main parsing function +;;; +;;; PREBUILT SYSTEM CREATOR +;;; (with-upgradability () - (defun* (parse-component-form) (parent options &key previous-serial-component) - (destructuring-bind - (type name &rest rest &key - (builtin-system-p () bspp) - ;; the following list of keywords is reproduced below in the - ;; 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 - ;; list ends - &allow-other-keys) options - (declare (ignorable perform explain output-files operation-done-p builtin-system-p)) - (check-component-input type name weakly-depends-on depends-on components) - (when (and parent - (find-component parent name) - (not ;; ignore the same object when rereading the defsystem - (typep (find-component parent name) - (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) - :pathname ,pathname - ,@(when parent `(:parent ,parent)) - ,@(remove-plist-keys - '(:components :pathname :if-component-dep-fails :version - :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)) - (if component ; preserve identity - (apply 'reinitialize-instance component args) - (setf component (apply 'make-instance (class-for-type parent type) args))) - (component-pathname component) ; eagerly compute the absolute pathname - (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 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) - (when (typep component 'parent-component) - (setf (component-children component) - (loop - :with previous-component = nil - :for c-form :in components - :for c = (parse-component-form component c-form - :previous-serial-component previous-component) - :for name = (component-name c) - :collect c - :when serial :do (setf previous-component name))) - (compute-children-by-name component)) - ;; Used by POIU. ASDF4: rename to component-depends-on? - (setf (component-sibling-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))) - - (defun register-system-definition - (name &rest options &key pathname (class 'system) (source-file () sfp) - defsystem-depends-on &allow-other-keys) - ;; The system must be registered before we parse the body, - ;; otherwise we recur when trying to find an existing system - ;; of the same name to reuse options (e.g. pathname) from. - ;; To avoid infinite recursion in cases where you defsystem a system - ;; that is registered to a different location to find-system, - ;; we also need to remember it in a special variable *systems-being-defined*. - (with-system-definitions () - (let* ((name (coerce-name name)) - (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) - (registered (system-registered-p name)) - (registered! (if registered - (rplaca registered (get-file-stamp source-file)) - (register-system - (make-instance 'system :name name :source-file source-file)))) - (system (reset-system (cdr registered!) - :name name :source-file source-file)) - (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 (eq (type-of system) class) - (change-class system class))) - (parse-component-form - nil (list* - :module name - :pathname (determine-system-directory pathname) - component-options))))) + (defmethod output-files ((o binary-op) (s system)) + (list (make-pathname :name (component-name s) :type "asd" + :defaults (component-pathname s)))) - (defmacro defsystem (name &body options) - `(apply 'register-system-definition ',name ',options))) -;;;; ------------------------------------------------------------------------- -;;;; ASDF-Bundle + (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))))) -(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 #:bundlable-file-p #: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) + #-(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))))) -(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 input-files ((o load-op) (s precompiled-system)) + (declare (ignorable o)) + (bundle-output-files (find-operation o 'fasl-op) s)) - (defclass fasl-op (bundle-op) - ;; create a single fasl for the entire library - ((bundle-type :initform :fasl))) + (defmethod perform ((o load-op) (s precompiled-system)) + (perform-lisp-load-fasl o s)) - (defclass load-fasl-op (basic-load-op) - ;; load a single fasl for the entire library - ()) + (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) + (declare (ignorable o)) + `((load-op ,s) ,@(call-next-method)))) - (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))) + #| ;; 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 dll-op (bundle-op) - ;; Link together all the dynamic library used by this system into a single one. - ((bundle-type :initform :dll))) +#+(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 binary-op (bundle-op) - ;; On ECL: produce lib and fasl for the system. - ;; On "normal" Lisps: produce just the fasl. - ()) + (defun register-pre-built-system (name) + (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))) - (defclass monolithic-op (operation) ()) ;; operation on a 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-bundle-op (monolithic-op bundle-op) - ((prologue-code :accessor monolithic-op-prologue-code) - (epilogue-code :accessor monolithic-op-epilogue-code))) +#+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-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. - ()) + (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 monolithic-fasl-op (monolithic-bundle-op fasl-op) - ;; Create a single fasl for the system and its dependencies. - ()) + (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 + +(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) - (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))) +;;; +;;; 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)) - (defclass monolithic-dll-op (monolithic-bundle-op dll-op) - ((bundle-type :initform :dll))) + (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))) - (defclass program-op (monolithic-bundle-op) - ;; All: create an executable file from the system and its dependencies - ((bundle-type :initform :program))) +;;;; --------------------------------------------------------------------------- +;;;; asdf-output-translations - (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/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) - (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))))))) +(when-upgrading () (undefine-function '(setf output-translations))) - (defmethod output-files ((o bundle-op) (c system)) - (bundle-output-files o c)) +(with-upgradability () + (define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~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))) + (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.") - (defmethod perform ((o monolithic-binary-op) (c system)) - (let ((output-file (output-file o c))) - (dump-image output-file)))) + (defun output-translations () + (car *output-translations*)) - (defclass compiled-file (file-component) - ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) + (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) - (defclass precompiled-system (system) - ((build-pathname :initarg :fasl))) + (defun output-translations-initialized-p () + (and *output-translations* t)) - (defclass prebuilt-system (system) - ((build-pathname :initarg :static-library :initarg :lib - :accessor prebuilt-system-static-library)))) + (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))))))) -;;; -;;; 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 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)) - (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)))) + (defun validate-output-translations-file (file) + (validate-configuration-file + file 'validate-output-translations-form :description "output translations")) - (defmethod bundle-op-build-args :around ((o lib-op)) - (declare (ignorable o)) - (let ((args (call-next-method))) - (remf args :ld-flags) - args)) + (defun validate-output-translations-directory (directory) + (validate-configuration-directory + directory :output-translations 'validate-output-translations-directive + :invalid-form-reporter 'invalid-output-translation)) - (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 allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) + (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))))))))) - (defgeneric* (trivial-system-p) (component)) + (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 user-system-p (s) - (and (typep s 'system) - (not (builtin-system-p s)) - (not (trivial-system-p s))))) + (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)) -(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) - (deftype user-system () '(and system (satisfies user-system-p)))) + (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf")) + (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/")) -;;; -;;; 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)))) + (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")) - (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)))) + (defgeneric process-output-translations (spec &key inherit collect)) - (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 inherit-output-translations (inherit &key collect) + (when inherit + (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) - (defmethod component-depends-on ((o binary-op) (c system)) - (declare (ignorable o)) - `((fasl-op ,c) - (lib-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 monolithic-binary-op) (c system)) - `((,(find-operation o 'monolithic-fasl-op) ,c) - (,(find-operation o 'monolithic-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 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)))) + (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 fasl-op) (c system)) - (declare (ignorable o)) - #+ecl `((lib-op ,c)) - #-ecl - (component-depends-on (find-operation o 'lib-op) c)) + (defvar *output-translations-parameter* nil) - (defmethod component-depends-on ((o dll-op) c) - (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 bundle-op) c) - (declare (ignorable o c)) - nil) + (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 :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))) + ;; 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 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)))))) + (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))))) + + ;; 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/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 #: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))) - - (defmethod input-files ((o load-fasl-op) (c system)) - (when (user-system-p c) - (output-files (find-operation o 'fasl-op) c))) + (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 perform ((o load-fasl-op) c) - (declare (ignorable o c)) - nil) + (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 system)) - (perform-lisp-load-fasl o c)) + (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader. + (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) - (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) - (mark-operation-done (find-operation o 'load-op) 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)) -;;; -;;; 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))) + (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))) - (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 -;;; +;;;; ASDF-Binary-Locations compatibility +;; This remains supported for legacy user, but not recommended for new users. (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) + (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) + (run-program command :force-shell t :ignore-error-status t :output *verbose-out*)))) - #-(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 #'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))) - (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. - (defmethod input-files ((o load-op) (s precompiled-system)) - (declare (ignorable o)) - (bundle-output-files (find-operation o 'fasl-op) s)) +;; 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 perform ((o load-op) (s precompiled-system)) - (perform-lisp-load-fasl o 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)) -(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. @@ -9263,25 +9516,28 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." ;; TODO: automatically generate interface with reexport? (:export #:defsystem #:find-system #:locate-system #:coerce-name - #:oos #:operate #:traverse #:perform-plan + #:oos #:operate #:traverse #: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 @@ -9357,7 +9613,7 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." #:missing-dependency #:missing-dependency-of-version #:circular-dependency ; errors - #:duplicate-names + #:duplicate-names #:non-toplevel-system #:non-system-system #:try-recompiling #:retry @@ -9391,6 +9647,7 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." #: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 diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index f36f6d02b697d8baf470f82f0d432d9b86ce6dfb..90df1d44efceb48d83e426f4019042e1a8d0219e 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -23,7 +23,7 @@ New in this release: * Feature enhancements * Changes - * ASDF2 updated to version 2.32. + * ASDF2 updated to version 3.0.1.. * DEFINE-COMPILER-MACRO now has source-location information for the macro definition. * :ALIEN-CALLBACK added to *FEATURES* for platforms that support