[armedbear-cvs] r14424 - trunk/abcl/src/org/armedbear/lisp
mevenson at common-lisp.net
mevenson at common-lisp.net
Wed Mar 6 09:58:27 UTC 2013
Author: mevenson
Date: Wed Mar 6 01:58:26 2013
New Revision: 14424
Log:
Update to asdf-2.32.
Modified:
trunk/abcl/src/org/armedbear/lisp/asdf.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/asdf.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/asdf.lisp Tue Mar 5 13:07:11 2013 (r14423)
+++ trunk/abcl/src/org/armedbear/lisp/asdf.lisp Wed Mar 6 01:58:26 2013 (r14424)
@@ -1,5 +1,5 @@
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
-;;; This is ASDF 2.30: Another System Definition Facility.
+;;; This is ASDF 2.32: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel at common-lisp.net>.
@@ -71,8 +71,7 @@
(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 #+clozure 2.27
- #+cmu 2.018 #+ecl 2.21 #+xcl 2.27))
+ (or #+abcl 2.25 #+cmu 2.018 2.27)))
(rename-package :asdf away)
(when *load-verbose*
(format t "; Renamed old ~A package away to ~A~%" :asdf away))))))
@@ -82,28 +81,28 @@
;;
;; 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
@@ -140,6 +139,12 @@
(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))
@@ -258,8 +263,8 @@
(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)
@@ -284,18 +289,18 @@
(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)
@@ -308,7 +313,7 @@
(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)
@@ -435,7 +440,34 @@
(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)
@@ -446,27 +478,18 @@
(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)
@@ -484,7 +507,7 @@
(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))
@@ -557,7 +580,7 @@
(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)
@@ -591,6 +614,7 @@
(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
@@ -604,7 +628,7 @@
(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))
@@ -612,7 +636,8 @@
(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)
@@ -694,9 +719,9 @@
(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)))
@@ -784,6 +809,9 @@
(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
@@ -792,11 +820,11 @@
;;; 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
@@ -808,7 +836,7 @@
#+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.")
@@ -859,13 +887,13 @@
#+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)
@@ -933,24 +961,33 @@
;;;; 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))))))))
@@ -959,20 +996,21 @@
(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:
@@ -994,7 +1032,7 @@
#:call-with-muffled-conditions #:with-muffled-conditions
#: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,
@@ -1056,7 +1094,7 @@
(with-upgradability ()
(defvar *asdf-debug-utility*
'(or (ignore-errors
- (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib/debug.lisp"))
+ (symbol-call :asdf :system-relative-pathname :asdf "contrib/debug.lisp"))
(merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
"form that evaluates to the pathname to your favorite debugging utilities")
@@ -1405,9 +1443,10 @@
;;;; ---------------------------------------------------------------------------
;;;; 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
@@ -1418,7 +1457,7 @@
;; 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 ()
@@ -1622,7 +1661,7 @@
#+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)
@@ -1729,9 +1768,10 @@
;; 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
@@ -1763,7 +1803,7 @@
#: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
@@ -2393,9 +2433,10 @@
;;;; -------------------------------------------------------------------------
;;;; 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
@@ -2416,7 +2457,7 @@
#:ensure-all-directories-exist
#:rename-file-overwriting-target
#:delete-file-if-exists))
-(in-package :asdf/filesystem)
+(in-package :uiop/filesystem)
;;; Native namestrings, as seen by the operating system calls rather than Lisp
(with-upgradability ()
@@ -2872,15 +2913,16 @@
;;;; ---------------------------------------------------------------------------
;;;; 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
#:finish-outputs #:format! #:safe-format!
@@ -2895,7 +2937,7 @@
#: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)
@@ -2914,10 +2956,16 @@
;;; 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.")
@@ -2975,7 +3023,11 @@
(*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
@@ -3325,9 +3377,10 @@
;;;; -------------------------------------------------------------------------
;;;; 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
@@ -3342,7 +3395,7 @@
#:call-image-restore-hook #:call-image-dump-hook
#:restore-image #:dump-image #:create-image
))
-(in-package :asdf/image)
+(in-package :uiop/image)
(with-upgradability ()
(defvar *lisp-interaction* t
@@ -3653,9 +3706,10 @@
;;;; -------------------------------------------------------------------------
;;;; 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
@@ -3668,7 +3722,7 @@
#: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 -----
@@ -4042,10 +4096,11 @@
;;;; -------------------------------------------------------------------------
;;;; 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*
@@ -4063,12 +4118,13 @@
#:reify-deferred-warnings #:reify-undefined-warning #: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*
@@ -4233,7 +4289,7 @@
((or number character simple-string pathname) 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)
@@ -4255,15 +4311,21 @@
(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)
- (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
+ (first (second function-name))))) ;; defmethod: keep gf name, drop method specializers
+ (list name)))
(defun unreify-function-name (function-name)
- (if (and (consp function-name) (eq (first function-name) 'setf))
- (let ((setfed (second function-name)))
- (gethash setfed ccl::%setf-function-names%))
- function-name))
+ function-name)
(defun reify-deferred-warning (deferred-warning)
(with-accessors ((warning-type ccl::compiler-warning-warning-type)
(args ccl::compiler-warning-args)
@@ -4271,8 +4333,11 @@
(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) formals)))))
+ :args (destructuring-bind (fun formals env) args
+ (declare (ignorable env))
+ (list (unsymbolify-function-name fun)
+ (mapcar (constantly nil) formals)
+ nil)))))
(defun unreify-deferred-warning (reified-deferred-warning)
(destructuring-bind (&key warning-type function-name source-note args)
reified-deferred-warning
@@ -4282,7 +4347,7 @@
:source-note (unreify-source-note source-note)
:warning-type warning-type
:args (destructuring-bind (fun . formals) args
- (cons (unreify-function-name fun) formals))))))
+ (cons (symbolify-function-name fun) formals))))))
#+(or cmu scl)
(defun reify-undefined-warning (warning)
;; Extracting undefined-warnings from the compilation-unit
@@ -4478,9 +4543,15 @@
((: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)
@@ -4502,7 +4573,7 @@
(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))
@@ -4711,10 +4782,11 @@
;;;; ---------------------------------------------------------------------------
;;;; 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)
(:export
#:get-folder-path
#:user-configuration-directories #:system-configuration-directories
@@ -4726,7 +4798,7 @@
#:*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 ()
@@ -5008,17 +5080,18 @@
;;;; -------------------------------------------------------------------------
;;; 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.
@@ -5048,19 +5121,19 @@
;;;; ---------------------------------------------------------------------------
;;;; 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
@@ -5115,7 +5188,7 @@
;; "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.30")
+ (asdf-version "2.32")
(existing-version (asdf-version)))
(setf *asdf-version* asdf-version)
(when (and existing-version (not (equal asdf-version existing-version)))
@@ -5182,16 +5255,11 @@
(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))))
@@ -5200,7 +5268,7 @@
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))
@@ -5219,7 +5287,8 @@
#:file-component
#:source-file #:c-source-file #:java-source-file
#:static-file #:doc-file #:html-file
- #:source-file-type ;; backward-compatibility
+ #:file-type
+ #:source-file-type #:source-file-explicit-type ;; backward-compatibility
#:component-in-order-to #:component-sibling-dependencies
#:component-if-feature #:around-compile-hook
#:component-description #:component-long-description
@@ -5350,7 +5419,8 @@
(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)
@@ -5627,13 +5697,13 @@
(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 () , at body)))
@@ -5666,7 +5736,7 @@
: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
@@ -5728,6 +5798,9 @@
;; 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
@@ -5891,6 +5964,25 @@
(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
@@ -5912,6 +6004,12 @@
(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 () , at body)))
@@ -5940,6 +6038,46 @@
(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
@@ -5957,12 +6095,20 @@
(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))
@@ -5988,7 +6134,7 @@
(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
@@ -6002,21 +6148,7 @@
(reinitialize-source-registry-and-retry ()
:report (lambda (s)
(format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
- (initialize-source-registry))))))
-
- (defvar *preloaded-systems* (make-hash-table :test 'equal))
-
- (defun sysdef-preloaded-system-search (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
@@ -6152,15 +6284,13 @@
;;;; 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.
#:build-op ;; THE generic operation
- #:*operations*
- #:make-operation
- #:find-operation))
+ #:*operations* #:make-operation #:find-operation #:feature))
(in-package :asdf/operation)
;;; Operation Classes
@@ -6202,7 +6332,10 @@
(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)
@@ -6226,7 +6359,7 @@
#: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)
@@ -6305,17 +6438,19 @@
"Returns a list of dependencies needed by the component to perform
the operation. A dependency has one of the following forms:
- (<operation> <component>*), where <operation> is a class
- designator and each <component> is a component
- designator, which means that the component depends on
+ (<operation> <component>*), where <operation> is an operation designator
+ with respect to FIND-OPERATION in the context of the OPERATION argument,
+ and each <component> is a component designator with respect to
+ FIND-COMPONENT in the context of the COMPONENT argument,
+ and means that the component depends on
<operation> having been performed on each <component>; or
(FEATURE <feature>), which means that the component depends
- on <feature>'s presence in *FEATURES*.
+ on the <feature> expression satisfying FEATUREP.
+ (This is DEPRECATED -- use :IF-FEATURE instead.)
Methods specialized on subclasses of existing component types
- should usually append the results of CALL-NEXT-METHOD to the
- list."))
+ should usually append the results of CALL-NEXT-METHOD to the list."))
(defgeneric component-self-dependencies (operation component))
(define-convenience-action-methods component-depends-on (operation component))
(define-convenience-action-methods component-self-dependencies (operation component))
@@ -6520,7 +6655,8 @@
(: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
@@ -6621,7 +6757,7 @@
"~/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
@@ -6674,7 +6810,7 @@
(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 ()
@@ -6771,6 +6907,7 @@
(declare (ignorable o))
`((load-op ,c) ,@(call-next-method))))
+
;;;; -------------------------------------------------------------------------
;;;; Plan
@@ -6945,11 +7082,12 @@
(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
@@ -7230,30 +7368,9 @@
(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).
@@ -7271,30 +7388,60 @@
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 &allow-other-keys)
+ (let ((plan (apply 'traverse operation component keys)))
+ (perform-plan plan)
+ (values operation plan)))
(defun oos (operation component &rest args &key &allow-other-keys)
(apply 'operate operation component args))
@@ -7354,18 +7501,54 @@
(defun require-system (s &rest keys &key &allow-other-keys)
(apply 'load-system s :force-not (already-loaded-systems) keys))
+ (defvar *modules-being-required* nil)
+
+ (defclass require-system (system)
+ ((module :initarg :module :initform nil :accessor required-module)))
+
+ (defmethod perform ((o compile-op) (c require-system))
+ (declare (ignorable o c))
+ nil)
+
+ (defmethod perform ((o load-op) (s require-system))
+ (declare (ignorable o))
+ (let* ((module (or (required-module s) (coerce-name s)))
+ (*modules-being-required* (cons module *modules-being-required*)))
+ (assert (null (component-children s)))
+ (require module)))
+
+ (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
+ (declare (ignorable component combinator))
+ (unless (length=n-p arguments 1)
+ (error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes only one argument~@:>")
+ (cons combinator arguments) component combinator))
+ (let* ((module (car arguments))
+ (name (string-downcase module))
+ (system (find-system name nil)))
+ (assert module)
+ ;;(unless (typep system '(or null require-system))
+ ;; (warn "~S depends on ~S but ~S is registered as a ~S"
+ ;; component (cons combinator arguments) module (type-of system)))
+ (or system (let ((system (make-instance 'require-system :name name)))
+ (register-system system)
+ system))))
+
(defun module-provide-asdf (name)
- (handler-bind
- ((style-warning #'muffle-warning)
- (missing-component (constantly nil))
- (error #'(lambda (e)
- (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
- name e))))
- (let ((*verbose-out* (make-broadcast-stream))
- (system (find-system (string-downcase name) nil)))
- (when system
- (require-system system :verbose nil)
- t)))))
+ (let ((module (string-downcase name)))
+ (unless (member module *modules-being-required* :test 'equal)
+ (let ((*modules-being-required* (cons module *modules-being-required*))
+ #+sbcl (sb-impl::*requiring* (remove module sb-impl::*requiring* :test 'equal)))
+ (handler-bind
+ ((style-warning #'muffle-warning)
+ (missing-component (constantly nil))
+ (error #'(lambda (e)
+ (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
+ name e))))
+ (let ((*verbose-out* (make-broadcast-stream)))
+ (let ((system (find-system module nil)))
+ (when system
+ (require-system system :verbose nil)
+ t)))))))))
;;;; Some upgrade magic
@@ -7645,27 +7828,27 @@
(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)))))
+ (etypecase path
+ (logical-pathname
+ path)
+ ((or pathname string)
+ (ensure-output-translations)
+ (loop* :with p = (resolve-symlinks* path)
+ :for (source destination) :in (car *output-translations*)
+ :for root = (when (or (eq source t)
+ (and (pathnamep source)
+ (not (absolute-pathname-p source))))
+ (pathname-root p))
+ :for absolute-source = (cond
+ ((eq source t) (wilden root))
+ (root (merge-pathnames* source root))
+ (t source))
+ :when (or (eq source t) (pathname-match-p p absolute-source))
+ :return (translate-pathname* p absolute-source destination root source)
+ :finally (return p)))))
;; Hook into asdf/driver's output-translation mechanism
+ #-cormanlisp
(setf *output-translation-function* 'apply-output-translations)
#+abcl
@@ -8155,8 +8338,9 @@
(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)))
@@ -8174,7 +8358,7 @@
(define-condition duplicate-names (system-definition-error)
((name :initarg :name :reader duplicate-names-name))
(:report (lambda (c s)
- (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
+ (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
(duplicate-names-name c)))))
(defun sysdef-error-component (msg type name value)
@@ -8194,18 +8378,34 @@
(sysdef-error-component ":components must be NIL or a list of components."
type name components)))
- (defun normalize-version (form pathname)
- (etypecase form
- ((or string null) form)
- (real
- (asdf-message "Invalid use of real number ~D as :version in ~S. Substituting a string."
- form pathname)
- (format nil "~D" form)) ;; 1.0 is "1.0"
- (cons
- (ecase (first form)
- ((:read-file-form)
- (destructuring-bind (subpath &key (at 0)) (rest form)
- (safe-read-file-form (subpathname pathname subpath) :at at))))))))
+ (defun* (normalize-version) (form &key pathname component parent)
+ (labels ((invalid (&optional (continuation "using NIL instead"))
+ (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
+ form component parent pathname continuation))
+ (invalid-parse (control &rest args)
+ (unless (builtin-system-p (find-component parent component))
+ (apply 'warn control args)
+ (invalid))))
+ (if-let (v (typecase form
+ ((or string null) form)
+ (real
+ (invalid "Substituting a string")
+ (format nil "~D" form)) ;; 1.0 becomes "1.0"
+ (cons
+ (case (first form)
+ ((:read-file-form)
+ (destructuring-bind (subpath &key (at 0)) (rest form)
+ (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user)))
+ ((:read-file-line)
+ (destructuring-bind (subpath &key (at 0)) (rest form)
+ (read-file-lines (subpathname pathname subpath) :at at)))
+ (otherwise
+ (invalid))))
+ (t
+ (invalid))))
+ (if-let (pv (parse-version v #'invalid-parse))
+ (unparse-version pv)
+ (invalid))))))
;;; Main parsing function
@@ -8218,7 +8418,7 @@
;; 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))
@@ -8249,13 +8449,10 @@
(apply 'reinitialize-instance component args)
(setf component (apply 'make-instance (class-for-type parent type) args)))
(component-pathname component) ; eagerly compute the absolute pathname
- (let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous
+ (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
(when (and (typep component 'system) (not bspp))
- (setf (builtin-system-p component) (lisp-implementation-pathname-p sysdir)))
- (setf version (normalize-version version sysdir)))
- (when (and versionp version (not (parse-version version nil)))
- (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
- version name parent))
+ (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
+ (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
;; A better fix is required.
(setf (slot-value component 'version) version)
@@ -8299,6 +8496,7 @@
(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.
@@ -8324,7 +8522,7 @@
(: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-op #:monolithic-bundle-op #:bundlable-file-p #:direct-dependency-files
#:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
#:program-op
#:compiled-file #:precompiled-system #:prebuilt-system
@@ -8458,7 +8656,7 @@
(unless name-suffix-p
(setf (slot-value instance 'name-suffix)
(unless (typep instance 'program-op)
- (if (operation-monolithic-p instance) ".all-systems" #-ecl ".system"))))
+ (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
@@ -8483,10 +8681,10 @@
(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)))))
+ (or #+ecl (or (equalp type (compile-file-type :type :object))
+ (equalp type (compile-file-type :type :static-library)))
+ #+mkcl (equalp type (compile-file-type :fasl-p nil))
+ #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
(defgeneric* (trivial-system-p) (component))
@@ -8654,7 +8852,7 @@
(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))
+ (defmethod perform ((o operation) (c compiled-file))
(declare (ignorable o c))
nil))
@@ -8713,8 +8911,8 @@
#-(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=))
+ (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
+ (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
(output-files (output-files o c))
(output-file (first output-files)))
(unless input-files (format t "WTF no input-files for ~S on ~S !???" o c))
@@ -8734,6 +8932,9 @@
(declare (ignorable o))
(bundle-output-files (find-operation o 'fasl-op) s))
+ (defmethod perform ((o load-op) (s precompiled-system))
+ (perform-lisp-load-fasl o s))
+
(defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
(declare (ignorable o))
`((load-op ,s) ,@(call-next-method))))
@@ -9091,11 +9292,13 @@
#: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
+ #:file-type
#:source-file-type
#:component-children ; component accessors
@@ -9176,7 +9379,7 @@
#: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*
@@ -9239,11 +9442,12 @@
(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))))))))
;;;; Done!
@@ -9262,6 +9466,3 @@
(asdf-message ";; ASDF, version ~a~%" (asdf-version)))
-;;; Local Variables:
-;;; mode: lisp
-;;; End:
More information about the armedbear-cvs
mailing list