X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=contrib%2Fasdf%2Fasdf.lisp;h=e90fae758b8338feb108aed91881039b8d8fd4af;hb=d5520a24b6c356918c2f91bf91dae60f62e1d065;hp=1cc6a6d51d5f11982152e1f084ccb6e9883924a0;hpb=5bf941f419b6cd275feb3ee44ca264596fbd9e8e;p=sbcl.git diff --git a/contrib/asdf/asdf.lisp b/contrib/asdf/asdf.lisp index 1cc6a6d..e90fae7 100644 --- a/contrib/asdf/asdf.lisp +++ b/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.29: Another System Definition Facility. +;;; This is ASDF 3.0.2: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to . @@ -54,7 +54,7 @@ (declaim (optimize (speed 1) (safety 3) (debug 3))) (setf ext:*gc-verbose* nil)) -#+(or abcl clisp cmu ecl xcl) +#+(or abcl clisp clozure cmu ecl xcl) (eval-when (:load-toplevel :compile-toplevel :execute) (unless (member :asdf3 *features*) (let* ((existing-version @@ -70,39 +70,39 @@ (existing-major-minor (subseq existing-version 0 second-dot)) (existing-version-number (and existing-version (read-from-string existing-major-minor))) (away (format nil "~A-~A" :asdf existing-version))) - (when (and existing-version (< existing-version-number - #+abcl 2.25 #+clisp 2.27 #+cmu 2.018 #+ecl 2.21 #+xcl 2.27)) + (when (and existing-version + (< existing-version-number #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27)) (rename-package :asdf away) (when *load-verbose* - (format t "; Renamed old ~A package away to ~A~%" :asdf away)))))) + (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))) ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. ;; ;; See https://bugs.launchpad.net/asdf/+bug/485687 ;; -;; CAUTION: we must handle the first few packages specially for hot-upgrade. -;; asdf/package will be frozen as of ASDF 3 -;; to forever export the same exact symbols. -;; Any other symbol must be import-from'ed -;; and reexported in a different package -;; (alternatively the package may be dropped & replaced by one with a new name). - -(defpackage :asdf/package + +(defpackage :uiop/package + ;; CAUTION: we must handle the first few packages specially for hot-upgrade. + ;; This package definition MUST NOT change unless its name too changes; + ;; if/when it changes, don't forget to add new functions missing from below. + ;; Until then, asdf/package is frozen to forever + ;; import and export the same exact symbols as for ASDF 2.27. + ;; Any other symbol must be import-from'ed and re-export'ed in a different package. (:use :common-lisp) (:export #:find-package* #:find-symbol* #:symbol-call - #:intern* #:unintern* #:export* #:make-symbol* - #:symbol-shadowing-p #:home-package-p #:rehome-symbol + #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern* + #:symbol-shadowing-p #:home-package-p #:symbol-package-name #:standard-common-lisp-symbol-p #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol - #:nuke-symbol-in-package #:nuke-symbol + #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol #:ensure-package-unused #:delete-package* - #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names + #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away #:package-definition-form #:parse-define-package-form #:ensure-package #:define-package)) -(in-package :asdf/package) +(in-package :uiop/package) ;;;; General purpose package utilities @@ -139,6 +139,12 @@ or when loading the package is optional." (let* ((package (find-package* package-designator)) (symbol (intern* name package))) (export (or symbol (list symbol)) package))) + (defun import* (symbol package-designator) + (import (or symbol (list symbol)) (find-package* package-designator))) + (defun shadowing-import* (symbol package-designator) + (shadowing-import (or symbol (list symbol)) (find-package* package-designator))) + (defun shadow* (name package-designator) + (shadow (string name) (find-package* package-designator))) (defun make-symbol* (name) (etypecase name (string (make-symbol name)) @@ -257,8 +263,8 @@ or when loading the package is optional." (multiple-value-bind (sym stat) (find-symbol name package) (when (and (member stat '(:internal :external)) (eq symbol sym)) (if (symbol-shadowing-p symbol package) - (shadowing-import (get-dummy-symbol symbol) package) - (unintern symbol package)))))) + (shadowing-import* (get-dummy-symbol symbol) package) + (unintern* symbol package)))))) (defun nuke-symbol (symbol &optional (packages (list-all-packages))) #+(or clisp clozure) (multiple-value-bind (setf-symbol kind) @@ -283,18 +289,18 @@ or when loading the package is optional." (package-name package) overwritten-symbol-status overwritten-symbol-shadowing-p) (when old-package (if shadowing - (shadowing-import shadowing old-package)) - (unintern symbol old-package)) + (shadowing-import* shadowing old-package)) + (unintern* symbol old-package)) (cond (overwritten-symbol-shadowing-p - (shadowing-import symbol package)) + (shadowing-import* symbol package)) (t (when overwritten-symbol-status - (unintern overwritten-symbol package)) - (import symbol package))) + (unintern* overwritten-symbol package)) + (import* symbol package))) (if shadowing - (shadowing-import symbol old-package) - (import symbol old-package)) + (shadowing-import* symbol old-package) + (import* symbol old-package)) #+(or clisp clozure) (multiple-value-bind (setf-symbol kind) (get-setf-function-symbol symbol) @@ -307,7 +313,7 @@ or when loading the package is optional." (symbol-name setf-symbol) (symbol-package-name setf-symbol) (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol)) (when (symbol-package setf-symbol) - (unintern setf-symbol (symbol-package setf-symbol))) + (unintern* setf-symbol (symbol-package setf-symbol))) (setf (fdefinition new-setf-symbol) setf-function) (set-setf-function-symbol new-setf-symbol symbol kind)))) #+(or clisp clozure) @@ -434,7 +440,34 @@ or when loading the package is optional." (or (home-package-p import-me from-package) (symbol-package-name import-me)) (package-name to-package) status (and status (or (home-package-p existing to-package) (symbol-package-name existing))))) - (shadowing-import import-me to-package)))))) + (shadowing-import* import-me to-package)))))) + (defun ensure-imported (import-me into-package &optional from-package) + (check-type import-me symbol) + (check-type into-package package) + (check-type from-package (or null package)) + (let ((name (symbol-name import-me))) + (multiple-value-bind (existing status) (find-symbol name into-package) + (cond + ((not status) + (import* import-me into-package)) + ((eq import-me existing)) + (t + (let ((shadowing-p (symbol-shadowing-p existing into-package))) + (note-package-fishiness + :ensure-imported name + (and from-package (package-name from-package)) + (or (home-package-p import-me from-package) (symbol-package-name import-me)) + (package-name into-package) + status + (and status (or (home-package-p existing into-package) (symbol-package-name existing))) + shadowing-p) + (cond + ((or shadowing-p (eq status :inherited)) + (shadowing-import* import-me into-package)) + (t + (unintern* existing into-package) + (import* import-me into-package)))))))) + (values)) (defun ensure-import (name to-package from-package shadowed imported) (check-type name string) (check-type to-package package) @@ -445,27 +478,18 @@ or when loading the package is optional." (when (null import-status) (note-package-fishiness :import-uninterned name (package-name from-package) (package-name to-package)) - (setf import-me (intern name from-package))) + (setf import-me (intern* name from-package))) (multiple-value-bind (existing status) (find-symbol name to-package) (cond - ((gethash name imported) - (unless (eq import-me existing) + ((and imported (gethash name imported)) + (unless (and status (eq import-me existing)) (error "Can't import ~S from both ~S and ~S" name (package-name (symbol-package existing)) (package-name from-package)))) ((gethash name shadowed) (error "Can't both shadow ~S and import it from ~S" name (package-name from-package))) (t - (setf (gethash name imported) t) - (unless (and status (eq import-me existing)) - (when status - (note-package-fishiness - :import name - (package-name from-package) - (or (home-package-p import-me from-package) (symbol-package-name import-me)) - (package-name to-package) status - (and status (or (home-package-p existing to-package) (symbol-package-name existing)))) - (unintern* existing to-package)) - (import import-me to-package))))))) + (setf (gethash name imported) t)))) + (ensure-imported import-me to-package from-package))) (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited) (check-type name string) (check-type symbol symbol) @@ -483,7 +507,7 @@ or when loading the package is optional." (note-package-fishiness :import-uninterned name (package-name from-package) (package-name to-package) mixp) - (import symbol from-package) + (import* symbol from-package) (setf sp (package-name from-package))) (cond ((gethash name shadowed)) @@ -556,7 +580,7 @@ or when loading the package is optional." (defun symbol-recycled-p (sym recycle) (check-type sym symbol) (check-type recycle list) - (member (symbol-package sym) recycle)) + (and (member (symbol-package sym) recycle) t)) (defun ensure-symbol (name package intern recycle shadowed imported inherited exported) (check-type name string) (check-type package package) @@ -590,6 +614,7 @@ or when loading the package is optional." (check-type symbol symbol) (check-type to-package package) (check-type recycle list) + (assert (equal name (symbol-name symbol))) (multiple-value-bind (existing status) (find-symbol name to-package) (unless (and status (eq symbol existing)) (let ((accessible @@ -603,7 +628,7 @@ or when loading the package is optional." (or (home-package-p existing to-package) (symbol-package-name existing)) status shadowing) (if (or (eq status :inherited) shadowing) - (shadowing-import symbol to-package) + (shadowing-import* symbol to-package) (unintern existing to-package)) t))))) (when (and accessible (eq status :external)) @@ -611,7 +636,8 @@ or when loading the package is optional." (defun ensure-exported (name symbol from-package &optional recycle) (dolist (to-package (package-used-by-list from-package)) (ensure-exported-to-user name symbol to-package recycle)) - (import symbol from-package) + (unless (eq from-package (symbol-package symbol)) + (ensure-imported symbol from-package)) (export* name from-package)) (defun ensure-export (name from-package &optional recycle) (multiple-value-bind (symbol status) (find-symbol* name from-package) @@ -693,9 +719,9 @@ or when loading the package is optional." (note-package-fishiness :shadow-imported (package-name package) name (symbol-package-name existing) status shadowing) - (shadowing-import dummy package) - (import dummy package))))))) - (shadow name package)) + (shadowing-import* dummy package) + (import* dummy package))))))) + (shadow* name package)) (loop :for (p . syms) :in shadowing-import-from :for pp = (find-package* p) :do (dolist (sym syms) (ensure-shadowing-import (string sym) package pp shadowed imported))) @@ -783,6 +809,9 @@ or when loading the package is optional." (pushnew :gcl2.6 *features*)) (t (pushnew :gcl2.7 *features*)))) + +;; Compatibility with whoever calls asdf/package +(define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package)) ;;;; ------------------------------------------------------------------------- ;;;; Handle compatibility with multiple implementations. ;;; This file is for papering over the deficiencies and peculiarities @@ -791,11 +820,11 @@ or when loading the package is optional." ;;; A few functions are defined here, but actually exported from utility; ;;; from this package only common-lisp symbols are exported. -(asdf/package:define-package :asdf/common-lisp - (:nicknames :asdf/cl) - (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package) +(uiop/package:define-package :uiop/common-lisp + (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl) + (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package) (:reexport :common-lisp) - (:recycle :asdf/common-lisp :asdf) + (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf) #+allegro (:intern #:*acl-warn-save*) #+cormanlisp (:shadow #:user-homedir-pathname) #+cormanlisp @@ -807,7 +836,7 @@ or when loading the package is optional." #+genera (:shadowing-import-from :scl #:boolean) #+genera (:export #:boolean #:ensure-directories-exist) #+mcl (:shadow #:user-homedir-pathname)) -(in-package :asdf/common-lisp) +(in-package :uiop/common-lisp) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "ASDF is not supported on your implementation. Please help us port it.") @@ -858,13 +887,13 @@ or when loading the package is optional." #+gcl2.6 (eval-when (:compile-toplevel :load-toplevel :execute) - (shadow 'type-of :asdf/common-lisp) - (shadowing-import 'system:*load-pathname* :asdf/common-lisp)) + (shadow 'type-of :uiop/common-lisp) + (shadowing-import 'system:*load-pathname* :uiop/common-lisp)) #+gcl2.6 (eval-when (:compile-toplevel :load-toplevel :execute) - (export 'type-of :asdf/common-lisp) - (export 'system:*load-pathname* :asdf/common-lisp)) + (export 'type-of :uiop/common-lisp) + (export 'system:*load-pathname* :uiop/common-lisp)) #+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations. (eval-when (:load-toplevel :compile-toplevel :execute) @@ -932,24 +961,33 @@ or when loading the package is optional." ;;;; compatfmt: avoid fancy format directives when unsupported (eval-when (:load-toplevel :compile-toplevel :execute) - (defun remove-substrings (substrings string) + (defun frob-substrings (string substrings &optional frob) + (declare (optimize (speed 0) (safety 3) (debug 3))) (let ((length (length string)) (stream nil)) - (labels ((emit (start end) - (when (and (zerop start) (= end length)) - (return-from remove-substrings string)) + (labels ((emit-string (x &optional (start 0) (end (length x))) (when (< start end) (unless stream (setf stream (make-string-output-stream))) - (write-string string stream :start start :end end))) + (write-string x stream :start start :end end))) + (emit-substring (start end) + (when (and (zerop start) (= end length)) + (return-from frob-substrings string)) + (emit-string string start end)) (recurse (substrings start end) (cond ((>= start end)) - ((null substrings) (emit start end)) - (t (let* ((sub (first substrings)) + ((null substrings) (emit-substring start end)) + (t (let* ((sub-spec (first substrings)) + (sub (if (consp sub-spec) (car sub-spec) sub-spec)) + (fun (if (consp sub-spec) (cdr sub-spec) frob)) (found (search sub string :start2 start :end2 end)) (more (rest substrings))) (cond (found (recurse more start found) + (etypecase fun + (null) + (string (emit-string fun)) + (function (funcall fun sub #'emit-string))) (recurse substrings (+ found (length sub)) end)) (t (recurse more start end)))))))) @@ -958,29 +996,33 @@ or when loading the package is optional." (defmacro compatfmt (format) #+(or gcl genera) - (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format) + (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>"))) #-(or gcl genera) format)) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities for ASDF -(asdf/package:define-package :asdf/utility - (:recycle :asdf/utility :asdf) - (:use :asdf/common-lisp :asdf/package) +(uiop/package:define-package :uiop/utility + (:nicknames :asdf/utility) + (:recycle :uiop/utility :asdf/utility :asdf) + (:use :uiop/common-lisp :uiop/package) ;; import and reexport a few things defined in :asdf/common-lisp - (:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings + (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) - (:export #:compatfmt #:loop* #:remove-substrings #:compatfmt + (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export ;; magic helper to define debugging functions: - #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility* + #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions #:if-let ;; basic flow control - #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists + #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists + #:remove-plist-keys #:remove-plist-key ;; plists #:emptyp ;; sequences - #:strcat #:first-char #:last-char #:split-string ;; strings + #:+non-base-chars-exist-p+ ;; characters + #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings + #:first-char #:last-char #:split-string #:string-prefix-p #:string-enclosed-p #:string-suffix-p #:find-class* ;; CLOS #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps @@ -991,10 +1033,9 @@ or when loading the package is optional." #:call-function #:call-functions #:register-hook-function #:match-condition-p #:match-any-condition-p ;; conditions #:call-with-muffled-conditions #:with-muffled-conditions - #:load-string #:load-stream #:lexicographic< #:lexicographic<= #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version -(in-package :asdf/utility) +(in-package :uiop/utility) ;;;; Defining functions in a way compatible with hot-upgrade: ;; DEFUN* and DEFGENERIC* use FMAKUNBOUND to delete any previous fdefinition, @@ -1054,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-driver "contrib/debug.lisp")) - (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname))) + (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")) + (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp")) "form that evaluates to the pathname to your favorite debugging utilities") - (defmacro asdf-debug (&rest keys) + (defmacro uiop-debug (&rest keys) `(eval-when (:compile-toplevel :load-toplevel :execute) - (load-asdf-debug-utility ,@keys))) + (load-uiop-debug-utility ,@keys))) - (defun load-asdf-debug-utility (&key package utility-file) + (defun load-uiop-debug-utility (&key package utility-file) (let* ((*package* (if package (find-package package) *package*)) (keyword (read-from-string (format nil ":DBG-~:@(~A~)" (package-name *package*))))) (unless (member keyword *features*) - (let* ((utility-file (or utility-file *asdf-debug-utility*)) + (let* ((utility-file (or utility-file *uiop-debug-utility*)) (file (ignore-errors (probe-file (eval utility-file))))) (if file (load file) (error "Failed to locate debug utility file: ~S" utility-file))))))) @@ -1118,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 () @@ -1142,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))) @@ -1166,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?" @@ -1362,9 +1438,6 @@ with later being determined by a lexicographical comparison of minor numbers." ;;; Condition control (with-upgradability () - (defvar *uninteresting-conditions* nil - "Uninteresting conditions, as per MATCH-CONDITION-P") - (defparameter +simple-condition-format-control-slot+ #+abcl 'system::format-control #+allegro 'excl::format-control @@ -1384,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 @@ -1401,16 +1475,17 @@ or a string describing the format-control of a simple-condition." (muffle-warning c))))) (funcall thunk))) - (defmacro with-muffled-uninteresting-conditions ((conditions) &body body) - `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body) ,conditions))) + (defmacro with-muffled-conditions ((conditions) &body body) + `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) ;;;; --------------------------------------------------------------------------- ;;;; Access to the Operating System -(asdf/package:define-package :asdf/os - (:recycle :asdf/os :asdf) - (:use :asdf/common-lisp :asdf/package :asdf/utility) +(uiop/package:define-package :uiop/os + (:nicknames :asdf/os) + (:recycle :uiop/os :asdf/os :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility) (:export #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features #:getenv #:getenvp ;; environment variables @@ -1421,7 +1496,7 @@ or a string describing the format-control of a simple-condition." ;; Windows shortcut support #:read-null-terminated-string #:read-little-endian #:parse-file-location-info #:parse-windows-shortcut)) -(in-package :asdf/os) +(in-package :uiop/os) ;;; Features (with-upgradability () @@ -1439,20 +1514,23 @@ or a string describing the format-control of a simple-condition." (defun os-windows-p () (or #+abcl (featurep :windows) - #+(and (not (or unix cygwin darwin)) (or win32 windows mswindows mingw32)) t)) + #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t)) (defun os-genera-p () (or #+genera t)) + (defun os-oldmac-p () + (or #+mcl t)) + (defun detect-os () - (flet ((yes (yes) (pushnew yes *features*)) - (no (no) (setf *features* (remove no *features*)))) - (cond - ((os-unix-p) (yes :os-unix) (no :os-windows) (no :genera)) - ((os-windows-p) (yes :os-windows) (no :os-unix) (no :genera)) - ((os-genera-p) (no :os-unix) (no :os-windows) (yes :genera)) - (t (error "Congratulations for trying XCVB on an operating system~%~ -that is neither Unix, nor Windows, nor even Genera.~%Now you port it."))))) + (loop* :with o + :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p) + (:genera . os-genera-p) (:os-oldmac . os-oldmac-p)) + :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*) + :else :do (setf *features* (remove feature *features*)) + :finally + (return (or o (error "Congratulations for trying ASDF on an operating system~%~ +that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port it."))))) (detect-os)) @@ -1596,7 +1674,7 @@ then returning the non-empty string value of the variable" (with-upgradability () (defun hostname () ;; Note: untested on RMCL - #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) + #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) #+cormanlisp "localhost" ;; is there a better way? Does it matter? #+allegro (symbol-call :excl.osi :gethostname) #+clisp (first (split-string (machine-instance) :separator " ")) @@ -1625,7 +1703,7 @@ then returning the non-empty string value of the variable" #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? #+ecl (ext:getcwd) #+gcl (parse-namestring ;; this is a joke. Isn't there a better way? - (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines))) + (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines))) #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical! #+lispworks (system:current-directory) #+mkcl (mk-ext:getcwd) @@ -1657,75 +1735,74 @@ then returning the non-empty string value of the variable" ;;;; Jesse Hager: The Windows Shortcut File Format. ;;;; http://www.wotsit.org/list.asp?fc=13 -(with-upgradability () - #-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. - (progn - (defparameter *link-initial-dword* 76) - (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) - - (defun read-null-terminated-string (s) - (with-output-to-string (out) - (loop :for code = (read-byte s) - :until (zerop code) - :do (write-char (code-char code) out)))) - - (defun read-little-endian (s &optional (bytes 4)) - (loop :for i :from 0 :below bytes - :sum (ash (read-byte s) (* 8 i)))) - - (defun parse-file-location-info (s) - (let ((start (file-position s)) - (total-length (read-little-endian s)) - (end-of-header (read-little-endian s)) - (fli-flags (read-little-endian s)) - (local-volume-offset (read-little-endian s)) - (local-offset (read-little-endian s)) - (network-volume-offset (read-little-endian s)) - (remaining-offset (read-little-endian s))) - (declare (ignore total-length end-of-header local-volume-offset)) - (unless (zerop fli-flags) - (cond - ((logbitp 0 fli-flags) - (file-position s (+ start local-offset))) - ((logbitp 1 fli-flags) - (file-position s (+ start - network-volume-offset - #x14)))) - (strcat (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) - - (defun parse-windows-shortcut (pathname) - (with-open-file (s pathname :element-type '(unsigned-byte 8)) - (handler-case - (when (and (= (read-little-endian s) *link-initial-dword*) - (let ((header (make-array (length *link-guid*)))) - (read-sequence header s) - (equalp header *link-guid*))) - (let ((flags (read-little-endian s))) - (file-position s 76) ;skip rest of header - (when (logbitp 0 flags) - ;; skip shell item id list - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (cond - ((logbitp 1 flags) - (parse-file-location-info s)) - (t - (when (logbitp 2 flags) - ;; skip description string - (let ((length (read-little-endian s 2))) - (file-position s (+ length (file-position s))))) - (when (logbitp 3 flags) - ;; finally, our pathname - (let* ((length (read-little-endian s 2)) - (buffer (make-array length))) - (read-sequence buffer s) - (map 'string #'code-char buffer))))))) - (end-of-file (c) - (declare (ignore c)) - nil)))))) +#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. +(with-upgradability () + (defparameter *link-initial-dword* 76) + (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) + + (defun read-null-terminated-string (s) + (with-output-to-string (out) + (loop :for code = (read-byte s) + :until (zerop code) + :do (write-char (code-char code) out)))) + + (defun read-little-endian (s &optional (bytes 4)) + (loop :for i :from 0 :below bytes + :sum (ash (read-byte s) (* 8 i)))) + + (defun parse-file-location-info (s) + (let ((start (file-position s)) + (total-length (read-little-endian s)) + (end-of-header (read-little-endian s)) + (fli-flags (read-little-endian s)) + (local-volume-offset (read-little-endian s)) + (local-offset (read-little-endian s)) + (network-volume-offset (read-little-endian s)) + (remaining-offset (read-little-endian s))) + (declare (ignore total-length end-of-header local-volume-offset)) + (unless (zerop fli-flags) + (cond + ((logbitp 0 fli-flags) + (file-position s (+ start local-offset))) + ((logbitp 1 fli-flags) + (file-position s (+ start + network-volume-offset + #x14)))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) + + (defun parse-windows-shortcut (pathname) + (with-open-file (s pathname :element-type '(unsigned-byte 8)) + (handler-case + (when (and (= (read-little-endian s) *link-initial-dword*) + (let ((header (make-array (length *link-guid*)))) + (read-sequence header s) + (equalp header *link-guid*))) + (let ((flags (read-little-endian s))) + (file-position s 76) ;skip rest of header + (when (logbitp 0 flags) + ;; skip shell item id list + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (cond + ((logbitp 1 flags) + (parse-file-location-info s)) + (t + (when (logbitp 2 flags) + ;; skip description string + (let ((length (read-little-endian s 2))) + (file-position s (+ length (file-position s))))) + (when (logbitp 3 flags) + ;; finally, our pathname + (let* ((length (read-little-endian s 2)) + (buffer (make-array length))) + (read-sequence buffer s) + (map 'string #'code-char buffer))))))) + (end-of-file (c) + (declare (ignore c)) + nil))))) ;;;; ------------------------------------------------------------------------- @@ -1733,9 +1810,10 @@ then returning the non-empty string value of the variable" ;; This layer allows for portable manipulation of pathname objects themselves, ;; which all is necessary prior to any access the filesystem or environment. -(asdf/package:define-package :asdf/pathname - (:recycle :asdf/pathname :asdf) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os) +(uiop/package:define-package :uiop/pathname + (:nicknames :asdf/pathname) + (:recycle :uiop/pathname :asdf/pathname :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os) (:export ;; Making and merging pathnames, portably #:normalize-pathname-directory-component #:denormalize-pathname-directory-component @@ -1767,7 +1845,7 @@ then returning the non-empty string value of the variable" #:directory-separator-for-host #:directorize-pathname-host-device #:translate-pathname* #:*output-translation-function*)) -(in-package :asdf/pathname) +(in-package :uiop/pathname) ;;; Normalizing pathnames across implementations @@ -1836,6 +1914,7 @@ then returning the non-empty string value of the variable" "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and tries hard to make a pathname that will actually behave as documented, despite the peculiarities of each implementation" + ;; TODO: reimplement defaulting for MCL, whereby an explicit NIL should override the defaults. (declare (ignorable host device directory name type version defaults)) (apply 'make-pathname (append @@ -1911,12 +1990,14 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." ;; see also "valid physical pathname host" in the CLHS glossary, that suggests ;; strings and lists of strings or :unspecific ;; But CMUCL decides to die on NIL. + ;; MCL has issues with make-pathname, nil and defaulting + (declare (ignorable defaults)) #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil :host (or #+cmu lisp::*unix-host*) #+scl ,@'(:scheme nil :scheme-specific-part nil :username nil :password nil :parameters nil :query nil :fragment nil) ;; the default shouldn't matter, but we really want something physical - :defaults defaults)) + #-mcl ,@'(:defaults defaults))) (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname)))) @@ -2184,7 +2265,7 @@ to throw an error if the pathname is absolute" (make-pathname* :directory (unless file-only (cons relative path)) :name name :type type - :defaults (or defaults *nil-pathname*)) + :defaults (or #-mcl defaults *nil-pathname*)) (remove-plist-keys '(:type :dot-dot :defaults) keys)))))) (defun unix-namestring (pathname) @@ -2391,20 +2472,27 @@ 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 -(asdf/package:define-package :asdf/filesystem - (:recycle :asdf/pathname :asdf) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname) +(uiop/package:define-package :uiop/filesystem + (:nicknames :asdf/filesystem) + (:recycle :uiop/filesystem :asdf/pathname :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname) (:export ;; Native namestrings #:native-namestring #:parse-native-namestring ;; Probing the filesystem - #:truename* #:safe-file-write-date #:probe-file* + #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories #:collect-sub*directories ;; Resolving symlinks somewhat @@ -2419,8 +2507,8 @@ 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)) -(in-package :asdf/filesystem) + #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree)) +(in-package :uiop/filesystem) ;;; Native namestrings, as seen by the operating system calls rather than Lisp (with-upgradability () @@ -2484,52 +2572,61 @@ or the original (parsed) pathname if it is false (the default)." (null nil) (string (probe-file* (parse-namestring p) :truename truename)) (pathname - (handler-case - (or - #+allegro - (probe-file p :follow-symlinks truename) - #-(or allegro clisp gcl2.6) - (if truename - (probe-file p) - (and (not (wild-pathname-p p)) + (and (not (wild-pathname-p p)) + (handler-case + (or + #+allegro + (probe-file p :follow-symlinks truename) + #-(or allegro clisp gcl2.6) + (if truename + (probe-file p) (ignore-errors (let ((pp (translate-logical-pathname p))) - #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) - #+(and lispworks unix) (system:get-file-stat pp) - #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) - #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp))) - p)) - #+(or clisp gcl2.6) - #.(flet ((probe (probe) - `(let ((foundtrue ,probe)) - (cond - (truename foundtrue) - (foundtrue p))))) - #+gcl2.6 - (probe '(or (probe-file p) - (and (directory-pathname-p p) - (ignore-errors - (ensure-directory-pathname - (truename* (subpathname - (ensure-directory-pathname p) "."))))))) - #+clisp - (let* ((fs (find-symbol* '#:file-stat :posix nil)) - (pp (find-symbol* '#:probe-pathname :ext nil)) - (resolve (if pp - `(ignore-errors (,pp p)) - '(or (truename* p) - (truename* (ignore-errors (ensure-directory-pathname p))))))) - (if fs - `(if truename - ,resolve - (and (ignore-errors (,fs p)) p)) - (probe resolve))))) - (file-error () nil)))))) + (and + #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) + #+(and lispworks unix) (system:get-file-stat pp) + #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) + #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp) + p)))) + #+(or clisp gcl2.6) + #.(flet ((probe (probe) + `(let ((foundtrue ,probe)) + (cond + (truename foundtrue) + (foundtrue p))))) + #+gcl2.6 + (probe '(or (probe-file p) + (and (directory-pathname-p p) + (ignore-errors + (ensure-directory-pathname + (truename* (subpathname + (ensure-directory-pathname p) "."))))))) + #+clisp + (let* ((fs (find-symbol* '#:file-stat :posix nil)) + (pp (find-symbol* '#:probe-pathname :ext nil)) + (resolve (if pp + `(ignore-errors (,pp p)) + '(or (truename* p) + (truename* (ignore-errors (ensure-directory-pathname p))))))) + (if fs + `(if truename + ,resolve + (and (ignore-errors (,fs p)) p)) + (probe resolve))))) + (file-error () nil))))))) + + (defun directory-exists-p (x) + (let ((p (probe-file* x :truename t))) + (and (directory-pathname-p p) p))) + + (defun file-exists-p (x) + (let ((p (probe-file* x :truename t))) + (and (file-pathname-p p) p))) (defun directory* (pathname-spec &rest keys &key &allow-other-keys) (apply 'directory pathname-spec (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) - #+clozure '(:follow-links nil) + #+(or clozure digitool) '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) #+(or cmu scl) '(:follow-links nil :truenamep nil) #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) @@ -2564,7 +2661,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) @@ -2611,10 +2712,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 @@ -2752,7 +2853,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) @@ -2812,8 +2914,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)) @@ -2858,7 +2962,8 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (with-upgradability () (defun ensure-all-directories-exist (pathnames) (dolist (pathname pathnames) - (ensure-directories-exist (translate-logical-pathname pathname)))) + (when pathname + (ensure-directories-exist (translate-logical-pathname pathname))))) (defun rename-file-overwriting-target (source target) #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic @@ -2868,26 +2973,103 @@ 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 "~@" + directory-pathname (unix:get-unix-error-msg errno)))) + #+cormanlisp (win32:delete-directory directory-pathname) + #+ecl (si:rmdir directory-pathname) + #+lispworks (lw:delete-directory directory-pathname) + #+mkcl (mkcl:rmdir directory-pathname) + #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) + `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later + `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) + #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl) + (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera xcl + + (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) + "Delete a directory including all its recursive contents, aka rm -rf. + +To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be +a physical non-wildcard directory pathname (not namestring). + +If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens: +if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done. + +Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass +the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument +which in practice is thus compulsory, and validates by returning a non-NIL result. +If you're suicidal or extremely confident, just use :VALIDATE T." + (check-type if-does-not-exist (member :error :ignore)) + (cond + ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname) + (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname)))) + (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname" + 'delete-filesystem-tree directory-pathname)) + ((not validatep) + (error "~S was asked to delete ~S but was not provided a validation predicate" + 'delete-filesystem-tree directory-pathname)) + ((not (call-function validate directory-pathname)) + (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]" + 'delete-filesystem-tree directory-pathname validate)) + ((not (directory-exists-p directory-pathname)) + (ecase if-does-not-exist + (:error + (error "~S was asked to delete ~S but the directory does not exist" + 'delete-filesystem-tree directory-pathname)) + (:ignore nil))) + #-(or allegro cmu clozure sbcl scl) + ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, + ;; except on implementations where we can prevent DIRECTORY from following symlinks; + ;; instead spawn a standard external program to do the dirty work. + (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname)))) + (t + ;; On supported implementation, call supported system functions + #+allegro (symbol-call :excl.osi :delete-directory-and-files + directory-pathname :if-does-not-exist if-does-not-exist) + #+clozure (ccl:delete-directory directory-pathname) + #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type)) + #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) + `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later + '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) + ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks, + ;; do things the hard way. + #-(or allegro clozure genera sbcl) + (let ((sub*directories + (while-collecting (c) + (collect-sub*directories directory-pathname t t #'c)))) + (dolist (d (nreverse sub*directories)) + (map () 'delete-file (directory-files d)) + (delete-empty-directory d))))))) ;;;; --------------------------------------------------------------------------- ;;;; Utilities related to streams -(asdf/package:define-package :asdf/stream - (:recycle :asdf/stream) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname :asdf/filesystem) +(uiop/package:define-package :uiop/stream + (:nicknames :asdf/stream) + (:recycle :uiop/stream :asdf/stream :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem) (:export #:*default-stream-element-type* #:*stderr* #:setup-stderr #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format #:*default-encoding* #:*utf-8-external-format* - #:with-safe-io-syntax #:call-with-safe-io-syntax + #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string #:with-output #:output-string #:with-input - #:with-input-file #:call-with-input-file + #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file #:finish-outputs #:format! #:safe-format! - #:copy-stream-to-stream #:concatenate-files - #:copy-stream-to-stream-line-by-line + #:copy-stream-to-stream #:concatenate-files #:copy-file #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line #:slurp-stream-forms #:slurp-stream-form #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form @@ -2898,7 +3080,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." #:call-with-temporary-file #:with-temporary-file #:add-pathname-suffix #:tmpize-pathname #:call-with-staging-pathname #:with-staging-pathname)) -(in-package :asdf/stream) +(in-package :uiop/stream) (with-upgradability () (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default) @@ -2917,10 +3099,16 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." ;;; Encodings (mostly hooks only; full support requires asdf-encodings) (with-upgradability () - (defvar *default-encoding* :default + (defparameter *default-encoding* + ;; preserve explicit user changes to something other than the legacy default :default + (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*))) + (unless (eq previous :default) previous)) + :utf-8) "Default encoding for source files. -The default value :default preserves the legacy behavior. -A future default might be :utf-8 or :autodetect +The default value :utf-8 is the portable thing. +The legacy behavior was :default. +If you (asdf:load-system :asdf-encodings) then +you will have autodetection via *encoding-detection-hook* below, reading emacs-style -*- coding: utf-8 -*- specifications, and falling back to utf-8 or latin1 if nothing is specified.") @@ -2961,7 +3149,7 @@ hopefully, if done consistently, that won't affect program behavior too much.") and implementation-defined external-format's") (defun encoding-external-format (encoding) - (funcall *encoding-external-format-hook* encoding))) + (funcall *encoding-external-format-hook* (or encoding *default-encoding*)))) ;;; Safe syntax @@ -2978,7 +3166,11 @@ and implementation-defined external-format's") (*read-default-float-format* 'double-float) (*print-readably* nil) (*read-eval* nil)) - (funcall thunk))))) + (funcall thunk)))) + + (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace) + (with-safe-io-syntax (:package package) + (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace)))) ;;; Output to a stream or string, FORMAT-style @@ -3049,10 +3241,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 () @@ -3109,6 +3324,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) @@ -3259,7 +3478,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 @@ -3328,14 +3547,15 @@ For the latter case, we ought pick random suffix and atomically open it." ;;;; ------------------------------------------------------------------------- ;;;; Starting, Stopping, Dumping a Lisp image -(asdf/package:define-package :asdf/image - (:recycle :asdf/image :xcvb-driver) - (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream :asdf/os) +(uiop/package:define-package :uiop/image + (:nicknames :asdf/image) + (:recycle :uiop/image :asdf/image :xcvb-driver) + (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) (:export #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:*lisp-interaction* - #:fatal-conditions #:fatal-condition-p #:handle-fatal-condition + #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition #:call-with-fatal-condition-handler #:with-fatal-condition-handler #:*image-restore-hook* #:*image-prelude* #:*image-entry-point* #:*image-postlude* #:*image-dump-hook* @@ -3343,9 +3563,9 @@ For the latter case, we ought pick random suffix and atomically open it." #:shell-boolean-exit #:register-image-restore-hook #:register-image-dump-hook #:call-image-restore-hook #:call-image-dump-hook - #:initialize-asdf-utilities #:restore-image #:dump-image #:create-image + #:restore-image #:dump-image #:create-image )) -(in-package :asdf/image) +(in-package :uiop/image) (with-upgradability () (defvar *lisp-interaction* t @@ -3360,6 +3580,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.") @@ -3396,7 +3619,7 @@ This is designed to abstract away the implementation specific quit forms." #+gcl (lisp:quit code) #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) - #+mcl (ccl:quit) ;; or should we use FFI to call libc's exit(3) ? + #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ? #+mkcl (mk-ext:quit :exit-code code) #+sbcl #.(let ((exit (find-symbol* :exit :sb-ext nil)) (quit (find-symbol* :quit :sb-ext nil))) @@ -3410,9 +3633,7 @@ This is designed to abstract away the implementation specific quit forms." "Die in error with some error message" (with-safe-io-syntax () (ignore-errors - (fresh-line *stderr*) - (apply #'format *stderr* format arguments) - (format! *stderr* "~&"))) + (format! *stderr* "~&~?~&" format arguments))) (quit code)) (defun raw-print-backtrace (&key (stream *debug-io*) count) @@ -3434,9 +3655,10 @@ This is designed to abstract away the implementation specific quit forms." (system::print-backtrace :out stream :limit count) #+(or clozure mcl) (let ((*debug-io* stream)) - (ccl:print-call-history :count count :start-frame-number 1) + #+clozure (ccl:print-call-history :count count :start-frame-number 1) + #+mcl (ccl:print-call-history :detailed-p nil) (finish-output stream)) - #+(or cmucl scl) + #+(or cmu scl) (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) (debug:backtrace most-positive-fixnum stream)) @@ -3525,11 +3747,11 @@ This is designed to abstract away the implementation specific quit forms." #+(or cmu scl) extensions:*command-line-strings* #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) #+gcl si:*command-args* - #+genera nil + #+(or genera mcl) nil #+lispworks sys:*line-arguments-list* #+sbcl sb-ext:*posix-argv* #+xcl system:*argv* - #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl) (error "raw-command-line-arguments not implemented yet")) (defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) @@ -3552,10 +3774,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*) @@ -3568,14 +3797,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.")) @@ -3594,8 +3825,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) @@ -3619,33 +3858,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) + (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 @@ -3656,9 +3898,10 @@ if we are not called from a directly executable image." ;;;; ------------------------------------------------------------------------- ;;;; run-program initially from xcvb-driver. -(asdf/package:define-package :asdf/run-program - (:recycle :asdf/run-program :xcvb-driver) - (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/filesystem :asdf/stream) +(uiop/package:define-package :uiop/run-program + (:nicknames :asdf/run-program) + (:recycle :uiop/run-program :asdf/run-program :xcvb-driver) + (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream) (:export ;;; Escaping the command invocation madness #:easy-sh-character-p #:escape-sh-token #:escape-sh-command @@ -3671,7 +3914,7 @@ if we are not called from a directly executable image." #:subprocess-error #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process )) -(in-package :asdf/run-program) +(in-package :uiop/run-program) ;;;; ----- Escaping strings for the shell ----- @@ -3830,6 +4073,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) @@ -3867,16 +4131,36 @@ 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. -Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor." + +Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0), +unless IGNORE-ERROR-STATUS is specified. + +If OUTPUT is either NIL or :INTERACTIVE, then +return the exit status code of the process that was called. +if it was NIL, the output is discarded; +if it was :INTERACTIVE, the output and the input are inherited from the current process. + +Otherwise, OUTPUT should be a value that is a suitable first argument to +SLURP-INPUT-STREAM. In this case, RUN-PROGRAM will create a temporary stream +for the program output. The program output, in that stream, will be processed +by SLURP-INPUT-STREAM, according to the using OUTPUT as the first argument. +RUN-PROGRAM will return whatever SLURP-INPUT-STREAM returns. E.g., using +:OUTPUT :STRING will have it return the entire output stream as a string. Use +ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor." + + ;; TODO: The current version does not honor :OUTPUT NIL on Allegro. Setting + ;; the :INPUT and :OUTPUT arguments to RUN-SHELL-COMMAND on ACL actually do + ;; what :OUTPUT :INTERACTIVE is advertised to do here. To get the behavior + ;; specified for :OUTPUT NIL, one would have to grab up the process output + ;; into a stream and then throw it on the floor. The consequences of + ;; getting this wrong seemed so much worse than having excess output that it + ;; is not currently implemented. + + ;; TODO: specially recognize :output pathname ? (declare (ignorable ignore-error-status element-type external-format)) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) (error "RUN-PROGRAM not implemented for this Lisp") @@ -3917,8 +4201,9 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process (excl:run-shell-command #+os-unix (coerce (cons (first command) command) 'vector) #+os-windows command - :input interactive :output (or (and pipe :stream) interactive) :wait wait - #+os-windows :show-window #+os-windows (and pipe :hide)) + :input nil + :output (and pipe :stream) :wait wait + #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide)) #+clisp (flet ((run (f &rest args) (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output @@ -3944,9 +4229,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*) @@ -3969,7 +4254,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 @@ -4008,7 +4293,13 @@ 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 nil + :output nil + :error-output :output ; write STDERR to output, too + :wait t + #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide)) #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl) (process-result (run-program command :pipe nil :interactive interactive) nil) #+ecl (ext:system command) @@ -4016,7 +4307,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 () @@ -4045,10 +4336,11 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process ;;;; ------------------------------------------------------------------------- ;;;; Support to build (compile and load) Lisp files -(asdf/package:define-package :asdf/lisp-build - (:recycle :asdf/interface :asdf :asdf/lisp-build) - (:use :asdf/common-lisp :asdf/package :asdf/utility - :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image) +(uiop/package:define-package :uiop/lisp-build + (:nicknames :asdf/lisp-build) + (:recycle :uiop/lisp-build :asdf/lisp-build :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) (:export ;; Variables #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* @@ -4057,21 +4349,24 @@ 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 #:current-lisp-file-pathname #:load-pathname #:lispize-pathname #:compile-file-type #:call-around-hook #:compile-file* #:compile-file-pathname* #:load* #:load-from-string #:combine-fasls) (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) -(in-package :asdf/lisp-build) +(in-package :uiop/lisp-build) (with-upgradability () (defvar *compile-file-warnings-behaviour* @@ -4093,15 +4388,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)))) @@ -4126,7 +4422,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.") @@ -4135,38 +4431,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)))) @@ -4234,12 +4534,15 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (etypecase sexp (symbol (reify-symbol sexp)) ((or number character simple-string pathname) sexp) - (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))))) + (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp)))) + (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list)))))) + (defun unreify-simple-sexp (sexp) (etypecase sexp ((or symbol number character simple-string pathname) sexp) (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) - ((simple-vector 2) (unreify-symbol sexp)))) + ((simple-vector 2) (unreify-symbol sexp)) + ((simple-vector 1) (coerce (mapcar 'unreify-simple-sexp (aref sexp 0)) 'vector)))) #+clozure (progn @@ -4255,17 +4558,29 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (destructuring-bind (&key filename start-pos end-pos source) source-note (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos :source (unreify-source-note source))))) + (defun unsymbolify-function-name (name) + (if-let (setfed (gethash name ccl::%setf-function-name-inverses%)) + `(setf ,setfed) + name)) + (defun symbolify-function-name (name) + (if (and (consp name) (eq (first name) 'setf)) + (let ((setfed (second name))) + (gethash setfed ccl::%setf-function-names%)) + name)) (defun reify-function-name (function-name) - (reify-simple-sexp - (if-let (setfed (gethash function-name ccl::%setf-function-name-inverses%)) - `(setf ,setfed) - function-name))) + (let ((name (or (first function-name) ;; defun: extract the name + (let ((sec (second function-name))) + (or (and (atom sec) sec) ; scoped method: drop scope + (first sec)))))) ; method: keep gf name, drop method specializers + (list name))) (defun unreify-function-name (function-name) - (let ((name (unreify-simple-sexp function-name))) - (if (and (consp name) (eq (first name) 'setf)) - (let ((setfed (second name))) - (gethash setfed ccl::%setf-function-names%)) - name))) + function-name) + (defun nullify-non-literals (sexp) + (typecase sexp + ((or number character simple-string symbol pathname) sexp) + (cons (cons (nullify-non-literals (car sexp)) + (nullify-non-literals (cdr sexp)))) + (t nil))) (defun reify-deferred-warning (deferred-warning) (with-accessors ((warning-type ccl::compiler-warning-warning-type) (args ccl::compiler-warning-args) @@ -4273,8 +4588,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) args - (cons (reify-function-name fun) (reify-simple-sexp formals)))))) + :args (destructuring-bind (fun &rest more) + args + (cons (unsymbolify-function-name fun) + (nullify-non-literals more)))))) (defun unreify-deferred-warning (reified-deferred-warning) (destructuring-bind (&key warning-type function-name source-note args) reified-deferred-warning @@ -4283,8 +4600,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 (unreify-function-name fun) (unreify-simple-sexp formals))))))) + :args (destructuring-bind (fun . more) args + (cons (symbolify-function-name fun) more)))))) #+(or cmu scl) (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit @@ -4330,9 +4647,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when using READ within a WITH-SAFE-IO-SYNTAX, that represents the warnings currently deferred by WITH-COMPILATION-UNIT. One of three functions required for deferred-warnings support in ASDF." #+allegro - (reify-simple-sexp - (list :functions-defined excl::.functions-defined. - :functions-called excl::.functions-called.)) + (list :functions-defined excl::.functions-defined. + :functions-called excl::.functions-called.) #+clozure (mapcar 'reify-deferred-warning (if-let (dw ccl::*outstanding-deferred-warnings*) @@ -4374,7 +4690,7 @@ One of three functions required for deferred-warnings support in ASDF." (declare (ignorable reified-deferred-warnings)) #+allegro (destructuring-bind (&key functions-defined functions-called) - (unreify-simple-sexp reified-deferred-warnings) + reified-deferred-warnings (setf excl::.functions-defined. (append functions-defined excl::.functions-defined.) excl::.functions-called. @@ -4481,9 +4797,15 @@ possibly in a different process." ((:clozure :ccl) "ccl-warnings") ((:scl) "scl-warnings"))) - (defvar *warnings-file-type* (warnings-file-type) + (defvar *warnings-file-type* nil "Type for warnings files") + (defun enable-deferred-warnings-check () + (setf *warnings-file-type* (warnings-file-type))) + + (defun disable-deferred-warnings-check () + (setf *warnings-file-type* nil)) + (defun warnings-file-p (file &optional implementation-type) (if-let (type (if implementation-type (warnings-file-type implementation-type) @@ -4505,7 +4827,7 @@ possibly in a different process." (unreify-deferred-warnings (handler-case (safe-read-file-form file) (error (c) - (delete-file-if-exists file) + ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging (push c file-errors) nil)))))) (dolist (error file-errors) (error error)) @@ -4583,7 +4905,7 @@ possibly in a different process. Otherwise just run the BODY." (defun* (compile-file*) (input-file &rest keys &key compile-check output-file warnings-file - #+clisp lib-file #+(or ecl mkcl) object-file + #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl &allow-other-keys) "This function provides a portable wrapper around COMPILE-FILE. It ensures that the OUTPUT-FILE value is only returned and @@ -4624,12 +4946,23 @@ it will filter them appropriately." (or object-file (compile-file-pathname output-file :fasl-p nil))) (tmp-file (tmpize-pathname output-file)) + #+sbcl + (cfasl-file (etypecase emit-cfasl + (null nil) + ((eql t) (make-pathname :type "cfasl" :defaults output-file)) + (string (parse-namestring emit-cfasl)) + (pathname emit-cfasl))) + #+sbcl + (tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file))) #+clisp (tmp-lib (make-pathname :type "lib" :defaults tmp-file))) (multiple-value-bind (output-truename warnings-p failure-p) (with-saved-deferred-warnings (warnings-file) (with-muffled-compiler-conditions () - (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords) + (or #-(or ecl mkcl) + (apply 'compile-file input-file :output-file tmp-file + #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) + #-sbcl keywords) #+ecl (apply 'compile-file input-file :output-file (if object-file (list* object-file :system-p t keywords) @@ -4654,11 +4987,14 @@ it will filter them appropriately." (delete-file-if-exists output-file) (when output-truename #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file)) + #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file)) (rename-file-overwriting-target output-truename output-file) (setf output-truename (truename output-file))) #+clisp (delete-file-if-exists tmp-lib)) (t ;; error or failed check (delete-file-if-exists output-truename) + #+clisp (delete-file-if-exists tmp-lib) + #+sbcl (delete-file-if-exists tmp-cfasl) (setf output-truename nil))) (values output-truename warnings-p failure-p)))) @@ -4685,11 +5021,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 @@ -4698,9 +5035,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)) @@ -4714,10 +5050,11 @@ it will filter them appropriately." ;;;; --------------------------------------------------------------------------- ;;;; Generic support for configuration files -(asdf/package:define-package :asdf/configuration - (:recycle :asdf/configuration :asdf) - (:use :asdf/common-lisp :asdf/utility - :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image) +(uiop/package:define-package :uiop/configuration + (:nicknames :asdf/configuration) + (:recycle :uiop/configuration :asdf/configuration :asdf) + (:use :uiop/common-lisp :uiop/utility + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) (:export #:get-folder-path #:user-configuration-directories #:system-configuration-directories @@ -4725,11 +5062,11 @@ 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)) -(in-package :asdf/configuration) +(in-package :uiop/configuration) (with-upgradability () (define-condition invalid-configuration () @@ -4943,7 +5280,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))) @@ -5011,17 +5349,18 @@ directive.") ;;;; ------------------------------------------------------------------------- ;;; Hacks for backward-compatibility of the driver -(asdf/package:define-package :asdf/backward-driver - (:recycle :asdf/backward-driver :asdf) - (:use :asdf/common-lisp :asdf/package :asdf/utility - :asdf/pathname :asdf/stream :asdf/os :asdf/image - :asdf/run-program :asdf/lisp-build - :asdf/configuration) +(uiop/package:define-package :uiop/backward-driver + (:nicknames :asdf/backward-driver) + (:recycle :uiop/backward-driver :asdf/backward-driver :asdf) + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/pathname :uiop/stream :uiop/os :uiop/image + :uiop/run-program :uiop/lisp-build + :uiop/configuration) (:export #:coerce-pathname #:component-name-to-pathname-components #+(or ecl mkcl) #:compile-file-keeping-object )) -(in-package :asdf/backward-driver) +(in-package :uiop/backward-driver) ;;;; Backward compatibility with various pathname functions. @@ -5051,19 +5390,19 @@ directive.") ;;;; --------------------------------------------------------------------------- ;;;; Re-export all the functionality in asdf/driver -(asdf/package:define-package :asdf/driver - (:nicknames :asdf-driver :asdf-utils) - (:use :asdf/common-lisp :asdf/package :asdf/utility - :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image - :asdf/run-program :asdf/lisp-build - :asdf/configuration :asdf/backward-driver) +(uiop/package:define-package :uiop/driver + (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils) + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image + :uiop/run-program :uiop/lisp-build + :uiop/configuration :uiop/backward-driver) (:reexport ;; NB: excluding asdf/common-lisp ;; which include all of CL with compatibility modifications on select platforms. - :asdf/package :asdf/utility - :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image - :asdf/run-program :asdf/lisp-build - :asdf/configuration :asdf/backward-driver)) + :uiop/package :uiop/utility + :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image + :uiop/run-program :uiop/lisp-build + :uiop/configuration :uiop/backward-driver)) ;;;; ------------------------------------------------------------------------- ;;;; Handle upgrade as forward- and backward-compatibly as possible ;; See https://bugs.launchpad.net/asdf/+bug/485687 @@ -5118,7 +5457,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.29") + (asdf-version "3.0.2") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -5135,8 +5474,8 @@ 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 - #:traverse ;; plan + #:component-depends-on #:operation-done-p #:component-depends-on + #:traverse ;; backward-interface #:operate ;; operate #:parse-component-form ;; defsystem #:apply-output-translations ;; output-translations @@ -5149,15 +5488,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 @@ -5185,16 +5526,11 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO (unless (equal old-version new-version) (push new-version *previous-asdf-versions*) (when old-version - (cond - ((version-compatible-p new-version old-version) - (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") - old-version new-version)) - ((version-compatible-p old-version new-version) - (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") - old-version new-version)) - (t - (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") - old-version new-version))) + (if (version<= new-version old-version) + (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) (call-functions (reverse *post-upgrade-cleanup-hook*)) t)))) @@ -5203,7 +5539,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO We need do that before we operate on anything that may possibly depend on ASDF." (let ((*load-print* nil) (*compile-print* nil)) - (handler-bind (((or style-warning warning) #'muffle-warning)) + (handler-bind (((or style-warning) #'muffle-warning)) (symbol-call :asdf :load-system :asdf :verbose nil)))) (register-hook-function '*post-upgrade-cleanup-hook* 'upgrade-configuration)) @@ -5222,8 +5558,9 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO #:file-component #:source-file #:c-source-file #:java-source-file #:static-file #:doc-file #:html-file - #:source-file-type ;; backward-compatibility - #:component-in-order-to #:component-sibling-dependencies + #:file-type + #:source-file-type #:source-file-explicit-type ;; backward-compatibility + #:component-in-order-to #:component-sideway-dependencies #:component-if-feature #:around-compile-hook #:component-description #:component-long-description #:component-version #:version-satisfies @@ -5242,7 +5579,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) @@ -5286,7 +5623,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. @@ -5353,7 +5690,8 @@ another pathname in a degenerate way.")) (defclass file-component (child-component) ((type :accessor file-type :initarg :type))) ; no default (defclass source-file (file-component) - ((type :initform nil))) ;; NB: many systems have come to rely on this default. + ((type :accessor source-file-explicit-type ;; backward-compatibility + :initform nil))) ;; NB: many systems have come to rely on this default. (defclass c-source-file (source-file) ((type :initform "c"))) (defclass java-source-file (source-file) @@ -5480,7 +5818,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) @@ -5630,13 +5968,13 @@ in which the system specification (.asd file) is located." (setf (gethash key *asdf-cache*) value-list) value-list))) - (defun consult-asdf-cache (key thunk) + (defun consult-asdf-cache (key &optional thunk) (if *asdf-cache* (multiple-value-bind (results foundp) (gethash key *asdf-cache*) (if foundp (apply 'values results) - (set-asdf-cache-entry key (multiple-value-list (funcall thunk))))) - (funcall thunk))) + (set-asdf-cache-entry key (multiple-value-list (call-function thunk))))) + (call-function thunk))) (defmacro do-asdf-cache (key &body body) `(consult-asdf-cache ,key #'(lambda () ,@body))) @@ -5669,7 +6007,7 @@ in which the system specification (.asd file) is located." :asdf/component :asdf/system :asdf/cache) (:export #:remove-entry-from-registry #:coerce-entry-to-directory - #:coerce-name #:primary-system-name + #:coerce-name #:primary-system-name #:coerce-filename #:find-system #:locate-system #:load-asd #:with-system-definitions #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems #:system-definition-error #:missing-component #:missing-requires #:missing-parent @@ -5679,7 +6017,7 @@ in which the system specification (.asd file) is located." #:*central-registry* #:probe-asd #:sysdef-central-registry-search #:find-system-if-being-defined #:*systems-being-defined* #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed - #:system-find-preloaded-system #:register-preloaded-system #:*preloaded-systems* + #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* #:clear-defined-systems #:*defined-systems* ;; defined in source-registry, but specially mentioned here: #:initialize-source-registry #:sysdef-source-registry-search)) @@ -5731,6 +6069,9 @@ in which the system specification (.asd file) is located." ;; the first of the slash-separated components. (first (split-string (coerce-name name) :separator "/"))) + (defun coerce-filename (name) + (frob-substrings (coerce-name name) '("/" ":" "\\") "--")) + (defvar *defined-systems* (make-hash-table :test 'equal) "This is a hash table whose keys are strings, being the names of the systems, and whose values are pairs, the first @@ -5762,6 +6103,7 @@ of which is a system object.") (setf *defined-systems* (make-hash-table :test 'equal)) (when asdf (setf (component-version asdf) *asdf-version*) + (setf (builtin-system-p asdf) t) (register-system asdf))) (values)) @@ -5801,7 +6143,7 @@ called with an object of type asdf:system." (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) '(sysdef-central-registry-search sysdef-source-registry-search - sysdef-find-preloaded-systems))))) + sysdef-preloaded-system-search))))) (cleanup-system-definition-search-functions) (defun search-for-system-definition (system) @@ -5893,6 +6235,25 @@ Going forward, we recommend new users should be using the source-registry. (list new) (subseq *central-registry* (1+ position)))))))))) + (defvar *preloaded-systems* (make-hash-table :test 'equal)) + + (defun make-preloaded-system (name keys) + (apply 'make-instance (getf keys :class 'system) + :name name :source-file (getf keys :source-file) + (remove-plist-keys '(:class :name :source-file) keys))) + + (defun sysdef-preloaded-system-search (requested) + (let ((name (coerce-name requested))) + (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) + (when foundp + (make-preloaded-system name keys))))) + + (defun register-preloaded-system (system-name &rest keys) + (setf (gethash (coerce-name system-name) *preloaded-systems*) keys)) + + (register-preloaded-system "asdf" :version *asdf-version*) + (register-preloaded-system "asdf-driver" :version *asdf-version*) + (defmethod find-system ((name null) &optional (error-p t)) (declare (ignorable name)) (when error-p @@ -5914,14 +6275,26 @@ Going forward, we recommend new users should be using the source-registry. (let ((*systems-being-defined* (make-hash-table :test 'equal))) (call-with-asdf-cache thunk)))) + (defun clear-systems-being-defined () + (when *systems-being-defined* + (clrhash *systems-being-defined*))) + + (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined) + (defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () ,@body))) - (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname)))) + (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) ;; Tries to load system definition with canonical NAME from PATHNAME. (with-system-definitions () (with-standard-io-syntax (let ((*package* (find-package :asdf-user)) + ;; Note that our backward-compatible *readtable* is + ;; a global readtable that gets globally side-effected. Ouch. + ;; Same for the *print-pprint-dispatch* table. + ;; We should do something about that for ASDF3 if possible, or else ASDF4. + (*readtable* readtable) + (*print-pprint-dispatch* print-pprint-dispatch) (*print-readably* nil) (*default-pathname-defaults* ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. @@ -5936,6 +6309,46 @@ Going forward, we recommend new users should be using the source-registry. (with-muffled-loader-conditions () (load* pathname :external-format external-format))))))) + (defvar *old-asdf-systems* (make-hash-table :test 'equal)) + + (defun check-not-old-asdf-system (name pathname) + (or (not (equal name "asdf")) + (null pathname) + (let* ((version-pathname (subpathname pathname "version.lisp-expr")) + (version (and (probe-file* version-pathname :truename nil) + (read-file-form version-pathname))) + (old-version (asdf-version))) + (or (version<= old-version version) + (let ((old-pathname + (if-let (pair (system-registered-p "asdf")) + (system-source-file (cdr pair)))) + (key (list pathname old-version))) + (unless (gethash key *old-asdf-systems*) + (setf (gethash key *old-asdf-systems*) t) + (warn "~@<~ + You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ + or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ + ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ + Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~ + and having an old version registered is a configuration error. ~ + ASDF will ignore this configured system rather than downgrade itself. ~ + In the future, you may want to either: ~ + (a) upgrade this configured ASDF to a newer version, ~ + (b) install a newer ASDF and register it in front of the former in your configuration, or ~ + (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~ + Note that the older ASDF might be registered implicitly through configuration inherited ~ + from your system installation, in which case you might have to specify ~ + :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~ + or other source-registry configuration file, environment variable or lisp parameter. ~ + Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~ + that you might want to upgrade (if a recent enough version is available) ~ + or else remove altogether (since most implementations ship with a recent asdf); ~ + if you lack the system administration rights to upgrade or remove this package, ~ + then you might indeed want to either install and register a more recent version, ~ + or use :ignore-inherited-configuration to avoid registering the old one. ~ + Please consult ASDF documentation and/or experts.~@:>~%" + old-version old-pathname version pathname))))))) + (defun locate-system (name) "Given a system NAME designator, try to locate where to load the system from. Returns five values: FOUNDP FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME @@ -5953,12 +6366,20 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (previous-time (car in-memory)) (found (search-for-system-definition name)) (found-system (and (typep found 'system) found)) - (pathname (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous)))) - (pathname (ensure-pathname (resolve-symlinks* pathname) :want-absolute t)) + (pathname (ensure-pathname + (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))) + :want-absolute t :resolve-symlinks *resolve-symlinks*)) (foundp (and (or found-system pathname previous) t))) (check-type found (or null pathname system)) + (unless (check-not-old-asdf-system name pathname) + (cond + (previous (setf found nil pathname nil)) + (t + (setf found (sysdef-preloaded-system-search "asdf")) + (assert (typep found 'system)) + (setf found-system found pathname nil)))) (values foundp found-system pathname previous previous-time))) (defmethod find-system ((name string) &optional (error-p t)) @@ -5984,7 +6405,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (translate-logical-pathname pathname) (translate-logical-pathname previous-pathname)))) (stamp<= stamp previous-time)))))) - ;; only load when it's a pathname that is different or has newer content + ;; only load when it's a pathname that is different or has newer content, and not an old asdf (load-asd pathname :name name))) (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed (return @@ -5998,21 +6419,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (reinitialize-source-registry-and-retry () :report (lambda (s) (format s (compatfmt "~@") name)) - (initialize-source-registry)))))) - - (defvar *preloaded-systems* (make-hash-table :test 'equal)) - - (defun sysdef-find-preloaded-systems (requested) - (let ((name (coerce-name requested))) - (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*) - (when foundp - (apply 'make-instance 'system :name name :source-file (getf keys :source-file) keys))))) - - (defun register-preloaded-system (system-name &rest keys) - (setf (gethash (coerce-name system-name) *preloaded-systems*) keys)) - - (register-preloaded-system "asdf" :version *asdf-version*) - (register-preloaded-system "asdf-driver" :version *asdf-version*)) + (initialize-source-registry))))))) ;;;; ------------------------------------------------------------------------- ;;;; Finding components @@ -6148,15 +6555,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ;;;; Operations (asdf/package:define-package :asdf/operation - (:recycle :asdf/operation :asdf) + (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) (:export #:operation - #:operation-original-initargs ;; backward-compatibility only. DO NOT USE. + #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE. #:build-op ;; THE generic operation - #:*operations* - #:make-operation - #:find-operation)) + #:*operations* #:make-operation #:find-operation #:feature)) (in-package :asdf/operation) ;;; Operation Classes @@ -6198,7 +6603,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (declare (ignorable context)) spec) (defmethod find-operation (context (spec symbol)) - (apply 'make-operation spec (operation-original-initargs context))) + (unless (member spec '(nil feature)) + ;; NIL designates itself, i.e. absence of operation + ;; FEATURE is the ASDF1 misfeature that comes with IF-COMPONENT-DEP-FAILS + (apply 'make-operation spec (operation-original-initargs context)))) (defmethod operation-original-initargs ((context symbol)) (declare (ignorable context)) nil) @@ -6217,12 +6625,12 @@ 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 - #:perform #:perform-with-restarts #:retry #:accept #:feature + #:perform #:perform-with-restarts #:retry #:accept #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan #:action-path #:find-action #:stamp #:done-p)) (in-package :asdf/action) @@ -6246,17 +6654,26 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ;;;; Convenience methods (with-upgradability () (defmacro define-convenience-action-methods - (function (operation component &optional keyp) - &key if-no-operation if-no-component operation-initargs) + (function formals &key if-no-operation if-no-component operation-initargs) (let* ((rest (gensym "REST")) (found (gensym "FOUND")) + (keyp (equal (last formals) '(&key))) + (formals-no-key (if keyp (butlast formals) formals)) + (len (length formals-no-key)) + (operation 'operation) + (component 'component) + (opix (position operation formals)) + (coix (position component formals)) + (prefix (subseq formals 0 opix)) + (suffix (subseq formals (1+ coix) len)) (more-args (when keyp `(&rest ,rest &key &allow-other-keys)))) + (assert (and (integerp opix) (integerp coix) (= coix (1+ opix)))) (flet ((next-method (o c) (if keyp - `(apply ',function ,o ,c ,rest) - `(,function ,o ,c)))) + `(apply ',function ,@prefix ,o ,c ,@suffix ,rest) + `(,function ,@prefix ,o ,c ,@suffix)))) `(progn - (defmethod ,function ((,operation symbol) ,component ,@more-args) + (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args) (if ,operation ,(next-method (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck. @@ -6264,14 +6681,13 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. `(make-operation ,operation)) `(or (find-component () ,component) ,if-no-component)) ,if-no-operation)) - (defmethod ,function ((,operation operation) ,component ,@more-args) + (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args) (if (typep ,component 'component) (error "No defined method for ~S on ~/asdf-action:format-action/" ',function (cons ,operation ,component)) - (let ((,found (find-component () ,component))) - (if ,found - ,(next-method operation found) - ,if-no-component))))))))) + (if-let (,found (find-component () ,component)) + ,(next-method operation found) + ,if-no-component)))))))) ;;;; self-description @@ -6296,35 +6712,33 @@ 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: - ( *), where is a class - designator and each is a component - designator, which means that the component depends on + ( *), where is an operation designator + with respect to FIND-OPERATION in the context of the OPERATION argument, + and each is a component designator with respect to + FIND-COMPONENT in the context of the COMPONENT argument, + and means that the component depends on having been performed on each ; or (FEATURE ), which means that the component depends - on 's presence in *FEATURES*. + on the expression satisfying FEATUREP. + (This is DEPRECATED -- use :IF-FEATURE instead.) Methods specialized on subclasses of existing component types - should usually append the results of CALL-NEXT-METHOD to the - list.")) - (defgeneric component-self-dependencies (operation component)) + should usually append the results of CALL-NEXT-METHOD to the list.")) (define-convenience-action-methods component-depends-on (operation component)) - (define-convenience-action-methods component-self-dependencies (operation component)) + + (defmethod component-depends-on :around ((o operation) (c component)) + (do-asdf-cache `(component-depends-on ,o ,c) + (call-next-method))) (defmethod component-depends-on ((o operation) (c component)) - (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies + (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies - (defmethod component-self-dependencies ((o operation) (c component)) - ;; NB: result in the same format as component-depends-on - (loop* :for (o-spec . c-spec) :in (component-depends-on o c) - :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature" - :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep))) - :collect (list o-spec c)))) ;;;; upward-operation, downward-operation ;; These together handle actions that propagate along the component hierarchy. @@ -6334,7 +6748,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: @@ -6342,7 +6756,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)) @@ -6351,13 +6765,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)))) @@ -6407,17 +6830,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 @@ -6516,14 +6938,16 @@ in some previous image, or T if it needs to be done.") (:recycle :asdf/lisp-action :asdf) (:intern #:proclamations #:flags) (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action) + :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/find-system + :asdf/operation :asdf/action) (:export #:try-recompiling #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op #:call-with-around-compile-hook - #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:flags)) + #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source + #:lisp-compilation-output-files #:flags)) (in-package :asdf/lisp-action) @@ -6542,22 +6966,27 @@ in some previous image, or T if it needs to be done.") (defclass basic-load-op (operation) ()) (defclass basic-compile-op (operation) ((proclamations :initarg :proclamations :accessor compile-op-proclamations :initform nil) - (flags :initarg :flags :accessor compile-op-flags - :initform nil)))) + (flags :initarg :flags :accessor compile-op-flags :initform nil)))) ;;; Our default operations: loading into the current lisp image (with-upgradability () - (defclass load-op (basic-load-op downward-operation sibling-operation) ()) - (defclass prepare-op (upward-operation sibling-operation) - ((sibling-operation :initform 'load-op :allocation :class))) - (defclass compile-op (basic-compile-op downward-operation) - ((downward-operation :initform 'load-op :allocation :class))) + (defclass prepare-op (upward-operation sideway-operation) + ((sideway-operation :initform 'load-op))) + (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation) + ;; NB: even though compile-op depends on prepare-op it is not needed-in-image-p, + ;; so we need to directly depend on prepare-op for its side-effects in the current image. + ((selfward-operation :initform '(prepare-op compile-op)))) + (defclass compile-op (basic-compile-op downward-operation selfward-operation) + ((selfward-operation :initform 'prepare-op) + (downward-operation :initform 'load-op))) - (defclass load-source-op (basic-load-op downward-operation) ()) - (defclass prepare-source-op (upward-operation sibling-operation) - ((sibling-operation :initform 'load-source-op :allocation :class))) + (defclass prepare-source-op (upward-operation sideway-operation) + ((sideway-operation :initform 'load-source-op))) + (defclass load-source-op (basic-load-op downward-operation selfward-operation) + ((selfward-operation :initform 'prepare-source-op))) - (defclass test-op (operation) ())) + (defclass test-op (selfward-operation) + ((selfward-operation :initform 'load-op)))) ;;;; prepare-op, compile-op and load-op @@ -6617,7 +7046,7 @@ in some previous image, or T if it needs to be done.") "~/asdf-action::format-action/" (list (cons o c)))))) (defun report-file-p (f) - (equal (pathname-type f) "build-report")) + (equalp (pathname-type f) "build-report")) (defun perform-lisp-warnings-check (o c) (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c))) (actual-warnings-files (loop :for w :in expected-warnings-files @@ -6633,8 +7062,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))) @@ -6648,9 +7076,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) @@ -6670,7 +7097,7 @@ in some previous image, or T if it needs to be done.") (defmethod output-files ((o compile-op) (c system)) (when (and *warnings-file-type* (not (builtin-system-p c))) (if-let ((pathname (component-pathname c))) - (list (subpathname pathname (component-name c) :type "build-report")))))) + (list (subpathname pathname (coerce-filename c) :type "build-report")))))) ;;; load-op (with-upgradability () @@ -6700,13 +7127,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 @@ -6734,9 +7155,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 "~@") 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 () @@ -6762,10 +7180,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 @@ -6783,13 +7198,13 @@ in some previous image, or T if it needs to be done.") #:circular-dependency #:circular-dependency-actions #:node-for #:needed-in-image-p #:action-index #:action-planned-p #:action-valid-p - #:plan-record-dependency #:visiting-action-p + #:plan-record-dependency #:normalize-forced-systems #:action-forced-p #:action-forced-not-p #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies #:visit-dependencies #:compute-action-stamp #:traverse-action #:circular-dependency #:circular-dependency-actions #:call-while-visiting-action #:while-visiting-action - #:traverse #:plan-actions #:perform-plan #:plan-operates-on-p + #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p #:planned-p #:index #:forced #:forced-not #:total-action-count #:planned-action-count #:planned-output-action-count #:visited-actions #:visiting-action-set #:visiting-action-list #:plan-actions-r @@ -6941,11 +7356,12 @@ the action of OPERATION on COMPONENT in the PLAN")) (with-upgradability () (defun map-direct-dependencies (operation component fun) (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) - :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature - :do (loop :with dep-o = (find-operation operation dep-o-spec) - :for dep-c-spec :in dep-c-specs - :for dep-c = (resolve-dependency-spec component dep-c-spec) - :do (funcall fun dep-o dep-c)))) + :for dep-o = (find-operation operation dep-o-spec) + :when dep-o + :do (loop :for dep-c-spec :in dep-c-specs + :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec)) + :when dep-c + :do (funcall fun dep-o dep-c)))) (defun reduce-direct-dependencies (operation component combinator seed) (map-direct-dependencies @@ -6974,8 +7390,8 @@ the action of OPERATION on COMPONENT in the PLAN")) (in-files (input-files o c)) ;; Three kinds of actions: (out-op (and out-files t)) ; those that create files on the filesystem - ;(image-op (and in-files (null out-files))) ; those that load stuff into the image - ;(null-op (and (null out-files) (null in-files))) ; dependency placeholders that do nothing + ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image + ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing ;; When was the thing last actually done? (Now, or ask.) (op-time (or just-done (component-operation-time o c))) ;; Accumulated timestamp from dependencies (or T if forced or out-of-date) @@ -7009,9 +7425,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))))) @@ -7094,7 +7510,9 @@ the action of OPERATION on COMPONENT in the PLAN")) :stamp stamp :done-p (and done-p (not add-to-plan-p)) :planned-p add-to-plan-p - :index (if status (action-index status) (incf (plan-total-action-count plan))))) + :index (if status + (action-index status) + (incf (plan-total-action-count plan))))) (when add-to-plan-p (incf (plan-planned-action-count plan)) (unless aniip @@ -7110,6 +7528,8 @@ the action of OPERATION on COMPONENT in the PLAN")) ((actions-r :initform nil :accessor plan-actions-r))) (defgeneric plan-actions (plan)) + (defmethod plan-actions ((plan list)) + plan) (defmethod plan-actions ((plan sequential-plan)) (reverse (plan-actions-r plan))) @@ -7126,37 +7546,39 @@ the action of OPERATION on COMPONENT in the PLAN")) ;;;; high-level interface: traverse, perform-plan, plan-operates-on-p (with-upgradability () - (defgeneric* (traverse) (operation component &key &allow-other-keys) + (defgeneric make-plan (plan-class operation component &key &allow-other-keys) (:documentation - "Generate and return a plan for performing OPERATION on COMPONENT. - -The plan returned is a list of dotted-pairs. Each pair is the CONS -of ASDF operation object and a COMPONENT object. The pairs will be -processed in order by OPERATE.")) - (define-convenience-action-methods traverse (operation component &key)) + "Generate and return a plan for performing OPERATION on COMPONENT.")) + (define-convenience-action-methods make-plan (plan-class operation component &key)) (defgeneric perform-plan (plan &key)) (defgeneric plan-operates-on-p (plan component)) - (defparameter *default-plan-class* 'sequential-plan) + (defvar *default-plan-class* 'sequential-plan) - (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys) + (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) (let ((plan (apply 'make-instance (or plan-class *default-plan-class*) - :system (component-system c) (remove-plist-key :plan-class keys)))) + :system (component-system c) keys))) (traverse-action plan o c t) - (plan-actions plan))) + plan)) - (defmethod perform-plan :around (plan &key) - (declare (ignorable plan)) + (defmethod perform-plan :around ((plan t) &key) (let ((*package* *package*) (*readtable* *readtable*)) (with-compilation-unit () ;; backward-compatibility. (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. - (defmethod perform-plan ((steps list) &key) - (loop* :for (op . component) :in steps :do - (perform-with-restarts op component))) + (defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys) + (apply 'perform-plan (plan-actions plan) keys)) + + (defmethod perform-plan ((steps list) &key force &allow-other-keys) + (loop* :for (o . c) :in steps + :when (or force (not (nth-value 1 (compute-action-stamp nil o c)))) + :do (perform-with-restarts o c))) + + (defmethod plan-operates-on-p ((plan plan-traversal) (component-path list)) + (plan-operates-on-p (plan-actions plan) component-path)) (defmethod plan-operates-on-p ((plan list) (component-path list)) (find component-path (mapcar 'cdr plan) @@ -7187,11 +7609,10 @@ processed in order by OPERATE.")) (defmethod traverse-actions (actions &rest keys &key plan-class &allow-other-keys) (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys))) - (loop* :for (o . c) :in actions :do - (traverse-action plan o c t)) - (plan-actions plan))) + (loop* :for (o . c) :in actions :do (traverse-action plan o c t)) + plan)) - (define-convenience-action-methods traverse-sub-actions (o c &key)) + (define-convenience-action-methods traverse-sub-actions (operation component &key)) (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys) (apply 'traverse-actions (direct-dependencies operation component) :system (component-system component) keys)) @@ -7199,13 +7620,14 @@ processed in order by OPERATE.")) (defmethod plan-actions ((plan filtered-sequential-plan)) (with-slots (keep-operation keep-component) plan (loop* :for (o . c) :in (call-next-method) - :when (and (typep o keep-operation) - (typep c keep-component)) + :when (and (typep o keep-operation) (typep c keep-component)) :collect (cons o c)))) (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) (remove-duplicates - (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys)) + (mapcar 'cdr (plan-actions + (apply 'traverse-sub-actions goal-operation system + (remove-plist-key :goal-operation keys)))) :from-end t))) ;;;; ------------------------------------------------------------------------- @@ -7218,39 +7640,17 @@ processed in order by OPERATE.")) :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) (:export #:operate #:oos - #:*systems-being-operated* #:*asdf-upgrade-already-attempted* + #:*systems-being-operated* #:build-system #:load-system #:load-systems #:compile-system #:test-system #:require-system #:*load-system-operation* #:module-provide-asdf - #:component-loaded-p #:already-loaded-systems - #:upgrade-asdf #:cleanup-upgraded-asdf #:*post-upgrade-hook*)) + #:component-loaded-p #:already-loaded-systems)) (in-package :asdf/operate) (with-upgradability () - (defgeneric* (operate) (operation component &key &allow-other-keys)) - (define-convenience-action-methods - operate (operation component &key) - :operation-initargs t ;; backward-compatibility with ASDF1. Yuck. - :if-no-component (error 'missing-component :requires component)) - - (defvar *systems-being-operated* nil - "A boolean indicating that some systems are being operated on") - - (defmethod operate :around (operation component - &key verbose - (on-warnings *compile-file-warnings-behaviour*) - (on-failure *compile-file-failure-behaviour*) &allow-other-keys) - (declare (ignorable operation component)) - ;; Setup proper bindings around any operate call. - (with-system-definitions () - (let* ((*verbose-out* (and verbose *standard-output*)) - (*compile-file-warnings-behaviour* on-warnings) - (*compile-file-failure-behaviour* on-failure)) - (call-next-method)))) - - (defmethod operate ((operation operation) (component component) - &rest args &key version &allow-other-keys) - "Operate does three things: + (defgeneric* (operate) (operation component &key &allow-other-keys) + (:documentation + "Operate does three things: 1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs. 2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk). @@ -7268,30 +7668,60 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: without recursively forcing the other systems we depend on. :ALL to force all systems including other systems we depend on to be rebuilt (resp. not). (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list -:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced." - (let* (;; I'd like to remove-plist-keys :force :force-not :verbose, - ;; but swank.asd relies on :force (!). - (systems-being-operated *systems-being-operated*) +:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced.")) + + (define-convenience-action-methods + operate (operation component &key) + ;; I'd like to at least remove-plist-keys :force :force-not :verbose, + ;; but swank.asd relies on :force (!). + :operation-initargs t ;; backward-compatibility with ASDF1. Yuck. + :if-no-component (error 'missing-component :requires component)) + + (defvar *systems-being-operated* nil + "A boolean indicating that some systems are being operated on") + + (defmethod operate :around (operation component &rest keys + &key verbose + (on-warnings *compile-file-warnings-behaviour*) + (on-failure *compile-file-failure-behaviour*) &allow-other-keys) + (declare (ignorable operation component)) + (let* ((systems-being-operated *systems-being-operated*) (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))) - (system (component-system component))) - (setf (gethash (coerce-name system) *systems-being-operated*) system) - (unless (version-satisfies component version) - (error 'missing-component-of-version :requires component :version version)) + (operation-name (reify-symbol (etypecase operation + (operation (type-of operation)) + (symbol operation)))) + (component-path (typecase component + (component (component-find-path component)) + (t component)))) ;; Before we operate on any system, make sure ASDF is up-to-date, ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble. (unless systems-being-operated - (let ((operation-name (reify-symbol (type-of operation))) - (component-path (component-find-path component))) - (when (upgrade-asdf) - ;; If we were upgraded, restart OPERATE the hardest of ways, for - ;; its function may have been redefined, its symbol uninterned, its package deleted. - (return-from operate - (apply (find-symbol* 'operate :asdf) - (unreify-symbol operation-name) - component-path args))))) - (let ((plan (apply 'traverse operation system args))) - (perform-plan plan) - (values operation plan)))) + (when (upgrade-asdf) + ;; If we were upgraded, restart OPERATE the hardest of ways, for + ;; its function may have been redefined, its symbol uninterned, its package deleted. + (return-from operate + (apply (find-symbol* 'operate :asdf) + (unreify-symbol operation-name) + component-path keys)))) + ;; Setup proper bindings around any operate call. + (with-system-definitions () + (let* ((*verbose-out* (and verbose *standard-output*)) + (*compile-file-warnings-behaviour* on-warnings) + (*compile-file-failure-behaviour* on-failure)) + (call-next-method))))) + + (defmethod operate :before ((operation operation) (component component) + &key version &allow-other-keys) + (let ((system (component-system component))) + (setf (gethash (coerce-name system) *systems-being-operated*) system)) + (unless (version-satisfies component version) + (error 'missing-component-of-version :requires component :version version))) + + (defmethod operate ((operation operation) (component component) + &rest keys &key plan-class &allow-other-keys) + (let ((plan (apply 'make-plan plan-class operation component keys))) + (apply 'perform-plan plan keys) + (values operation plan))) (defun oos (operation component &rest args &key &allow-other-keys) (apply 'operate operation component args)) @@ -7351,18 +7781,54 @@ for how to load or compile stuff") (defun require-system (s &rest keys &key &allow-other-keys) (apply 'load-system s :force-not (already-loaded-systems) keys)) + (defvar *modules-being-required* nil) + + (defclass require-system (system) + ((module :initarg :module :initform nil :accessor required-module))) + + (defmethod perform ((o compile-op) (c require-system)) + (declare (ignorable o c)) + nil) + + (defmethod perform ((o load-op) (s require-system)) + (declare (ignorable o)) + (let* ((module (or (required-module s) (coerce-name s))) + (*modules-being-required* (cons module *modules-being-required*))) + (assert (null (component-children s))) + (require module))) + + (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments) + (declare (ignorable component combinator)) + (unless (length=n-p arguments 1) + (error (compatfmt "~@") + (cons combinator arguments) component combinator)) + (let* ((module (car arguments)) + (name (string-downcase module)) + (system (find-system name nil))) + (assert module) + ;;(unless (typep system '(or null require-system)) + ;; (warn "~S depends on ~S but ~S is registered as a ~S" + ;; component (cons combinator arguments) module (type-of system))) + (or system (let ((system (make-instance 'require-system :name name))) + (register-system system) + system)))) + (defun module-provide-asdf (name) - (handler-bind - ((style-warning #'muffle-warning) - (missing-component (constantly nil)) - (error #'(lambda (e) - (format *error-output* (compatfmt "~@~%") - name e)))) - (let ((*verbose-out* (make-broadcast-stream)) - (system (find-system (string-downcase name) nil))) - (when system - (require-system system :verbose nil) - t))))) + (let ((module (string-downcase name))) + (unless (member module *modules-being-required* :test 'equal) + (let ((*modules-being-required* (cons module *modules-being-required*)) + #+sbcl (sb-impl::*requiring* (remove module sb-impl::*requiring* :test 'equal))) + (handler-bind + ((style-warning #'muffle-warning) + (missing-component (constantly nil)) + (error #'(lambda (e) + (format *error-output* (compatfmt "~@~%") + name e)))) + (let ((*verbose-out* (make-broadcast-stream))) + (let ((system (find-system module nil))) + (when system + (require-system system :verbose nil) + t))))))))) ;;;; Some upgrade magic @@ -7374,694 +7840,59 @@ for how to load or compile stuff") (clrhash *systems-being-defined*) (dolist (s l) (find-system s nil))))) - (pushnew 'restart-upgraded-asdf *post-upgrade-restart-hook*)) - + (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)) -;;;; --------------------------------------------------------------------------- -;;;; asdf-output-translations -(asdf/package:define-package :asdf/output-translations - (:recycle :asdf/output-translations :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) - (:export - #:*output-translations* #:*output-translations-parameter* - #:invalid-output-translation - #:output-translations #:output-translations-initialized-p - #:initialize-output-translations #:clear-output-translations - #:disable-output-translations #:ensure-output-translations - #:apply-output-translations - #:validate-output-translations-directive #:validate-output-translations-form - #:validate-output-translations-file #:validate-output-translations-directory - #:parse-output-translations-string #:wrapping-output-translations - #:user-output-translations-pathname #:system-output-translations-pathname - #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname - #:environment-output-translations #:process-output-translations - #:compute-output-translations - #+abcl #:translate-jar-pathname - )) -(in-package :asdf/output-translations) +;;;; ------------------------------------------------------------------------- +;;; Internal hacks for backward-compatibility -(when-upgrading () (undefine-function '(setf output-translations))) +(asdf/package:define-package :asdf/backward-internals + (:recycle :asdf/backward-internals :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/system :asdf/component :asdf/operation + :asdf/find-system :asdf/action :asdf/lisp-action) + (:export ;; for internal use + #:load-sysdef #:make-temporary-package + #:%refresh-component-inline-methods + #:%resolve-if-component-dep-fails + #:make-sub-operation + #:load-sysdef #:make-temporary-package)) +(in-package :asdf/backward-internals) +;;;; Backward compatibility with "inline methods" (with-upgradability () - (define-condition invalid-output-translation (invalid-configuration warning) - ((format :initform (compatfmt "~@")))) - - (defvar *output-translations* () - "Either NIL (for uninitialized), or a list of one element, -said element itself being a sorted list of mappings. -Each mapping is a pair of a source pathname and destination pathname, -and the order is by decreasing length of namestring of the source pathname.") + (defparameter +asdf-methods+ + '(perform-with-restarts perform explain output-files operation-done-p)) - (defun output-translations () - (car *output-translations*)) + (defun %remove-component-inline-methods (component) + (dolist (name +asdf-methods+) + (map () + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf + ;; But this is hardly performance-critical + #'(lambda (m) + (remove-method (symbol-function name) m)) + (component-inline-methods component))) + (component-inline-methods component) nil) - (defun set-output-translations (new-value) - (setf *output-translations* - (list - (stable-sort (copy-list new-value) #'> - :key #'(lambda (x) - (etypecase (car x) - ((eql t) -1) - (pathname - (let ((directory (pathname-directory (car x)))) - (if (listp directory) (length directory) 0)))))))) - new-value) - (defsetf output-translations set-output-translations) ; works with gcl 2.6 + (defun %define-component-inline-methods (ret rest) + (loop* :for (key value) :on rest :by #'cddr + :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=)) + :when name :do + (destructuring-bind (op &rest body) value + (loop :for arg = (pop body) + :while (atom arg) + :collect arg :into qualifiers + :finally + (destructuring-bind (o c) arg + (pushnew + (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body)) + (component-inline-methods ret))))))) - (defun output-translations-initialized-p () - (and *output-translations* t)) - - (defun clear-output-translations () - "Undoes any initialization of the output translations." - (setf *output-translations* '()) - (values)) - (register-clear-configuration-hook 'clear-output-translations) - - (defun validate-output-translations-directive (directive) - (or (member directive '(:enable-user-cache :disable-cache nil)) - (and (consp directive) - (or (and (length=n-p directive 2) - (or (and (eq (first directive) :include) - (typep (second directive) '(or string pathname null))) - (and (location-designator-p (first directive)) - (or (location-designator-p (second directive)) - (location-function-p (second directive)))))) - (and (length=n-p directive 1) - (location-designator-p (first directive))))))) - - (defun validate-output-translations-form (form &key location) - (validate-configuration-form - form - :output-translations - 'validate-output-translations-directive - :location location :invalid-form-reporter 'invalid-output-translation)) - - (defun validate-output-translations-file (file) - (validate-configuration-file - file 'validate-output-translations-form :description "output translations")) - - (defun validate-output-translations-directory (directory) - (validate-configuration-directory - directory :output-translations 'validate-output-translations-directive - :invalid-form-reporter 'invalid-output-translation)) - - (defun parse-output-translations-string (string &key location) - (cond - ((or (null string) (equal string "")) - '(:output-translations :inherit-configuration)) - ((not (stringp string)) - (error (compatfmt "~@") 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 "~@") - string)) - (setf inherit t) - (push :inherit-configuration directives)) - (t - (setf source s))) - (setf start (1+ i)) - (when (> start end) - (when source - (error (compatfmt "~@") - string)) - (unless inherit - (push :ignore-inherited-configuration directives)) - (return `(:output-translations ,@(nreverse directives))))))))) - - (defparameter *default-output-translations* - '(environment-output-translations - user-output-translations-pathname - user-output-translations-directory-pathname - system-output-translations-pathname - system-output-translations-directory-pathname)) - - (defun wrapping-output-translations () - `(:output-translations - ;; Some implementations have precompiled ASDF systems, - ;; so we must disable translations for implementation paths. - #+(or #|clozure|# ecl mkcl sbcl) - ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) - (when h `(((,h ,*wild-path*) ())))) - #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) - ;; All-import, here is where we want user stuff to be: - :inherit-configuration - ;; These are for convenience, and can be overridden by the user: - #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) - #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - ;; We enable the user cache by default, and here is the place we do: - :enable-user-cache)) - - (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf")) - (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/")) - - (defun user-output-translations-pathname (&key (direction :input)) - (in-user-configuration-directory *output-translations-file* :direction direction)) - (defun system-output-translations-pathname (&key (direction :input)) - (in-system-configuration-directory *output-translations-file* :direction direction)) - (defun user-output-translations-directory-pathname (&key (direction :input)) - (in-user-configuration-directory *output-translations-directory* :direction direction)) - (defun system-output-translations-directory-pathname (&key (direction :input)) - (in-system-configuration-directory *output-translations-directory* :direction direction)) - (defun environment-output-translations () - (getenv "ASDF_OUTPUT_TRANSLATIONS")) - - (defgeneric process-output-translations (spec &key inherit collect)) - - (defun inherit-output-translations (inherit &key collect) - (when inherit - (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) - - (defun* (process-output-translations-directive) (directive &key inherit collect) - (if (atom directive) - (ecase directive - ((:enable-user-cache) - (process-output-translations-directive '(t :user-cache) :collect collect)) - ((:disable-cache) - (process-output-translations-directive '(t t) :collect collect)) - ((:inherit-configuration) - (inherit-output-translations inherit :collect collect)) - ((:ignore-inherited-configuration :ignore-invalid-entries nil) - nil)) - (let ((src (first directive)) - (dst (second directive))) - (if (eq src :include) - (when dst - (process-output-translations (pathname dst) :inherit nil :collect collect)) - (when src - (let ((trusrc (or (eql src t) - (let ((loc (resolve-location src :ensure-directory t :wilden t))) - (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc))))) - (cond - ((location-function-p dst) - (funcall collect - (list trusrc - (if (symbolp (second dst)) - (fdefinition (second dst)) - (eval (second dst)))))) - ((eq dst t) - (funcall collect (list trusrc t))) - (t - (let* ((trudst (if dst - (resolve-location dst :ensure-directory t :wilden t) - trusrc))) - (funcall collect (list trudst t)) - (funcall collect (list trusrc trudst))))))))))) - - (defmethod process-output-translations ((x symbol) &key - (inherit *default-output-translations*) - collect) - (process-output-translations (funcall x) :inherit inherit :collect collect)) - (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect) - (cond - ((directory-pathname-p pathname) - (process-output-translations (validate-output-translations-directory pathname) - :inherit inherit :collect collect)) - ((probe-file* pathname :truename *resolve-symlinks*) - (process-output-translations (validate-output-translations-file pathname) - :inherit inherit :collect collect)) - (t - (inherit-output-translations inherit :collect collect)))) - (defmethod process-output-translations ((string string) &key inherit collect) - (process-output-translations (parse-output-translations-string string) - :inherit inherit :collect collect)) - (defmethod process-output-translations ((x null) &key inherit collect) - (declare (ignorable x)) - (inherit-output-translations inherit :collect collect)) - (defmethod process-output-translations ((form cons) &key inherit collect) - (dolist (directive (cdr (validate-output-translations-form form))) - (process-output-translations-directive directive :inherit inherit :collect collect))) - - (defun compute-output-translations (&optional parameter) - "read the configuration, return it" - (remove-duplicates - (while-collecting (c) - (inherit-output-translations - `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) - :test 'equal :from-end t)) - - (defvar *output-translations-parameter* nil) - - (defun initialize-output-translations (&optional (parameter *output-translations-parameter*)) - "read the configuration, initialize the internal configuration variable, -return the configuration" - (setf *output-translations-parameter* parameter - (output-translations) (compute-output-translations parameter))) - - (defun disable-output-translations () - "Initialize output translations in a way that maps every file to itself, -effectively disabling the output translation facility." - (initialize-output-translations - '(:output-translations :disable-cache :ignore-inherited-configuration))) - - ;; checks an initial variable to see whether the state is initialized - ;; or cleared. In the former case, return current configuration; in - ;; the latter, initialize. ASDF will call this function at the start - ;; of (asdf:find-system). - (defun ensure-output-translations () - (if (output-translations-initialized-p) - (output-translations) - (initialize-output-translations))) - - (defun* (apply-output-translations) (path) - #+cormanlisp (resolve-symlinks* path) #-cormanlisp - (etypecase path - (logical-pathname - path) - ((or pathname string) - (ensure-output-translations) - (loop* :with p = (resolve-symlinks* path) - :for (source destination) :in (car *output-translations*) - :for root = (when (or (eq source t) - (and (pathnamep source) - (not (absolute-pathname-p source)))) - (pathname-root p)) - :for absolute-source = (cond - ((eq source t) (wilden root)) - (root (merge-pathnames* source root)) - (t source)) - :when (or (eq source t) (pathname-match-p p absolute-source)) - :return (translate-pathname* p absolute-source destination root source) - :finally (return p))))) - - ;; Hook into asdf/driver's output-translation mechanism - (setf *output-translation-function* 'apply-output-translations) - - #+abcl - (defun translate-jar-pathname (source wildcard) - (declare (ignore wildcard)) - (flet ((normalize-device (pathname) - (if (find :windows *features*) - pathname - (make-pathname :defaults pathname :device :unspecific)))) - (let* ((jar - (pathname (first (pathname-device source)))) - (target-root-directory-namestring - (format nil "/___jar___file___root___/~@[~A/~]" - (and (find :windows *features*) - (pathname-device jar)))) - (relative-source - (relativize-pathname-directory source)) - (relative-jar - (relativize-pathname-directory (ensure-directory-pathname jar))) - (target-root-directory - (normalize-device - (pathname-directory-pathname - (parse-namestring target-root-directory-namestring)))) - (target-root - (merge-pathnames* relative-jar target-root-directory)) - (target - (merge-pathnames* relative-source target-root))) - (normalize-device (apply-output-translations target)))))) - -;;;; ----------------------------------------------------------------- -;;;; Source Registry Configuration, by Francois-Rene Rideau -;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 - -(asdf/package:define-package :asdf/source-registry - (:recycle :asdf/source-registry :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system) - (:export - #:*source-registry* #:*source-registry-parameter* #:*default-source-registries* - #:invalid-source-registry - #:source-registry #:source-registry-initialized-p - #:initialize-source-registry #:clear-source-registry #:*source-registry* - #:disable-source-registry #:ensure-source-registry #:*source-registry-parameter* - #:*default-source-registry-exclusions* #:*source-registry-exclusions* - #:*wild-asd* #:directory-asd-files #:register-asd-directory - #:collect-asds-in-directory #:collect-sub*directories-asd-files - #:validate-source-registry-directive #:validate-source-registry-form - #:validate-source-registry-file #:validate-source-registry-directory - #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry - #:user-source-registry #:system-source-registry - #:user-source-registry-directory #:system-source-registry-directory - #:environment-source-registry #:process-source-registry - #:compute-source-registry #:flatten-source-registry - #:sysdef-source-registry-search)) -(in-package :asdf/source-registry) - -(with-upgradability () - (define-condition invalid-source-registry (invalid-configuration warning) - ((format :initform (compatfmt "~@")))) - - ;; 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 "~@") 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 "~@") string)) - dir)) - (cond - ((equal "" s) ; empty element: inherit - (when inherit - (error (compatfmt "~@") - string)) - (setf inherit t) - (push ':inherit-configuration directives)) - ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? - (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) - (t - (push `(:directory ,(check s)) directives)))) - (cond - (pos - (setf start (1+ pos))) - (t - (unless inherit - (push '(:ignore-inherited-configuration) directives)) - (return `(:source-registry ,@(nreverse directives)))))))))) - - (defun register-asd-directory (directory &key recurse exclude collect) - (if (not recurse) - (collect-asds-in-directory directory collect) - (collect-sub*directories-asd-files - directory :exclude exclude :collect collect))) - - (defparameter *default-source-registries* - '(environment-source-registry - user-source-registry - user-source-registry-directory - system-source-registry - system-source-registry-directory - default-source-registry)) - - (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf")) - (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/")) - - (defun wrapping-source-registry () - `(:source-registry - #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) - #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) - :inherit-configuration - #+cmu (:tree #p"modules:") - #+scl (:tree #p"file://modules/"))) - (defun default-source-registry () - `(:source-registry - #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/")) - ,@(loop :for dir :in - `(,@(when (os-unix-p) - `(,(or (getenv-absolute-directory "XDG_DATA_HOME") - (subpathname (user-homedir-pathname) ".local/share/")) - ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") - '("/usr/local/share" "/usr/share")))) - ,@(when (os-windows-p) - (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata)))) - :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) - :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) - :inherit-configuration)) - (defun user-source-registry (&key (direction :input)) - (in-user-configuration-directory *source-registry-file* :direction direction)) - (defun system-source-registry (&key (direction :input)) - (in-system-configuration-directory *source-registry-file* :direction direction)) - (defun user-source-registry-directory (&key (direction :input)) - (in-user-configuration-directory *source-registry-directory* :direction direction)) - (defun system-source-registry-directory (&key (direction :input)) - (in-system-configuration-directory *source-registry-directory* :direction direction)) - (defun environment-source-registry () - (getenv "CL_SOURCE_REGISTRY")) - - (defgeneric* (process-source-registry) (spec &key inherit register)) - - (defun* (inherit-source-registry) (inherit &key register) - (when inherit - (process-source-registry (first inherit) :register register :inherit (rest inherit)))) - - (defun* (process-source-registry-directive) (directive &key inherit register) - (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) - (ecase kw - ((:include) - (destructuring-bind (pathname) rest - (process-source-registry (resolve-location pathname) :inherit nil :register register))) - ((:directory) - (destructuring-bind (pathname) rest - (when pathname - (funcall register (resolve-location pathname :ensure-directory t))))) - ((:tree) - (destructuring-bind (pathname) rest - (when pathname - (funcall register (resolve-location pathname :ensure-directory t) - :recurse t :exclude *source-registry-exclusions*)))) - ((:exclude) - (setf *source-registry-exclusions* rest)) - ((:also-exclude) - (appendf *source-registry-exclusions* rest)) - ((:default-registry) - (inherit-source-registry '(default-source-registry) :register register)) - ((:inherit-configuration) - (inherit-source-registry inherit :register register)) - ((:ignore-inherited-configuration) - nil))) - nil) - - (defmethod process-source-registry ((x symbol) &key inherit register) - (process-source-registry (funcall x) :inherit inherit :register register)) - (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register) - (cond - ((directory-pathname-p pathname) - (let ((*here-directory* (resolve-symlinks* pathname))) - (process-source-registry (validate-source-registry-directory pathname) - :inherit inherit :register register))) - ((probe-file* pathname :truename *resolve-symlinks*) - (let ((*here-directory* (pathname-directory-pathname pathname))) - (process-source-registry (validate-source-registry-file pathname) - :inherit inherit :register register))) - (t - (inherit-source-registry inherit :register register)))) - (defmethod process-source-registry ((string string) &key inherit register) - (process-source-registry (parse-source-registry-string string) - :inherit inherit :register register)) - (defmethod process-source-registry ((x null) &key inherit register) - (declare (ignorable x)) - (inherit-source-registry inherit :register register)) - (defmethod process-source-registry ((form cons) &key inherit register) - (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) - (dolist (directive (cdr (validate-source-registry-form form))) - (process-source-registry-directive directive :inherit inherit :register register)))) - - (defun flatten-source-registry (&optional parameter) - (remove-duplicates - (while-collecting (collect) - (with-pathname-defaults () ;; be location-independent - (inherit-source-registry - `(wrapping-source-registry - ,parameter - ,@*default-source-registries*) - :register #'(lambda (directory &key recurse exclude) - (collect (list directory :recurse recurse :exclude exclude)))))) - :test 'equal :from-end t)) - - ;; Will read the configuration and initialize all internal variables. - (defun compute-source-registry (&optional parameter (registry *source-registry*)) - (dolist (entry (flatten-source-registry parameter)) - (destructuring-bind (directory &key recurse exclude) entry - (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates - (register-asd-directory - directory :recurse recurse :exclude exclude :collect - #'(lambda (asd) - (let* ((name (pathname-name asd)) - (name (if (typep asd 'logical-pathname) - ;; logical pathnames are upper-case, - ;; at least in the CLHS and on SBCL, - ;; yet (coerce-name :foo) is lower-case. - ;; won't work well with (load-system "Foo") - ;; instead of (load-system 'foo) - (string-downcase name) - name))) - (cond - ((gethash name registry) ; already shadowed by something else - nil) - ((gethash name h) ; conflict at current level - (when *verbose-out* - (warn (compatfmt "~@") - directory recurse name (gethash name h) asd))) - (t - (setf (gethash name registry) asd) - (setf (gethash name h) asd)))))) - h))) - (values)) - - (defvar *source-registry-parameter* nil) - - (defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) - ;; Record the parameter used to configure the registry - (setf *source-registry-parameter* parameter) - ;; Clear the previous registry database: - (setf *source-registry* (make-hash-table :test 'equal)) - ;; Do it! - (compute-source-registry parameter)) - - ;; Checks an initial variable to see whether the state is initialized - ;; or cleared. In the former case, return current configuration; in - ;; the latter, initialize. ASDF will call this function at the start - ;; of (asdf:find-system) to make sure the source registry is initialized. - ;; However, it will do so *without* a parameter, at which point it - ;; will be too late to provide a parameter to this function, though - ;; you may override the configuration explicitly by calling - ;; initialize-source-registry directly with your parameter. - (defun ensure-source-registry (&optional parameter) - (unless (source-registry-initialized-p) - (initialize-source-registry parameter)) - (values)) - - (defun sysdef-source-registry-search (system) - (ensure-source-registry) - (values (gethash (primary-system-name system) *source-registry*)))) - - -;;;; ------------------------------------------------------------------------- -;;; Internal hacks for backward-compatibility - -(asdf/package:define-package :asdf/backward-internals - (:recycle :asdf/backward-internals :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/system :asdf/component :asdf/operation - :asdf/find-system :asdf/action :asdf/lisp-action) - (:export ;; for internal use - #:load-sysdef #:make-temporary-package - #:%refresh-component-inline-methods - #:%resolve-if-component-dep-fails - #:make-sub-operation - #:load-sysdef #:make-temporary-package)) -(in-package :asdf/backward-internals) - -;;;; Backward compatibility with "inline methods" -(with-upgradability () - (defparameter +asdf-methods+ - '(perform-with-restarts perform explain output-files operation-done-p)) - - (defun %remove-component-inline-methods (component) - (dolist (name +asdf-methods+) - (map () - ;; this is inefficient as most of the stored - ;; methods will not be for this particular gf - ;; But this is hardly performance-critical - #'(lambda (m) - (remove-method (symbol-function name) m)) - (component-inline-methods component))) - (component-inline-methods component) nil) - - (defun %define-component-inline-methods (ret rest) - (dolist (name +asdf-methods+) - (let ((keyword (intern (symbol-name name) :keyword))) - (loop :for data = rest :then (cddr data) - :for key = (first data) - :for value = (second data) - :while data - :when (eq key keyword) :do - (destructuring-bind (op qual? &rest rest) value - (multiple-value-bind (qual args-and-body) - (if (symbolp qual?) - (values (list qual?) rest) - (values nil (cons qual? rest))) - (destructuring-bind ((o c) &body body) args-and-body - (pushnew - (eval `(defmethod ,name ,@qual ((,o ,op) (,c (eql ,ret))) - ,@body)) - (component-inline-methods ret))))))))) - - (defun %refresh-component-inline-methods (component rest) - ;; clear methods, then add the new ones - (%remove-component-inline-methods component) - (%define-component-inline-methods component rest))) + (defun %refresh-component-inline-methods (component rest) + ;; clear methods, then add the new ones + (%remove-component-inline-methods component) + (%define-component-inline-methods component rest))) ;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute ;; and the companion asdf:feature pseudo-dependency. @@ -8115,7 +7946,8 @@ system names to pathnames of .asd files") #:defsystem #:register-system-definition #:class-for-type #:*default-component-class* #:determine-system-directory #:parse-component-form - #:duplicate-names #:sysdef-error-component #:check-component-input)) + #:duplicate-names #:non-toplevel-system #:non-system-system + #:sysdef-error-component #:check-component-input)) (in-package :asdf/defsystem) ;;; Pathname @@ -8152,8 +7984,9 @@ system names to pathnames of .asd files") (or (loop :for symbol :in (list type (find-symbol* type *package* nil) - (find-symbol* type :asdf/interface nil)) - :for class = (and symbol (find-class* symbol nil)) + (find-symbol* type :asdf/interface nil) + (and (stringp type) (safe-read-from-string type :package :asdf/interface))) + :for class = (and symbol (symbolp symbol) (find-class* symbol nil)) :when (and class (#-cormanlisp subtypep #+cormanlisp cl::subclassp class (find-class* 'component))) @@ -8171,9 +8004,23 @@ system names to pathnames of .asd files") (define-condition duplicate-names (system-definition-error) ((name :initarg :name :reader duplicate-names-name)) (:report (lambda (c s) - (format s (compatfmt "~@") + (format s (compatfmt "~@") (duplicate-names-name c))))) + (define-condition non-system-system (system-definition-error) + ((name :initarg :name :reader non-system-system-name) + (class-name :initarg :class-name :reader non-system-system-class-name)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (non-system-system-name c) (non-system-system-class-name c) 'system)))) + + (define-condition non-toplevel-system (system-definition-error) + ((parent :initarg :parent :reader non-toplevel-system-parent) + (name :initarg :name :reader non-toplevel-system-name)) + (:report (lambda (c s) + (format s (compatfmt "~@") + (non-toplevel-system-parent c) (non-toplevel-system-name c))))) + (defun sysdef-error-component (msg type name value) (sysdef-error (strcat msg (compatfmt "~&~@")) type name value)) @@ -8191,18 +8038,34 @@ system names to pathnames of .asd files") (sysdef-error-component ":components must be NIL or a list of components." type name components))) - (defun normalize-version (form pathname) - (etypecase form - ((or string null) form) - (real - (asdf-message "Invalid use of real number ~D as :version in ~S. Substituting a string." - form pathname) - (format nil "~D" form)) ;; 1.0 is "1.0" - (cons - (ecase (first form) - ((:read-file-form) - (destructuring-bind (subpath &key (at 0)) (rest form) - (safe-read-file-form (subpathname pathname subpath) :at at)))))))) + (defun* (normalize-version) (form &key pathname component parent) + (labels ((invalid (&optional (continuation "using NIL instead")) + (warn (compatfmt "~@") + form component parent pathname continuation)) + (invalid-parse (control &rest args) + (unless (builtin-system-p (find-component parent component)) + (apply 'warn control args) + (invalid)))) + (if-let (v (typecase form + ((or string null) form) + (real + (invalid "Substituting a string") + (format nil "~D" form)) ;; 1.0 becomes "1.0" + (cons + (case (first form) + ((:read-file-form) + (destructuring-bind (subpath &key (at 0)) (rest form) + (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user))) + ((:read-file-line) + (destructuring-bind (subpath &key (at 0)) (rest form) + (read-file-lines (subpathname pathname subpath) :at at))) + (otherwise + (invalid)))) + (t + (invalid)))) + (if-let (pv (parse-version v #'invalid-parse)) + (unparse-version pv) + (invalid)))))) ;;; Main parsing function @@ -8215,7 +8078,7 @@ system names to pathnames of .asd files") ;; remove-plist-keys form. important to keep them in sync components pathname perform explain output-files operation-done-p weakly-depends-on depends-on serial - do-first if-component-dep-fails (version nil versionp) + do-first if-component-dep-fails version ;; list ends &allow-other-keys) options (declare (ignorable perform explain output-files operation-done-p builtin-system-p)) @@ -8227,7 +8090,8 @@ system names to pathnames of .asd files") (class-for-type parent type)))) (error 'duplicate-names :name name)) (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3")) - (let* ((args `(:name ,(coerce-name name) + (let* ((name (coerce-name name)) + (args `(:name ,name :pathname ,pathname ,@(when parent `(:parent ,parent)) ,@(remove-plist-keys @@ -8235,24 +8099,18 @@ system names to pathnames of .asd files") :perform :explain :output-files :operation-done-p :weakly-depends-on :depends-on :serial) rest))) - (component (find-component parent name))) - (when weakly-depends-on - ;; ASDF4: deprecate this feature and remove it. - (appendf depends-on - (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) - (when previous-serial-component - (push previous-serial-component depends-on)) + (component (find-component parent name)) + (class (class-for-type parent type))) + (when (and parent (subtypep class 'system)) + (error 'non-toplevel-system :parent parent :name name)) (if component ; preserve identity (apply 'reinitialize-instance component args) - (setf component (apply 'make-instance (class-for-type parent type) args))) + (setf component (apply 'make-instance class args))) (component-pathname component) ; eagerly compute the absolute pathname - (let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous + (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous (when (and (typep component 'system) (not bspp)) - (setf (builtin-system-p component) (lisp-implementation-pathname-p sysdir))) - (setf version (normalize-version version sysdir))) - (when (and versionp version (not (parse-version version nil))) - (warn (compatfmt "~@") - version name parent)) + (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile))) + (setf version (normalize-version version :component name :parent parent :pathname sysfile))) ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8. ;; A better fix is required. (setf (slot-value component 'version) version) @@ -8267,8 +8125,14 @@ system names to pathnames of .asd files") :collect c :when serial :do (setf previous-component name))) (compute-children-by-name component)) + (when previous-serial-component + (push previous-serial-component depends-on)) + (when weakly-depends-on + ;; ASDF4: deprecate this feature and remove it. + (appendf depends-on + (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) ;; Used by POIU. ASDF4: rename to component-depends-on? - (setf (component-sibling-dependencies component) depends-on) + (setf (component-sideway-dependencies component) depends-on) (%refresh-component-inline-methods component rest) (when if-component-dep-fails (%resolve-if-component-dep-fails if-component-dep-fails component)) @@ -8296,10 +8160,13 @@ system names to pathnames of .asd files") (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 @@ -8308,738 +8175,1394 @@ system names to pathnames of .asd files") :pathname (determine-system-directory pathname) component-options))))) - (defmacro defsystem (name &body options) - `(apply 'register-system-definition ',name ',options))) -;;;; ------------------------------------------------------------------------- -;;;; ASDF-Bundle + (defmacro defsystem (name &body options) + `(apply 'register-system-definition ',name ',options))) +;;;; ------------------------------------------------------------------------- +;;;; ASDF-Bundle + +(asdf/package:define-package :asdf/bundle + (:recycle :asdf/bundle :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation + :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) + (:export + #:bundle-op #:bundle-op-build-args #:bundle-type + #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files + #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p + #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op + #:lib-op #:monolithic-lib-op + #:dll-op #:monolithic-dll-op + #:binary-op #:monolithic-binary-op + #:program-op #:compiled-file #:precompiled-system #:prebuilt-system + #:user-system-p #:user-system #:trivial-system-p + #+ecl #:make-build + #:register-pre-built-system + #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library)) +(in-package :asdf/bundle) + +(with-upgradability () + (defclass bundle-op (operation) + ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) + (name-suffix :initarg :name-suffix :initform nil) + (bundle-type :initform :no-output-file :reader bundle-type) + #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files) + #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) + #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) + + (defclass bundle-compile-op (bundle-op basic-compile-op) + () + (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files")) + + ;; create a single fasl for the entire library + (defclass basic-fasl-op (bundle-compile-op) + ((bundle-type :initform :fasl))) + (defclass prepare-fasl-op (sideway-operation) + ((sideway-operation :initform 'load-fasl-op))) + (defclass fasl-op (basic-fasl-op selfward-operation) + ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op)))) + (defclass load-fasl-op (basic-load-op selfward-operation) + ((selfward-operation :initform '(prepare-op fasl-op)))) + + ;; NB: since the monolithic-op's can't be sideway-operation's, + ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's, + ;; we'd have to have the monolithic-op not inherit from the main op, + ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above. + + (defclass no-ld-flags-op (operation) ()) + + (defclass lib-op (bundle-compile-op no-ld-flags-op) + ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) + (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it." + #-(or ecl mkcl) "just compile the system")) + + (defclass dll-op (bundle-compile-op selfward-operation no-ld-flags-op) + ((bundle-type :initform :dll)) + (:documentation "compile the system and produce dynamic (.so/.dll) library for it.")) + + (defclass binary-op (basic-compile-op selfward-operation) + ((selfward-operation :initform '(fasl-op lib-op))) + (:documentation "produce fasl and asd files for the system")) + + (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies + + (defclass monolithic-bundle-op (monolithic-op bundle-op) + ((prologue-code :accessor monolithic-op-prologue-code) + (epilogue-code :accessor monolithic-op-epilogue-code))) + + (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op) + () + (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems")) + + (defclass monolithic-binary-op (monolithic-op binary-op) + ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op))) + (:documentation "produce fasl and asd files for combined system and dependencies.")) + + (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) () + (:documentation "Create a single fasl for the system and its dependencies.")) + + (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op no-ld-flags-op) + ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) + (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies." + #-(or ecl mkcl) "Compile a system and its dependencies.")) + + (defclass monolithic-dll-op (monolithic-bundle-compile-op sideway-operation selfward-operation no-ld-flags-op) + ((bundle-type :initform :dll)) + (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies.")) + + (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op) + #-(or mkcl ecl) (monolithic-bundle-op selfward-operation) + ((bundle-type :initform :program) + #-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op)) + (:documentation "create an executable file from the system and its dependencies")) + + (defun bundle-pathname-type (bundle-type) + (etypecase bundle-type + ((eql :no-output-file) nil) ;; should we error out instead? + ((or null string) bundle-type) + ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") + #+ecl + ((member :binary :dll :lib :shared-library :static-library :program :object :program) + (compile-file-type :type bundle-type)) + ((eql :binary) "image") + ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll"))) + ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib"))) + ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) + + (defun bundle-output-files (o c) + (when (input-files o c) + (let ((bundle-type (bundle-type o))) + (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type. + (let ((name (or (component-build-pathname c) + (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) + (type (bundle-pathname-type bundle-type))) + (values (list (subpathname (component-pathname c) name :type type)) + (eq (type-of o) (component-build-operation c)))))))) + + (defmethod output-files ((o bundle-op) (c system)) + (bundle-output-files o c)) + + #-(or ecl mkcl) + (defmethod perform ((o program-op) (c system)) + (let ((output-file (output-file o c))) + (setf *image-entry-point* (ensure-function (component-entry-point c))) + (dump-image output-file :executable t))) + + (defclass compiled-file (file-component) + ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) + + (defclass precompiled-system (system) + ((build-pathname :initarg :fasl))) + + (defclass prebuilt-system (system) + ((build-pathname :initarg :static-library :initarg :lib + :accessor prebuilt-system-static-library)))) + + +;;; +;;; BUNDLE-OP +;;; +;;; This operation takes all components from one or more systems and +;;; creates a single output file, which may be +;;; a FASL, a statically linked library, a shared library, etc. +;;; The different targets are defined by specialization. +;;; +(with-upgradability () + (defun operation-monolithic-p (op) + (typep op 'monolithic-op)) + + (defmethod initialize-instance :after ((instance bundle-op) &rest initargs + &key (name-suffix nil name-suffix-p) + &allow-other-keys) + (declare (ignorable initargs name-suffix)) + (unless name-suffix-p + (setf (slot-value instance 'name-suffix) + (unless (typep instance 'program-op) + (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames + (when (typep instance 'monolithic-bundle-op) + (destructuring-bind (&rest original-initargs + &key lisp-files prologue-code epilogue-code + &allow-other-keys) + (operation-original-initargs instance) + (setf (operation-original-initargs instance) + (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs) + (monolithic-op-prologue-code instance) prologue-code + (monolithic-op-epilogue-code instance) epilogue-code) + #-ecl (assert (null (or lisp-files epilogue-code prologue-code))) + #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) + (setf (bundle-op-build-args instance) + (remove-plist-keys '(:type :monolithic :name-suffix) + (operation-original-initargs instance)))) + + (defmethod bundle-op-build-args :around ((o no-ld-flags-op)) + (declare (ignorable o)) + (let ((args (call-next-method))) + (remf args :ld-flags) + args)) + + (defun bundlable-file-p (pathname) + (let ((type (pathname-type pathname))) + (declare (ignorable type)) + (or #+ecl (or (equalp type (compile-file-type :type :object)) + (equalp type (compile-file-type :type :static-library))) + #+mkcl (equalp type (compile-file-type :fasl-p nil)) + #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) + + (defgeneric* (trivial-system-p) (component)) + + (defun user-system-p (s) + (and (typep s 'system) + (not (builtin-system-p s)) + (not (trivial-system-p s))))) + +(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) + (deftype user-system () '(and system (satisfies user-system-p)))) + +;;; +;;; First we handle monolithic bundles. +;;; These are standalone systems which contain everything, +;;; including other ASDF systems required by the current one. +;;; A PROGRAM is always monolithic. +;;; +;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL +;;; +(with-upgradability () + (defmethod component-depends-on ((o bundle-compile-op) (c system)) + `(,(if (operation-monolithic-p o) + `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op + ,@(required-components c :other-systems t :component-type 'system + :goal-operation (find-operation o 'load-op) + :keep-operation 'compile-op)) + `(compile-op + ,@(required-components c :other-systems nil :component-type '(not system) + :goal-operation (find-operation o 'load-op) + :keep-operation 'compile-op))) + ,@(call-next-method))) + + (defmethod component-depends-on :around ((o bundle-op) (c component)) + (declare (ignorable o c)) + (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c))) + `((,op ,c)) + (call-next-method))) + + (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) + ;; This file selects output files from direct dependencies; + ;; your component-depends-on method better gathered the correct dependencies in the correct order. + (while-collecting (collect) + (map-direct-dependencies + o c #'(lambda (sub-o sub-c) + (loop :for f :in (funcall key sub-o sub-c) + :when (funcall test f) :do (collect f)))))) + + (defmethod input-files ((o bundle-compile-op) (c system)) + (unless (eq (bundle-type o) :no-output-file) + (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))) + + (defun select-bundle-operation (type &optional monolithic) + (ecase type + ((:binary) + (if monolithic 'monolithic-binary-op 'binary-op)) + ((:dll :shared-library) + (if monolithic 'monolithic-dll-op 'dll-op)) + ((:lib :static-library) + (if monolithic 'monolithic-lib-op 'lib-op)) + ((:fasl) + (if monolithic 'monolithic-fasl-op 'fasl-op)) + ((:program) + 'program-op))) + + (defun make-build (system &rest args &key (monolithic nil) (type :fasl) + (move-here nil move-here-p) + &allow-other-keys) + (let* ((operation-name (select-bundle-operation type monolithic)) + (move-here-path (if (and move-here + (typep move-here '(or pathname string))) + (pathname move-here) + (system-relative-pathname system "asdf-output/"))) + (operation (apply #'operate operation-name + system + (remove-plist-keys '(:monolithic :type :move-here) args))) + (system (find-system system)) + (files (and system (output-files operation system)))) + (if (or move-here (and (null move-here-p) + (member operation-name '(:program :binary)))) + (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) + :for f :in files + :for new-f = (make-pathname :name (pathname-name f) + :type (pathname-type f) + :defaults dest-path) + :do (rename-file-overwriting-target f new-f) + :collect new-f) + files)))) + +;;; +;;; LOAD-FASL-OP +;;; +;;; This is like ASDF's LOAD-OP, but using monolithic fasl files. +;;; +(with-upgradability () + (defmethod component-depends-on ((o load-fasl-op) (c system)) + (declare (ignorable o)) + `((,o ,@(loop :for dep :in (component-sideway-dependencies c) + :collect (resolve-dependency-spec c dep))) + (,(if (user-system-p c) 'fasl-op 'load-op) ,c) + ,@(call-next-method))) + + (defmethod input-files ((o load-fasl-op) (c system)) + (when (user-system-p c) + (output-files (find-operation o 'fasl-op) c))) + + (defmethod perform ((o load-fasl-op) c) + (declare (ignorable o c)) + nil) + + (defmethod perform ((o load-fasl-op) (c system)) + (when (input-files o c) + (perform-lisp-load-fasl o c))) + + (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) + (mark-operation-done (find-operation o 'load-op) c))) + +;;; +;;; PRECOMPILED FILES +;;; +;;; This component can be used to distribute ASDF systems in precompiled form. +;;; Only useful when the dependencies have also been precompiled. +;;; +(with-upgradability () + (defmethod trivial-system-p ((s system)) + (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) + + (defmethod output-files (o (c compiled-file)) + (declare (ignorable o c)) + nil) + (defmethod input-files (o (c compiled-file)) + (declare (ignorable o)) + (component-pathname c)) + (defmethod perform ((o load-op) (c compiled-file)) + (perform-lisp-load-fasl o c)) + (defmethod perform ((o load-source-op) (c compiled-file)) + (perform (find-operation o 'load-op) c)) + (defmethod perform ((o load-fasl-op) (c compiled-file)) + (perform (find-operation o 'load-op) c)) + (defmethod perform ((o operation) (c compiled-file)) + (declare (ignorable o c)) + nil)) + +;;; +;;; Pre-built systems +;;; +(with-upgradability () + (defmethod trivial-system-p ((s prebuilt-system)) + (declare (ignorable s)) + t) + + (defmethod perform ((o lib-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) + + (defmethod component-depends-on ((o lib-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) + + (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system)) + (declare (ignorable o)) + nil)) -(asdf/package:define-package :asdf/bundle - (:recycle :asdf/bundle :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation - :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) - (:export - #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type - #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op - #:monolithic-op #:monolithic-bundle-op #:direct-dependency-files - #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op - #:program-op - #:compiled-file #:precompiled-system #:prebuilt-system - #:operation-monolithic-p - #:user-system-p #:user-system #:trivial-system-p - #+ecl #:make-build - #:register-pre-built-system - #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library)) -(in-package :asdf/bundle) +;;; +;;; PREBUILT SYSTEM CREATOR +;;; (with-upgradability () - (defclass bundle-op (operation) - ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) - (name-suffix :initarg :name-suffix :initform nil) - (bundle-type :initform :no-output-file :reader bundle-type) - #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files) - #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) - #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) + (defmethod output-files ((o binary-op) (s system)) + (list (make-pathname :name (component-name s) :type "asd" + :defaults (component-pathname s)))) - (defclass fasl-op (bundle-op) - ;; create a single fasl for the entire library - ((bundle-type :initform :fasl))) + (defmethod perform ((o binary-op) (s system)) + (let* ((inputs (input-files o s)) + (fasl (first inputs)) + (library (second inputs)) + (asd (first (output-files o s))) + (name (if (and fasl asd) (pathname-name asd) (return-from perform))) + (dependencies + (if (operation-monolithic-p o) + (remove-if-not 'builtin-system-p + (required-components s :component-type 'system + :keep-operation 'load-op)) + (while-collecting (x) ;; resolve the sideway-dependencies of s + (map-direct-dependencies + 'load-op s + #'(lambda (o c) + (when (and (typep o 'load-op) (typep c 'system)) + (x c))))))) + (depends-on (mapcar 'coerce-name dependencies))) + (when (pathname-equal asd (system-source-file s)) + (cerror "overwrite the asd file" + "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations." + (cons o s) asd)) + (with-open-file (s asd :direction :output :if-exists :supersede + :if-does-not-exist :create) + (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%" + (operation-monolithic-p o) name) + (format s ";;; Built for ~A ~A on a ~A/~A ~A~%" + (lisp-implementation-type) + (lisp-implementation-version) + (software-type) + (machine-type) + (software-version)) + (let ((*package* (find-package :asdf-user))) + (pprint `(defsystem ,name + :class prebuilt-system + :depends-on ,depends-on + :components ((:compiled-file ,(pathname-name fasl))) + ,@(when library `(:lib ,(file-namestring library)))) + s) + (terpri s))))) - (defclass load-fasl-op (basic-load-op) - ;; load a single fasl for the entire library - ()) + #-(or ecl mkcl) + (defmethod perform ((o bundle-compile-op) (c system)) + (let* ((input-files (input-files o c)) + (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) + (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) + (output-files (output-files o c)) + (output-file (first output-files))) + (assert (eq (not input-files) (not output-files))) + (when input-files + (when non-fasl-files + (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S" + (implementation-type) non-fasl-files)) + (when (and (typep o 'monolithic-bundle-op) + (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o))) + (error "prologue-code and epilogue-code are not supported on ~A" + (implementation-type))) + (with-staging-pathname (output-file) + (combine-fasls fasl-files output-file))))) - (defclass lib-op (bundle-op) - ;; On ECL: compile the system and produce linkable .a library for it. - ;; On others: just compile the system. - ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))) + (defmethod input-files ((o load-op) (s precompiled-system)) + (declare (ignorable o)) + (bundle-output-files (find-operation o 'fasl-op) s)) - (defclass dll-op (bundle-op) - ;; Link together all the dynamic library used by this system into a single one. - ((bundle-type :initform :dll))) + (defmethod perform ((o load-op) (s precompiled-system)) + (perform-lisp-load-fasl o s)) - (defclass binary-op (bundle-op) - ;; On ECL: produce lib and fasl for the system. - ;; On "normal" Lisps: produce just the fasl. - ()) + (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) + (declare (ignorable o)) + `((load-op ,s) ,@(call-next-method)))) - (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies + #| ;; Example use: +(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) +(asdf:load-system :precompiled-asdf-utils) +|# - (defclass monolithic-bundle-op (monolithic-op bundle-op) - ((prologue-code :accessor monolithic-op-prologue-code) - (epilogue-code :accessor monolithic-op-epilogue-code))) +#+(or ecl mkcl) +(with-upgradability () + (defun uiop-library-file () + (or (and (find-system :uiop nil) + (system-source-directory :uiop) + (progn + (operate 'lib-op :uiop) + (output-file 'lib-op :uiop))) + (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib)))) + (defmethod input-files :around ((o program-op) (c system)) + (let ((files (call-next-method)) + (plan (traverse-sub-actions o c :plan-class 'sequential-plan))) + (unless (or (and (find-system :uiop nil) + (system-source-directory :uiop) + (plan-operates-on-p plan '("uiop"))) + (and (system-source-directory :asdf) + (plan-operates-on-p plan '("asdf")))) + (pushnew (uiop-library-file) files :test 'pathname-equal)) + files)) - (defclass monolithic-binary-op (binary-op monolithic-bundle-op) - ;; On ECL: produce lib and fasl for combined system and dependencies. - ;; On "normal" Lisps: produce an image file from system and dependencies. - ()) + (defun register-pre-built-system (name) + (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))) - (defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) - ;; Create a single fasl for the system and its dependencies. - ()) +#+ecl +(with-upgradability () + (defmethod perform ((o bundle-compile-op) (c system)) + (let* ((object-files (input-files o c)) + (output (output-files o c)) + (bundle (first output)) + (kind (bundle-type o))) + (when output + (create-image + bundle (append object-files (bundle-op-lisp-files o)) + :kind kind + :entry-point (component-entry-point c) + :prologue-code + (when (typep o 'monolithic-bundle-op) + (monolithic-op-prologue-code o)) + :epilogue-code + (when (typep o 'monolithic-bundle-op) + (monolithic-op-epilogue-code o)) + :build-args (bundle-op-build-args o)))))) - (defclass monolithic-lib-op (monolithic-bundle-op lib-op) - ;; ECL: Create a single linkable library for the system and its dependencies. - ((bundle-type :initform :lib))) +#+mkcl +(with-upgradability () + (defmethod perform ((o lib-op) (s system)) + (apply #'compiler::build-static-library (output-file o c) + :lisp-object-files (input-files o s) (bundle-op-build-args o))) - (defclass monolithic-dll-op (monolithic-bundle-op dll-op) - ((bundle-type :initform :dll))) + (defmethod perform ((o basic-fasl-op) (s system)) + (apply #'compiler::build-bundle (output-file o c) ;; second??? + :lisp-object-files (input-files o s) (bundle-op-build-args o))) - (defclass program-op (monolithic-bundle-op) - ;; All: create an executable file from the system and its dependencies - ((bundle-type :initform :program))) + (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) + (declare (ignore force verbose version)) + (apply #'operate 'binary-op system args))) +;;;; ------------------------------------------------------------------------- +;;;; Concatenate-source - (defun bundle-pathname-type (bundle-type) - (etypecase bundle-type - ((eql :no-output-file) nil) ;; should we error out instead? - ((or null string) bundle-type) - ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") - #+ecl - ((member :binary :dll :lib :static-library :program :object :program) - (compile-file-type :type bundle-type)) - ((eql :binary) "image") - ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll"))) - ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib"))) - ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) +(asdf/package:define-package :asdf/concatenate-source + (:recycle :asdf/concatenate-source :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/operation + :asdf/system :asdf/find-system :asdf/defsystem + :asdf/action :asdf/lisp-action :asdf/bundle) + (:export + #:concatenate-source-op + #:load-concatenated-source-op + #:compile-concatenated-source-op + #:load-compiled-concatenated-source-op + #:monolithic-concatenate-source-op + #:monolithic-load-concatenated-source-op + #:monolithic-compile-concatenated-source-op + #:monolithic-load-compiled-concatenated-source-op)) +(in-package :asdf/concatenate-source) - (defun bundle-output-files (o c) - (let ((bundle-type (bundle-type o))) - (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type. - (let ((name (or (component-build-pathname c) - (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) - (type (bundle-pathname-type bundle-type))) - (values (list (subpathname (component-pathname c) name :type type)) - (eq (type-of o) (component-build-operation c))))))) +;;; +;;; Concatenate sources +;;; +(with-upgradability () + (defclass basic-concatenate-source-op (bundle-op) + ((bundle-type :initform "lisp"))) + (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ()) + (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ()) + (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ()) + + (defclass concatenate-source-op (basic-concatenate-source-op) ()) + (defclass load-concatenated-source-op (basic-load-concatenated-source-op) + ((selfward-operation :initform '(prepare-op concatenate-source-op)))) + (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op) + ((selfward-operation :initform '(prepare-op concatenate-source-op)))) + (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform '(prepare-op compile-concatenated-source-op)))) + + (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ()) + (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op) + ((selfward-operation :initform 'monolithic-concatenate-source-op))) + (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op) + ((selfward-operation :initform 'monolithic-concatenate-source-op))) + (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform 'monolithic-compile-concatenated-source-op))) + + (defmethod input-files ((operation basic-concatenate-source-op) (s system)) + (loop :with encoding = (or (component-encoding s) *default-encoding*) + :with other-encodings = '() + :with around-compile = (around-compile-hook s) + :with other-around-compile = '() + :for c :in (required-components + s :goal-operation 'compile-op + :keep-operation 'compile-op + :other-systems (operation-monolithic-p operation)) + :append + (when (typep c 'cl-source-file) + (let ((e (component-encoding c))) + (unless (equal e encoding) + (pushnew e other-encodings :test 'equal))) + (let ((a (around-compile-hook c))) + (unless (equal a around-compile) + (pushnew a other-around-compile :test 'equal))) + (input-files (make-operation 'compile-op) c)) :into inputs + :finally + (when other-encodings + (warn "~S uses encoding ~A but has sources that use these encodings: ~A" + operation encoding other-encodings)) + (when other-around-compile + (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" + operation around-compile other-around-compile)) + (return inputs))) + (defmethod output-files ((o basic-compile-concatenated-source-op) (s system)) + (lisp-compilation-output-files o s)) - (defmethod output-files ((o bundle-op) (c system)) - (bundle-output-files o c)) + (defmethod perform ((o basic-concatenate-source-op) (s system)) + (let ((inputs (input-files o s)) + (output (output-file o s))) + (concatenate-files inputs output))) + (defmethod perform ((o basic-load-concatenated-source-op) (s system)) + (perform-lisp-load-source o s)) + (defmethod perform ((o basic-compile-concatenated-source-op) (s system)) + (perform-lisp-compilation o s)) + (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system)) + (perform-lisp-load-fasl o s))) - #-(or ecl mkcl) - (progn - (defmethod perform ((o program-op) (c system)) - (let ((output-file (output-file o c))) - (setf *image-entry-point* (ensure-function (component-entry-point c))) - (dump-image output-file :executable t))) +;;;; --------------------------------------------------------------------------- +;;;; asdf-output-translations - (defmethod perform ((o monolithic-binary-op) (c system)) - (let ((output-file (output-file o c))) - (dump-image output-file)))) +(asdf/package:define-package :asdf/output-translations + (:recycle :asdf/output-translations :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:export + #:*output-translations* #:*output-translations-parameter* + #:invalid-output-translation + #:output-translations #:output-translations-initialized-p + #:initialize-output-translations #:clear-output-translations + #:disable-output-translations #:ensure-output-translations + #:apply-output-translations + #:validate-output-translations-directive #:validate-output-translations-form + #:validate-output-translations-file #:validate-output-translations-directory + #:parse-output-translations-string #:wrapping-output-translations + #:user-output-translations-pathname #:system-output-translations-pathname + #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname + #:environment-output-translations #:process-output-translations + #:compute-output-translations + #+abcl #:translate-jar-pathname + )) +(in-package :asdf/output-translations) - (defclass compiled-file (file-component) - ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) +(when-upgrading () (undefine-function '(setf output-translations))) - (defclass precompiled-system (system) - ((build-pathname :initarg :fasl))) +(with-upgradability () + (define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform (compatfmt "~@")))) - (defclass prebuilt-system (system) - ((build-pathname :initarg :static-library :initarg :lib - :accessor prebuilt-system-static-library)))) + (defvar *output-translations* () + "Either NIL (for uninitialized), or a list of one element, +said element itself being a sorted list of mappings. +Each mapping is a pair of a source pathname and destination pathname, +and the order is by decreasing length of namestring of the source pathname.") + (defun output-translations () + (car *output-translations*)) -;;; -;;; BUNDLE-OP -;;; -;;; This operation takes all components from one or more systems and -;;; creates a single output file, which may be -;;; a FASL, a statically linked library, a shared library, etc. -;;; The different targets are defined by specialization. -;;; -(with-upgradability () - (defun operation-monolithic-p (op) - (typep op 'monolithic-op)) + (defun set-output-translations (new-value) + (setf *output-translations* + (list + (stable-sort (copy-list new-value) #'> + :key #'(lambda (x) + (etypecase (car x) + ((eql t) -1) + (pathname + (let ((directory (pathname-directory (car x)))) + (if (listp directory) (length directory) 0)))))))) + new-value) + #-gcl2.6 + (defun* ((setf output-translations)) (new-value) (set-output-translations new-value)) + #+gcl2.6 + (defsetf output-translations set-output-translations) + + (defun output-translations-initialized-p () + (and *output-translations* t)) + + (defun clear-output-translations () + "Undoes any initialization of the output translations." + (setf *output-translations* '()) + (values)) + (register-clear-configuration-hook 'clear-output-translations) + + (defun validate-output-translations-directive (directive) + (or (member directive '(:enable-user-cache :disable-cache nil)) + (and (consp directive) + (or (and (length=n-p directive 2) + (or (and (eq (first directive) :include) + (typep (second directive) '(or string pathname null))) + (and (location-designator-p (first directive)) + (or (location-designator-p (second directive)) + (location-function-p (second directive)))))) + (and (length=n-p directive 1) + (location-designator-p (first directive))))))) + + (defun validate-output-translations-form (form &key location) + (validate-configuration-form + form + :output-translations + 'validate-output-translations-directive + :location location :invalid-form-reporter 'invalid-output-translation)) + + (defun validate-output-translations-file (file) + (validate-configuration-file + file 'validate-output-translations-form :description "output translations")) - (defmethod initialize-instance :after ((instance bundle-op) &rest initargs - &key (name-suffix nil name-suffix-p) - &allow-other-keys) - (declare (ignorable initargs name-suffix)) - (unless name-suffix-p - (setf (slot-value instance 'name-suffix) - (unless (typep instance 'program-op) - (if (operation-monolithic-p instance) ".all-systems" #-ecl ".system")))) - (when (typep instance 'monolithic-bundle-op) - (destructuring-bind (&rest original-initargs - &key lisp-files prologue-code epilogue-code - &allow-other-keys) - (operation-original-initargs instance) - (setf (operation-original-initargs instance) - (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs) - (monolithic-op-prologue-code instance) prologue-code - (monolithic-op-epilogue-code instance) epilogue-code) - #-ecl (assert (null (or lisp-files epilogue-code prologue-code))) - #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) - (setf (bundle-op-build-args instance) - (remove-plist-keys '(:type :monolithic :name-suffix) - (operation-original-initargs instance)))) + (defun validate-output-translations-directory (directory) + (validate-configuration-directory + directory :output-translations 'validate-output-translations-directive + :invalid-form-reporter 'invalid-output-translation)) - (defmethod bundle-op-build-args :around ((o lib-op)) - (declare (ignorable o)) - (let ((args (call-next-method))) - (remf args :ld-flags) - args)) + (defun parse-output-translations-string (string &key location) + (cond + ((or (null string) (equal string "")) + '(:output-translations :inherit-configuration)) + ((not (stringp string)) + (error (compatfmt "~@") 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 "~@") + string)) + (setf inherit t) + (push :inherit-configuration directives)) + (t + (setf source s))) + (setf start (1+ i)) + (when (> start end) + (when source + (error (compatfmt "~@") + string)) + (unless inherit + (push :ignore-inherited-configuration directives)) + (return `(:output-translations ,@(nreverse directives))))))))) - (defun bundlable-file-p (pathname) - (let ((type (pathname-type pathname))) - (declare (ignorable type)) - (or #+ecl (or (equal type (compile-file-type :type :object)) - (equal type (compile-file-type :type :static-library))) - #+mkcl (equal type (compile-file-type :fasl-p nil)) - #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type))))) + (defparameter *default-output-translations* + '(environment-output-translations + user-output-translations-pathname + user-output-translations-directory-pathname + system-output-translations-pathname + system-output-translations-directory-pathname)) - (defgeneric* (trivial-system-p) (component)) + (defun wrapping-output-translations () + `(:output-translations + ;; Some implementations have precompiled ASDF systems, + ;; so we must disable translations for implementation paths. + #+(or #|clozure|# ecl mkcl sbcl) + ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) + (when h `(((,h ,*wild-path*) ())))) + #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) + ;; All-import, here is where we want user stuff to be: + :inherit-configuration + ;; These are for convenience, and can be overridden by the user: + #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + ;; We enable the user cache by default, and here is the place we do: + :enable-user-cache)) - (defun user-system-p (s) - (and (typep s 'system) - (not (builtin-system-p s)) - (not (trivial-system-p s))))) + (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf")) + (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/")) -(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) - (deftype user-system () '(and system (satisfies user-system-p)))) + (defun user-output-translations-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-file* :direction direction)) + (defun system-output-translations-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-file* :direction direction)) + (defun user-output-translations-directory-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-directory* :direction direction)) + (defun system-output-translations-directory-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-directory* :direction direction)) + (defun environment-output-translations () + (getenv "ASDF_OUTPUT_TRANSLATIONS")) -;;; -;;; First we handle monolithic bundles. -;;; These are standalone systems which contain everything, -;;; including other ASDF systems required by the current one. -;;; A PROGRAM is always monolithic. -;;; -;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL -;;; -(with-upgradability () - (defmethod component-depends-on ((o monolithic-lib-op) (c system)) - (declare (ignorable o)) - `((lib-op ,@(required-components c :other-systems t :component-type 'system - :goal-operation 'load-op - :keep-operation 'compile-op)))) + (defgeneric process-output-translations (spec &key inherit collect)) - (defmethod component-depends-on ((o monolithic-fasl-op) (c system)) - (declare (ignorable o)) - `((fasl-op ,@(required-components c :other-systems t :component-type 'system - :goal-operation 'load-fasl-op - :keep-operation 'fasl-op)))) + (defun inherit-output-translations (inherit &key collect) + (when inherit + (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) - (defmethod component-depends-on ((o program-op) (c system)) - (declare (ignorable o)) - #+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op) c) - #-(or ecl mkcl) `((load-op ,c))) + (defun* (process-output-translations-directive) (directive &key inherit collect) + (if (atom directive) + (ecase directive + ((:enable-user-cache) + (process-output-translations-directive '(t :user-cache) :collect collect)) + ((:disable-cache) + (process-output-translations-directive '(t t) :collect collect)) + ((:inherit-configuration) + (inherit-output-translations inherit :collect collect)) + ((:ignore-inherited-configuration :ignore-invalid-entries nil) + nil)) + (let ((src (first directive)) + (dst (second directive))) + (if (eq src :include) + (when dst + (process-output-translations (pathname dst) :inherit nil :collect collect)) + (when src + (let ((trusrc (or (eql src t) + (let ((loc (resolve-location src :ensure-directory t :wilden t))) + (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc))))) + (cond + ((location-function-p dst) + (funcall collect + (list trusrc + (if (symbolp (second dst)) + (fdefinition (second dst)) + (eval (second dst)))))) + ((eq dst t) + (funcall collect (list trusrc t))) + (t + (let* ((trudst (if dst + (resolve-location dst :ensure-directory t :wilden t) + trusrc))) + (funcall collect (list trudst t)) + (funcall collect (list trusrc trudst))))))))))) - (defmethod component-depends-on ((o binary-op) (c system)) - (declare (ignorable o)) - `((fasl-op ,c) - (lib-op ,c))) + (defmethod process-output-translations ((x symbol) &key + (inherit *default-output-translations*) + collect) + (process-output-translations (funcall x) :inherit inherit :collect collect)) + (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect) + (cond + ((directory-pathname-p pathname) + (process-output-translations (validate-output-translations-directory pathname) + :inherit inherit :collect collect)) + ((probe-file* pathname :truename *resolve-symlinks*) + (process-output-translations (validate-output-translations-file pathname) + :inherit inherit :collect collect)) + (t + (inherit-output-translations inherit :collect collect)))) + (defmethod process-output-translations ((string string) &key inherit collect) + (process-output-translations (parse-output-translations-string string) + :inherit inherit :collect collect)) + (defmethod process-output-translations ((x null) &key inherit collect) + (declare (ignorable x)) + (inherit-output-translations inherit :collect collect)) + (defmethod process-output-translations ((form cons) &key inherit collect) + (dolist (directive (cdr (validate-output-translations-form form))) + (process-output-translations-directive directive :inherit inherit :collect collect))) - (defmethod component-depends-on ((o monolithic-binary-op) (c system)) - `((,(find-operation o 'monolithic-fasl-op) ,c) - (,(find-operation o 'monolithic-lib-op) ,c))) + (defun compute-output-translations (&optional parameter) + "read the configuration, return it" + (remove-duplicates + (while-collecting (c) + (inherit-output-translations + `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) + :test 'equal :from-end t)) - (defmethod component-depends-on ((o lib-op) (c system)) - (declare (ignorable o)) - `((compile-op ,@(required-components c :other-systems nil :component-type '(not system) - :goal-operation 'load-op - :keep-operation 'compile-op)))) + (defvar *output-translations-parameter* nil) - (defmethod component-depends-on ((o fasl-op) (c system)) - (declare (ignorable o)) - #+ecl `((lib-op ,c)) - #-ecl - (component-depends-on (find-operation o 'lib-op) c)) + (defun initialize-output-translations (&optional (parameter *output-translations-parameter*)) + "read the configuration, initialize the internal configuration variable, +return the configuration" + (setf *output-translations-parameter* parameter + (output-translations) (compute-output-translations parameter))) - (defmethod component-depends-on ((o dll-op) c) - (component-depends-on (find-operation o 'lib-op) c)) + (defun disable-output-translations () + "Initialize output translations in a way that maps every file to itself, +effectively disabling the output translation facility." + (initialize-output-translations + '(:output-translations :disable-cache :ignore-inherited-configuration))) - (defmethod component-depends-on ((o bundle-op) c) - (declare (ignorable o c)) - nil) + ;; checks an initial variable to see whether the state is initialized + ;; or cleared. In the former case, return current configuration; in + ;; the latter, initialize. ASDF will call this function at the start + ;; of (asdf:find-system). + (defun ensure-output-translations () + (if (output-translations-initialized-p) + (output-translations) + (initialize-output-translations))) - (defmethod component-depends-on :around ((o bundle-op) (c component)) - (declare (ignorable o c)) - (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c))) - `((,op ,c)) - (call-next-method))) + (defun* (apply-output-translations) (path) + (etypecase path + (logical-pathname + path) + ((or pathname string) + (ensure-output-translations) + (loop* :with p = (resolve-symlinks* path) + :for (source destination) :in (car *output-translations*) + :for root = (when (or (eq source t) + (and (pathnamep source) + (not (absolute-pathname-p source)))) + (pathname-root p)) + :for absolute-source = (cond + ((eq source t) (wilden root)) + (root (merge-pathnames* source root)) + (t source)) + :when (or (eq source t) (pathname-match-p p absolute-source)) + :return (translate-pathname* p absolute-source destination root source) + :finally (return p))))) - (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) - (while-collecting (collect) - (map-direct-dependencies - o c #'(lambda (sub-o sub-c) - (loop :for f :in (funcall key sub-o sub-c) - :when (funcall test f) :do (collect f)))))) + ;; Hook into asdf/driver's output-translation mechanism + #-cormanlisp + (setf *output-translation-function* 'apply-output-translations) - (defmethod input-files ((o bundle-op) (c system)) - (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)) + #+abcl + (defun translate-jar-pathname (source wildcard) + (declare (ignore wildcard)) + (flet ((normalize-device (pathname) + (if (find :windows *features*) + pathname + (make-pathname :defaults pathname :device :unspecific)))) + (let* ((jar + (pathname (first (pathname-device source)))) + (target-root-directory-namestring + (format nil "/___jar___file___root___/~@[~A/~]" + (and (find :windows *features*) + (pathname-device jar)))) + (relative-source + (relativize-pathname-directory source)) + (relative-jar + (relativize-pathname-directory (ensure-directory-pathname jar))) + (target-root-directory + (normalize-device + (pathname-directory-pathname + (parse-namestring target-root-directory-namestring)))) + (target-root + (merge-pathnames* relative-jar target-root-directory)) + (target + (merge-pathnames* relative-source target-root))) + (normalize-device (apply-output-translations target)))))) - (defun select-bundle-operation (type &optional monolithic) - (ecase type - ((:binary) - (if monolithic 'monolithic-binary-op 'binary-op)) - ((:dll :shared-library) - (if monolithic 'monolithic-dll-op 'dll-op)) - ((:lib :static-library) - (if monolithic 'monolithic-lib-op 'lib-op)) - ((:fasl) - (if monolithic 'monolithic-fasl-op 'fasl-op)) - ((:program) - 'program-op))) +;;;; ------------------------------------------------------------------------- +;;; Backward-compatible interfaces - (defun make-build (system &rest args &key (monolithic nil) (type :fasl) - (move-here nil move-here-p) - &allow-other-keys) - (let* ((operation-name (select-bundle-operation type monolithic)) - (move-here-path (if (and move-here - (typep move-here '(or pathname string))) - (pathname move-here) - (system-relative-pathname system "asdf-output/"))) - (operation (apply #'operate operation-name - system - (remove-plist-keys '(:monolithic :type :move-here) args))) - (system (find-system system)) - (files (and system (output-files operation system)))) - (if (or move-here (and (null move-here-p) - (member operation-name '(:program :binary)))) - (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) - :for f :in files - :for new-f = (make-pathname :name (pathname-name f) - :type (pathname-type f) - :defaults dest-path) - :do (rename-file-overwriting-target f new-f) - :collect new-f) - files)))) +(asdf/package:define-package :asdf/backward-interface + (:recycle :asdf/backward-interface :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action + :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations) + (:export + #:*asdf-verbose* + #:operation-error #:compile-error #:compile-failed #:compile-warned + #:error-component #:error-operation #:traverse + #:component-load-dependencies + #:enable-asdf-binary-locations-compatibility + #:operation-forced + #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings + #:component-property + #:run-shell-command + #:system-definition-pathname)) +(in-package :asdf/backward-interface) -;;; -;;; LOAD-FASL-OP -;;; -;;; This is like ASDF's LOAD-OP, but using monolithic fasl files. -;;; (with-upgradability () - (defmethod component-depends-on ((o load-fasl-op) (c system)) - (declare (ignorable o)) - `((,o ,@(loop :for dep :in (component-sibling-dependencies c) - :collect (resolve-dependency-spec c dep))) - (,(if (user-system-p c) 'fasl-op 'load-op) ,c) - ,@(call-next-method))) + (define-condition operation-error (error) ;; Bad, backward-compatible name + ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") + (type-of c) (error-operation c) (error-component c))))) + (define-condition compile-error (operation-error) ()) + (define-condition compile-failed (compile-error) ()) + (define-condition compile-warned (compile-error) ()) - (defmethod input-files ((o load-fasl-op) (c system)) - (when (user-system-p c) - (output-files (find-operation o 'fasl-op) c))) + (defun component-load-dependencies (component) + ;; Old deprecated name for the same thing. Please update your software. + (component-sideway-dependencies component)) - (defmethod perform ((o load-fasl-op) c) - (declare (ignorable o c)) - nil) + (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader. + (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) - (defmethod perform ((o load-fasl-op) (c system)) - (perform-lisp-load-fasl o c)) + (defgeneric operation-on-warnings (operation)) + (defgeneric operation-on-failure (operation)) + #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation)) + #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation)) + (defmethod operation-on-warnings ((o operation)) + (declare (ignorable o)) *compile-file-warnings-behaviour*) + (defmethod operation-on-failure ((o operation)) + (declare (ignorable o)) *compile-file-failure-behaviour*) + (defmethod (setf operation-on-warnings) (x (o operation)) + (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x)) + (defmethod (setf operation-on-failure) (x (o operation)) + (declare (ignorable o)) (setf *compile-file-failure-behaviour* x)) - (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) - (mark-operation-done (find-operation o 'load-op) c))) + (defun system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" + "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. +It used to expose ASDF internals with subtle differences with respect to +user expectations, that have been refactored away since. +We recommend you use ASDF:SYSTEM-SOURCE-FILE instead +for a mostly compatible replacement that we're supporting, +or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x)) -;;; -;;; PRECOMPILED FILES -;;; -;;; This component can be used to distribute ASDF systems in precompiled form. -;;; Only useful when the dependencies have also been precompiled. -;;; -(with-upgradability () - (defmethod trivial-system-p ((s system)) - (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) + (defgeneric* (traverse) (operation component &key &allow-other-keys) + (:documentation + "Generate and return a plan for performing OPERATION on COMPONENT. - (defmethod output-files (o (c compiled-file)) - (declare (ignorable o c)) - nil) - (defmethod input-files (o (c compiled-file)) - (declare (ignorable o)) - (component-pathname c)) - (defmethod perform ((o load-op) (c compiled-file)) - (perform-lisp-load-fasl o c)) - (defmethod perform ((o load-source-op) (c compiled-file)) - (perform (find-operation o 'load-op) c)) - (defmethod perform ((o load-fasl-op) (c compiled-file)) - (perform (find-operation o 'load-op) c)) - (defmethod perform (o (c compiled-file)) - (declare (ignorable o c)) - nil)) +The plan returned is a list of dotted-pairs. Each pair is the CONS +of ASDF operation object and a COMPONENT object. The pairs will be +processed in order by OPERATE.")) + (define-convenience-action-methods traverse (operation component &key)) -;;; -;;; Pre-built systems -;;; -(with-upgradability () - (defmethod trivial-system-p ((s prebuilt-system)) - (declare (ignorable s)) - t) + (defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys) + (plan-actions (apply 'make-plan plan-class o c keys)))) - (defmethod perform ((o lib-op) (c prebuilt-system)) - (declare (ignorable o c)) - nil) - (defmethod component-depends-on ((o lib-op) (c prebuilt-system)) - (declare (ignorable o c)) - nil) +;;;; ASDF-Binary-Locations compatibility +;; This remains supported for legacy user, but not recommended for new users. +(with-upgradability () + (defun enable-asdf-binary-locations-compatibility + (&key + (centralize-lisp-binaries nil) + (default-toplevel-directory + (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? + (include-per-user-information nil) + (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) + (source-to-target-mappings nil) + (file-types `(,(compile-file-type) + "build-report" + #+ecl (compile-file-type :type :object) + #+mkcl (compile-file-type :fasl-p nil) + #+clisp "lib" #+sbcl "cfasl" + #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) + #+(or clisp ecl mkcl) + (when (null map-all-source-files) + (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) + (let* ((patterns (if map-all-source-files (list *wild-file*) + (loop :for type :in file-types + :collect (make-pathname :type type :defaults *wild-file*)))) + (destination-directory + (if centralize-lisp-binaries + `(,default-toplevel-directory + ,@(when include-per-user-information + (cdr (pathname-directory (user-homedir-pathname)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) + (initialize-output-translations + `(:output-translations + ,@source-to-target-mappings + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) + ,@(loop :for pattern :in patterns + :collect `((:root ,*wild-inferiors* ,pattern) + (,@destination-directory ,pattern))) + (t t) + :ignore-inherited-configuration)))) - (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system)) - (declare (ignorable o)) - nil)) + (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) + (declare (ignorable operation-class system args)) + (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) + (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. +ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, +which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, +and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. +In case you insist on preserving your previous A-B-L configuration, but +do not know how to achieve the same effect with A-O-T, you may use function +ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; +call that function where you would otherwise have loaded and configured A-B-L.")))) -;;; -;;; PREBUILT SYSTEM CREATOR -;;; +;;; run-shell-command +;; WARNING! The function below is not just deprecated but also dysfunctional. +;; Please use asdf/run-program:run-program instead. (with-upgradability () - (defmethod output-files ((o binary-op) (s system)) - (list (make-pathname :name (component-name s) :type "asd" - :defaults (component-pathname s)))) + (defun run-shell-command (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, with +output to *VERBOSE-OUT*. Returns the shell's exit code. - (defmethod perform ((o binary-op) (s system)) - (let* ((dependencies (component-depends-on o s)) - (fasl (first (apply #'output-files (first dependencies)))) - (library (first (apply #'output-files (second dependencies)))) - (asd (first (output-files o s))) - (name (pathname-name asd)) - (name-keyword (intern (string name) (find-package :keyword)))) - (with-open-file (s asd :direction :output :if-exists :supersede - :if-does-not-exist :create) - (format s ";;; Prebuilt ASDF definition for system ~A" name) - (format s ";;; Built for ~A ~A on a ~A/~A ~A" - (lisp-implementation-type) - (lisp-implementation-version) - (software-type) - (machine-type) - (software-version)) - (let ((*package* (find-package :keyword))) - (pprint `(defsystem ,name-keyword - :class prebuilt-system - :components ((:compiled-file ,(pathname-name fasl))) - :lib ,(and library (file-namestring library))) - s))))) +PLEASE DO NOT USE. +Deprecated function, for backward-compatibility only. +Please use UIOP:RUN-PROGRAM instead." + (let ((command (apply 'format nil control-string args))) + (asdf-message "; $ ~A~%" command) + (handler-case + (progn + (run-program command :force-shell t :ignore-error-status nil :output *verbose-out*) + 0) + (subprocess-error (c) + (let ((code (subprocess-error-code c))) + (typecase code + (integer code) + (t 255)))))))) - #-(or ecl mkcl) - (defmethod perform ((o fasl-op) (c system)) - (let* ((input-files (input-files o c)) - (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'string=)) - (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=)) - (output-files (output-files o c)) - (output-file (first output-files))) - (unless input-files (format t "WTF no input-files for ~S on ~S !???" o c)) - (when input-files - (assert output-files) - (when non-fasl-files - (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S" - (implementation-type) non-fasl-files)) - (when (and (typep o 'monolithic-bundle-op) - (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o))) - (error "prologue-code and epilogue-code are not supported on ~A" - (implementation-type))) - (with-staging-pathname (output-file) - (combine-fasls fasl-files output-file))))) +(with-upgradability () + (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. + +;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED. +(with-upgradability () + (defgeneric component-property (component property)) + (defgeneric (setf component-property) (new-value component property)) - (defmethod input-files ((o load-op) (s precompiled-system)) - (declare (ignorable o)) - (bundle-output-files (find-operation o 'fasl-op) s)) + (defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) - (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) - (declare (ignorable o)) - `((load-op ,s) ,@(call-next-method)))) + (defmethod (setf component-property) (new-value (c component) property) + (let ((a (assoc property (slot-value c 'properties) :test #'equal))) + (if a + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties))))) + new-value)) +;;;; ----------------------------------------------------------------- +;;;; Source Registry Configuration, by Francois-Rene Rideau +;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 - #| ;; Example use: -(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) -(asdf:load-system :precompiled-asdf-utils) -|# +(asdf/package:define-package :asdf/source-registry + (:recycle :asdf/source-registry :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system) + (:export + #:*source-registry-parameter* #:*default-source-registries* + #:invalid-source-registry + #:source-registry-initialized-p + #:initialize-source-registry #:clear-source-registry #:*source-registry* + #:ensure-source-registry #:*source-registry-parameter* + #:*default-source-registry-exclusions* #:*source-registry-exclusions* + #:*wild-asd* #:directory-asd-files #:register-asd-directory + #:collect-asds-in-directory #:collect-sub*directories-asd-files + #:validate-source-registry-directive #:validate-source-registry-form + #:validate-source-registry-file #:validate-source-registry-directory + #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry + #:user-source-registry #:system-source-registry + #:user-source-registry-directory #:system-source-registry-directory + #:environment-source-registry #:process-source-registry + #:compute-source-registry #:flatten-source-registry + #:sysdef-source-registry-search)) +(in-package :asdf/source-registry) -#+ecl (with-upgradability () - (defmethod perform ((o bundle-op) (c system)) - (let* ((object-files (input-files o c)) - (output (output-files o c)) - (bundle (first output)) - (kind (bundle-type o))) - (create-image - bundle (append object-files (bundle-op-lisp-files o)) - :kind kind - :entry-point (component-entry-point c) - :prologue-code - (when (typep o 'monolithic-bundle-op) - (monolithic-op-prologue-code o)) - :epilogue-code - (when (typep o 'monolithic-bundle-op) - (monolithic-op-epilogue-code o)) - :build-args (bundle-op-build-args o))))) + (define-condition invalid-source-registry (invalid-configuration warning) + ((format :initform (compatfmt "~@")))) -#+mkcl -(with-upgradability () - (defmethod perform ((o lib-op) (s system)) - (apply #'compiler::build-static-library (first output) - :lisp-object-files (input-files o s) (bundle-op-build-args o))) + ;; Using ack 1.2 exclusions + (defvar *default-source-registry-exclusions* + '(".bzr" ".cdv" + ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards + ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" + "_sgbak" "autom4te.cache" "cover_db" "_build" + "debian")) ;; debian often builds stuff under the debian directory... BAD. - (defmethod perform ((o fasl-op) (s system)) - (apply #'compiler::build-bundle (second output) - :lisp-object-files (input-files o s) (bundle-op-build-args o))) + (defvar *source-registry-exclusions* *default-source-registry-exclusions*) - (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) - (declare (ignore force verbose version)) - (apply #'operate 'binary-op system args))) + (defvar *source-registry* nil + "Either NIL (for uninitialized), or an equal hash-table, mapping +system names to pathnames of .asd files") -#+(or ecl mkcl) -(with-upgradability () - (defun register-pre-built-system (name) - (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))) + (defun source-registry-initialized-p () + (typep *source-registry* 'hash-table)) -;;;; ------------------------------------------------------------------------- -;;;; Concatenate-source + (defun clear-source-registry () + "Undoes any initialization of the source registry." + (setf *source-registry* nil) + (values)) + (register-clear-configuration-hook 'clear-source-registry) -(asdf/package:define-package :asdf/concatenate-source - (:recycle :asdf/concatenate-source :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/operation - :asdf/system :asdf/find-system :asdf/defsystem - :asdf/action :asdf/lisp-action :asdf/bundle) - (:export - #:concatenate-source-op - #:load-concatenated-source-op - #:compile-concatenated-source-op - #:load-compiled-concatenated-source-op - #:monolithic-concatenate-source-op - #:monolithic-load-concatenated-source-op - #:monolithic-compile-concatenated-source-op - #:monolithic-load-compiled-concatenated-source-op - #:component-concatenated-source-file - #:concatenated-source-file)) -(in-package :asdf/concatenate-source) + (defparameter *wild-asd* + (make-pathname* :directory nil :name *wild* :type "asd" :version :newest)) -;;; -;;; Concatenate sources -;;; -(with-upgradability () - (defclass concatenate-source-op (bundle-op) - ((bundle-type :initform "lisp"))) - (defclass load-concatenated-source-op (basic-load-op operation) - ((bundle-type :initform :no-output-file))) - (defclass compile-concatenated-source-op (basic-compile-op bundle-op) - ((bundle-type :initform :fasl))) - (defclass load-compiled-concatenated-source-op (basic-load-op operation) - ((bundle-type :initform :no-output-file))) + (defun directory-asd-files (directory) + (directory-files directory *wild-asd*)) - (defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ()) - (defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ()) - (defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ()) - (defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ()) + (defun collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) - (defmethod input-files ((operation concatenate-source-op) (s system)) - (loop :with encoding = (or (component-encoding s) *default-encoding*) - :with other-encodings = '() - :with around-compile = (around-compile-hook s) - :with other-around-compile = '() - :for c :in (required-components - s :goal-operation 'compile-op - :keep-operation 'compile-op - :other-systems (operation-monolithic-p operation)) - :append - (when (typep c 'cl-source-file) - (let ((e (component-encoding c))) - (unless (equal e encoding) - (pushnew e other-encodings :test 'equal))) - (let ((a (around-compile-hook c))) - (unless (equal a around-compile) - (pushnew a other-around-compile :test 'equal))) - (input-files (make-operation 'compile-op) c)) :into inputs - :finally - (when other-encodings - (warn "~S uses encoding ~A but has sources that use these encodings: ~A" - operation encoding other-encodings)) - (when other-around-compile - (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" - operation around-compile other-around-compile)) - (return inputs))) + (defun collect-sub*directories-asd-files + (directory &key (exclude *default-source-registry-exclusions*) collect) + (collect-sub*directories + directory + (constantly t) + #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal))) + #'(lambda (dir) (collect-asds-in-directory dir collect)))) - (defmethod input-files ((o load-concatenated-source-op) (s system)) - (direct-dependency-files o s)) - (defmethod input-files ((o compile-concatenated-source-op) (s system)) - (direct-dependency-files o s)) - (defmethod output-files ((o compile-concatenated-source-op) (s system)) - (let ((input (first (input-files o s)))) - (list (compile-file-pathname input)))) - (defmethod input-files ((o load-compiled-concatenated-source-op) (s system)) - (direct-dependency-files o s)) - - (defmethod perform ((o concatenate-source-op) (s system)) - (let ((inputs (input-files o s)) - (output (output-file o s))) - (concatenate-files inputs output))) - (defmethod perform ((o load-concatenated-source-op) (s system)) - (perform-lisp-load-source o s)) - (defmethod perform ((o compile-concatenated-source-op) (s system)) - (perform-lisp-compilation o s)) - (defmethod perform ((o load-compiled-concatenated-source-op) (s system)) - (perform-lisp-load-fasl o s)) + (defun validate-source-registry-directive (directive) + (or (member directive '(:default-registry)) + (and (consp directive) + (let ((rest (rest directive))) + (case (first directive) + ((:include :directory :tree) + (and (length=n-p rest 1) + (location-designator-p (first rest)))) + ((:exclude :also-exclude) + (every #'stringp rest)) + ((:default-registry) + (null rest))))))) - (defmethod component-depends-on ((o concatenate-source-op) (s system)) - (declare (ignorable o s)) nil) - (defmethod component-depends-on ((o load-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s))) - (defmethod component-depends-on ((o compile-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((concatenate-source-op ,s))) - (defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((compile-concatenated-source-op ,s))) - - (defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system)) - (declare (ignorable o s)) nil) - (defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) - (defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) - (defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s)))) + (defun validate-source-registry-form (form &key location) + (validate-configuration-form + form :source-registry 'validate-source-registry-directive + :location location :invalid-form-reporter 'invalid-source-registry)) -;;;; ------------------------------------------------------------------------- -;;; Backward-compatible interfaces + (defun validate-source-registry-file (file) + (validate-configuration-file + file 'validate-source-registry-form :description "a source registry")) -(asdf/package:define-package :asdf/backward-interface - (:recycle :asdf/backward-interface :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action - :asdf/lisp-build :asdf/operate :asdf/output-translations) - (:export - #:*asdf-verbose* - #:operation-error #:compile-error #:compile-failed #:compile-warned - #:error-component #:error-operation - #:component-load-dependencies - #:enable-asdf-binary-locations-compatibility - #:operation-forced - #:operation-on-failure - #:operation-on-warnings - #:component-property - #:run-shell-command - #:system-definition-pathname)) -(in-package :asdf/backward-interface) + (defun validate-source-registry-directory (directory) + (validate-configuration-directory + directory :source-registry 'validate-source-registry-directive + :invalid-form-reporter 'invalid-source-registry)) -(with-upgradability () - (define-condition operation-error (error) ;; Bad, backward-compatible name - ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel - ((component :reader error-component :initarg :component) - (operation :reader error-operation :initarg :operation)) - (:report (lambda (c s) - (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") - (type-of c) (error-operation c) (error-component c))))) - (define-condition compile-error (operation-error) ()) - (define-condition compile-failed (compile-error) ()) - (define-condition compile-warned (compile-error) ()) + (defun parse-source-registry-string (string &key location) + (cond + ((or (null string) (equal string "")) + '(:source-registry :inherit-configuration)) + ((not (stringp string)) + (error (compatfmt "~@") 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 "~@") string)) + dir)) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error (compatfmt "~@") + 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 "~@") + 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. @@ -9061,25 +9584,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 #:make-plan #:perform-plan #:sequential-plan #:system-definition-pathname #:with-system-definitions #:search-for-system-definition #:find-component #:component-find-path #:compile-system #:load-system #:load-systems #:require-system #:test-system #:clear-system - #:operation #:upward-operation #:downward-operation #:make-operation + #:operation #:make-operation #:find-operation + #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation #:build-system #:build-op #:load-op #:prepare-op #:compile-op #:prepare-source-op #:load-source-op #:test-op #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type #:hostname #:input-files #:output-files #:output-file #:perform - #:operation-done-p #:explain #:action-description #:component-sibling-dependencies + #:operation-done-p #:explain #:action-description #:component-sideway-dependencies #:needed-in-image-p ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT. #:component-load-dependencies #:run-shell-command ; deprecated, do not use - #:bundle-op #:precompiled-system #:compiled-file #:bundle-system + #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system #+ecl #:make-build - #:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op + #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op + #:lib-op #:dll-op #:binary-op #:program-op + #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op #:concatenate-source-op #:load-concatenated-source-op #:compile-concatenated-source-op @@ -9090,11 +9616,13 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." #:monolithic-load-compiled-concatenated-source-op #:operation-monolithic-p #:required-components + #:component-loaded-p #:component #:parent-component #:child-component #:system #:module #:file-component #:source-file #:c-source-file #:java-source-file #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp - #:static-file #:doc-file #:html-file :text-file + #:static-file #:doc-file #:html-file + #:file-type #:source-file-type #:component-children ; component accessors @@ -9112,6 +9640,7 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." #:module-components ; backward-compatibility #:operation-on-warnings #:operation-on-failure ; backward-compatibility #:component-property ; backward-compatibility + #:traverse ; backward-compatibility #:system-description #:system-long-description @@ -9123,8 +9652,8 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." #:system-source-directory #:system-relative-pathname #:system-homepage + #:system-mailto #:system-bug-tracker - #:system-developers-email #:system-long-name #:system-source-control #:map-systems @@ -9153,7 +9682,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 @@ -9175,7 +9704,7 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." #:apply-output-translations #:compile-file* #:compile-file-pathname* - #:*warnings-file-type* + #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check #:enable-asdf-binary-locations-compatibility #:*default-source-registries* #:*source-registry-parameter* @@ -9187,6 +9716,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 @@ -9238,11 +9768,18 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* (loop :for f :in #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* - :unless (eq f 'module-provide-asdf) - :collect #'(lambda (name) - (let ((l (multiple-value-list (funcall f name)))) - (and (first l) (register-pre-built-system (coerce-name name))) - (values-list l))))))) + :collect + (if (eq f 'module-provide-asdf) f + #'(lambda (name) + (let ((l (multiple-value-list (funcall f name)))) + (and (first l) (register-pre-built-system (coerce-name name))) + (values-list l)))))))) + +#+cmu +(with-upgradability () + (defun herald-asdf (stream) + (format stream " ASDF ~A" (asdf-version))) + (setf (getf ext:*herald-items* :asdf) `(herald-asdf))) ;;;; Done! @@ -9261,6 +9798,3 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." (asdf-message ";; ASDF, version ~a~%" (asdf-version))) -;;; Local Variables: -;;; mode: lisp -;;; End: