Changeset 15754


Ignore:
Timestamp:
Mar 6, 2013, 1:07:31 AM (7 years ago)
Author:
rme
Message:

Merge ASDF 2.32 here from trunk.

Location:
release/1.9/source
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/1.9/source

  • release/1.9/source/tools/asdf.lisp

    r15743 r15754  
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
    2 ;;; This is ASDF 2.30: Another System Definition Facility.
     2;;; This is ASDF 2.32: Another System Definition Facility.
    33;;;
    44;;; Feedback, bug reports, and patches are all welcome:
     
    7272           (away (format nil "~A-~A" :asdf existing-version)))
    7373      (when (and existing-version (< existing-version-number
    74                                      #+abcl 2.25 #+clisp 2.27 #+clozure 2.27
    75                                      #+cmu 2.018 #+ecl 2.21 #+xcl 2.27))
     74                                     (or #+abcl 2.25 #+cmu 2.018 2.27)))
    7675        (rename-package :asdf away)
    7776        (when *load-verbose*
     
    8382;; See https://bugs.launchpad.net/asdf/+bug/485687
    8483;;
    85 ;; CAUTION: we must handle the first few packages specially for hot-upgrade.
    86 ;; asdf/package will be frozen as of ASDF 3
    87 ;; to forever export the same exact symbols.
    88 ;; Any other symbol must be import-from'ed
    89 ;; and reexported in a different package
    90 ;; (alternatively the package may be dropped & replaced by one with a new name).
    91 
    92 (defpackage :asdf/package
     84
     85(defpackage :uiop/package
     86  ;; CAUTION: we must handle the first few packages specially for hot-upgrade.
     87  ;; This package definition MUST NOT change unless its name too changes;
     88  ;; if/when it changes, don't forget to add new functions missing from below.
     89  ;; Until then, asdf/package is frozen to forever
     90  ;; import and export the same exact symbols as for ASDF 2.27.
     91  ;; Any other symbol must be import-from'ed and re-export'ed in a different package.
    9392  (:use :common-lisp)
    9493  (:export
    9594   #:find-package* #:find-symbol* #:symbol-call
    96    #:intern* #:unintern* #:export* #:make-symbol*
    97    #:symbol-shadowing-p #:home-package-p #:rehome-symbol
     95   #:intern* #:export* #:import* #:shadowing-import* #:shadow* #:make-symbol* #:unintern*
     96   #:symbol-shadowing-p #:home-package-p
    9897   #:symbol-package-name #:standard-common-lisp-symbol-p
    9998   #:reify-package #:unreify-package #:reify-symbol #:unreify-symbol
    100    #:nuke-symbol-in-package #:nuke-symbol
     99   #:nuke-symbol-in-package #:nuke-symbol #:rehome-symbol
    101100   #:ensure-package-unused #:delete-package*
    102    #:fresh-package-name #:rename-package-away #:package-names #:packages-from-names
     101   #:package-names #:packages-from-names #:fresh-package-name #:rename-package-away
    103102   #:package-definition-form #:parse-define-package-form
    104103   #:ensure-package #:define-package))
    105104
    106 (in-package :asdf/package)
     105(in-package :uiop/package)
    107106
    108107;;;; General purpose package utilities
     
    141140           (symbol (intern* name package)))
    142141      (export (or symbol (list symbol)) package)))
     142  (defun import* (symbol package-designator)
     143    (import (or symbol (list symbol)) (find-package* package-designator)))
     144  (defun shadowing-import* (symbol package-designator)
     145    (shadowing-import (or symbol (list symbol)) (find-package* package-designator)))
     146  (defun shadow* (name package-designator)
     147    (shadow (string name) (find-package* package-designator)))
    143148  (defun make-symbol* (name)
    144149    (etypecase name
     
    259264        (when (and (member stat '(:internal :external)) (eq symbol sym))
    260265          (if (symbol-shadowing-p symbol package)
    261               (shadowing-import (get-dummy-symbol symbol) package)
    262               (unintern symbol package))))))
     266              (shadowing-import* (get-dummy-symbol symbol) package)
     267              (unintern* symbol package))))))
    263268  (defun nuke-symbol (symbol &optional (packages (list-all-packages)))
    264269    #+(or clisp clozure)
     
    285290            (when old-package
    286291              (if shadowing
    287                   (shadowing-import shadowing old-package))
    288               (unintern symbol old-package))
     292                  (shadowing-import* shadowing old-package))
     293              (unintern* symbol old-package))
    289294            (cond
    290295              (overwritten-symbol-shadowing-p
    291                (shadowing-import symbol package))
     296               (shadowing-import* symbol package))
    292297              (t
    293298               (when overwritten-symbol-status
    294                  (unintern overwritten-symbol package))
    295                (import symbol package)))
     299                 (unintern* overwritten-symbol package))
     300               (import* symbol package)))
    296301            (if shadowing
    297                 (shadowing-import symbol old-package)
    298                 (import symbol old-package))
     302                (shadowing-import* symbol old-package)
     303                (import* symbol old-package))
    299304            #+(or clisp clozure)
    300305            (multiple-value-bind (setf-symbol kind)
     
    309314                   (symbol-name new-setf-symbol) (symbol-package-name new-setf-symbol))
    310315                  (when (symbol-package setf-symbol)
    311                     (unintern setf-symbol (symbol-package setf-symbol)))
     316                    (unintern* setf-symbol (symbol-package setf-symbol)))
    312317                  (setf (fdefinition new-setf-symbol) setf-function)
    313318                  (set-setf-function-symbol new-setf-symbol symbol kind))))
     
    436441              (package-name to-package) status
    437442              (and status (or (home-package-p existing to-package) (symbol-package-name existing)))))
    438            (shadowing-import import-me to-package))))))
     443           (shadowing-import* import-me to-package))))))
     444  (defun ensure-imported (import-me into-package &optional from-package)
     445    (check-type import-me symbol)
     446    (check-type into-package package)
     447    (check-type from-package (or null package))
     448    (let ((name (symbol-name import-me)))
     449      (multiple-value-bind (existing status) (find-symbol name into-package)
     450        (cond
     451          ((not status)
     452           (import* import-me into-package))
     453          ((eq import-me existing))
     454          (t
     455           (let ((shadowing-p (symbol-shadowing-p existing into-package)))
     456             (note-package-fishiness
     457              :ensure-imported name
     458              (and from-package (package-name from-package))
     459              (or (home-package-p import-me from-package) (symbol-package-name import-me))
     460              (package-name into-package)
     461              status
     462              (and status (or (home-package-p existing into-package) (symbol-package-name existing)))
     463              shadowing-p)
     464             (cond
     465               ((or shadowing-p (eq status :inherited))
     466                (shadowing-import* import-me into-package))
     467               (t
     468                (unintern* existing into-package)
     469                (import* import-me into-package))))))))
     470    (values))
    439471  (defun ensure-import (name to-package from-package shadowed imported)
    440472    (check-type name string)
     
    447479        (note-package-fishiness
    448480         :import-uninterned name (package-name from-package) (package-name to-package))
    449         (setf import-me (intern name from-package)))
     481        (setf import-me (intern* name from-package)))
    450482      (multiple-value-bind (existing status) (find-symbol name to-package)
    451483        (cond
    452           ((gethash name imported)
    453            (unless (eq import-me existing)
     484          ((and imported (gethash name imported))
     485           (unless (and status (eq import-me existing))
    454486             (error "Can't import ~S from both ~S and ~S"
    455487                    name (package-name (symbol-package existing)) (package-name from-package))))
     
    457489           (error "Can't both shadow ~S and import it from ~S" name (package-name from-package)))
    458490          (t
    459            (setf (gethash name imported) t)
    460            (unless (and status (eq import-me existing))
    461              (when status
    462                (note-package-fishiness
    463                 :import name
    464                 (package-name from-package)
    465                 (or (home-package-p import-me from-package) (symbol-package-name import-me))
    466                 (package-name to-package) status
    467                 (and status (or (home-package-p existing to-package) (symbol-package-name existing))))
    468                (unintern* existing to-package))
    469              (import import-me to-package)))))))
     491           (setf (gethash name imported) t))))
     492      (ensure-imported import-me to-package from-package)))
    470493  (defun ensure-inherited (name symbol to-package from-package mixp shadowed imported inherited)
    471494    (check-type name string)
     
    485508           :import-uninterned name
    486509           (package-name from-package) (package-name to-package) mixp)
    487           (import symbol from-package)
     510          (import* symbol from-package)
    488511          (setf sp (package-name from-package)))
    489512        (cond
     
    558581    (check-type sym symbol)
    559582    (check-type recycle list)
    560     (member (symbol-package sym) recycle))
     583    (and (member (symbol-package sym) recycle) t))
    561584  (defun ensure-symbol (name package intern recycle shadowed imported inherited exported)
    562585    (check-type name string)
     
    592615    (check-type to-package package)
    593616    (check-type recycle list)
     617    (assert (equal name (symbol-name symbol)))
    594618    (multiple-value-bind (existing status) (find-symbol name to-package)
    595619      (unless (and status (eq symbol existing))
     
    605629                         status shadowing)
    606630                        (if (or (eq status :inherited) shadowing)
    607                             (shadowing-import symbol to-package)
     631                            (shadowing-import* symbol to-package)
    608632                            (unintern existing to-package))
    609633                        t)))))
     
    613637    (dolist (to-package (package-used-by-list from-package))
    614638      (ensure-exported-to-user name symbol to-package recycle))
    615     (import symbol from-package)
     639    (unless (eq from-package (symbol-package symbol))
     640      (ensure-imported symbol from-package))
    616641    (export* name from-package))
    617642  (defun ensure-export (name from-package &optional recycle)
     
    695720                    :shadow-imported (package-name package) name
    696721                    (symbol-package-name existing) status shadowing)
    697                    (shadowing-import dummy package)
    698                    (import dummy package)))))))
    699         (shadow name package))
     722                   (shadowing-import* dummy package)
     723                   (import* dummy package)))))))
     724        (shadow* name package))
    700725      (loop :for (p . syms) :in shadowing-import-from
    701726            :for pp = (find-package* p) :do
     
    785810    (t
    786811     (pushnew :gcl2.7 *features*))))
     812
     813;; Compatibility with whoever calls asdf/package
     814(define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package))
    787815;;;; -------------------------------------------------------------------------
    788816;;;; Handle compatibility with multiple implementations.
     
    793821;;; from this package only common-lisp symbols are exported.
    794822
    795 (asdf/package:define-package :asdf/common-lisp
    796   (:nicknames :asdf/cl)
    797   (:use #-genera :common-lisp #+genera :future-common-lisp :asdf/package)
     823(uiop/package:define-package :uiop/common-lisp
     824  (:nicknames :uoip/cl :asdf/common-lisp :asdf/cl)
     825  (:use #-genera :common-lisp #+genera :future-common-lisp :uiop/package)
    798826  (:reexport :common-lisp)
    799   (:recycle :asdf/common-lisp :asdf)
     827  (:recycle :uiop/common-lisp :uoip/cl :asdf/common-lisp :asdf/cl :asdf)
    800828  #+allegro (:intern #:*acl-warn-save*)
    801829  #+cormanlisp (:shadow #:user-homedir-pathname)
     
    809837  #+genera (:export #:boolean #:ensure-directories-exist)
    810838  #+mcl (:shadow #:user-homedir-pathname))
    811 (in-package :asdf/common-lisp)
     839(in-package :uiop/common-lisp)
    812840
    813841#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
     
    860888#+gcl2.6
    861889(eval-when (:compile-toplevel :load-toplevel :execute)
    862   (shadow 'type-of :asdf/common-lisp)
    863   (shadowing-import 'system:*load-pathname* :asdf/common-lisp))
     890  (shadow 'type-of :uiop/common-lisp)
     891  (shadowing-import 'system:*load-pathname* :uiop/common-lisp))
    864892
    865893#+gcl2.6
    866894(eval-when (:compile-toplevel :load-toplevel :execute)
    867   (export 'type-of :asdf/common-lisp)
    868   (export 'system:*load-pathname* :asdf/common-lisp))
     895  (export 'type-of :uiop/common-lisp)
     896  (export 'system:*load-pathname* :uiop/common-lisp))
    869897
    870898#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations.
     
    934962;;;; compatfmt: avoid fancy format directives when unsupported
    935963(eval-when (:load-toplevel :compile-toplevel :execute)
    936   (defun remove-substrings (substrings string)
     964  (defun frob-substrings (string substrings &optional frob)
     965    (declare (optimize (speed 0) (safety 3) (debug 3)))
    937966    (let ((length (length string)) (stream nil))
    938       (labels ((emit (start end)
    939                  (when (and (zerop start) (= end length))
    940                    (return-from remove-substrings string))
     967      (labels ((emit-string (x &optional (start 0) (end (length x)))
    941968                 (when (< start end)
    942969                   (unless stream (setf stream (make-string-output-stream)))
    943                    (write-string string stream :start start :end end)))
     970                   (write-string x stream :start start :end end)))
     971               (emit-substring (start end)
     972                 (when (and (zerop start) (= end length))
     973                   (return-from frob-substrings string))
     974                 (emit-string string start end))
    944975               (recurse (substrings start end)
    945976                 (cond
    946977                   ((>= start end))
    947                    ((null substrings) (emit start end))
    948                    (t (let* ((sub (first substrings))
     978                   ((null substrings) (emit-substring start end))
     979                   (t (let* ((sub-spec (first substrings))
     980                             (sub (if (consp sub-spec) (car sub-spec) sub-spec))
     981                             (fun (if (consp sub-spec) (cdr sub-spec) frob))
    949982                             (found (search sub string :start2 start :end2 end))
    950983                             (more (rest substrings)))
     
    952985                          (found
    953986                           (recurse more start found)
     987                           (etypecase fun
     988                             (null)
     989                             (string (emit-string fun))
     990                             (function (funcall fun sub #'emit-string)))
    954991                           (recurse substrings (+ found (length sub)) end))
    955992                          (t
     
    960997  (defmacro compatfmt (format)
    961998    #+(or gcl genera)
    962     (remove-substrings `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")) format)
     999    (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>")))
    9631000    #-(or gcl genera) format))
    9641001
     
    9671004;;;; General Purpose Utilities for ASDF
    9681005
    969 (asdf/package:define-package :asdf/utility
    970   (:recycle :asdf/utility :asdf)
    971   (:use :asdf/common-lisp :asdf/package)
     1006(uiop/package:define-package :uiop/utility
     1007  (:nicknames :asdf/utility)
     1008  (:recycle :uiop/utility :asdf/utility :asdf)
     1009  (:use :uiop/common-lisp :uiop/package)
    9721010  ;; import and reexport a few things defined in :asdf/common-lisp
    973   (:import-from :asdf/common-lisp #:compatfmt #:loop* #:remove-substrings
     1011  (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings
    9741012   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
    975   (:export #:compatfmt #:loop* #:remove-substrings #:compatfmt
     1013  (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt
    9761014   #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix)
    9771015  (:export
     
    9951033   #:lexicographic< #:lexicographic<=
    9961034   #:parse-version #:unparse-version #:version< #:version<= #:version-compatible-p)) ;; version
    997 (in-package :asdf/utility)
     1035(in-package :uiop/utility)
    9981036
    9991037;;;; Defining functions in a way compatible with hot-upgrade:
     
    10571095  (defvar *asdf-debug-utility*
    10581096    '(or (ignore-errors
    1059           (symbol-call :asdf :system-relative-pathname :asdf-driver "contrib/debug.lisp"))
     1097          (symbol-call :asdf :system-relative-pathname :asdf "contrib/debug.lisp"))
    10601098      (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname)))
    10611099    "form that evaluates to the pathname to your favorite debugging utilities")
     
    14061444;;;; Access to the Operating System
    14071445
    1408 (asdf/package:define-package :asdf/os
    1409   (:recycle :asdf/os :asdf)
    1410   (:use :asdf/common-lisp :asdf/package :asdf/utility)
     1446(uiop/package:define-package :uiop/os
     1447  (:nicknames :asdf/os)
     1448  (:recycle :uiop/os :asdf/os :asdf)
     1449  (:use :uiop/common-lisp :uiop/package :uiop/utility)
    14111450  (:export
    14121451   #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features
     
    14191458   #:read-null-terminated-string #:read-little-endian
    14201459   #:parse-file-location-info #:parse-windows-shortcut))
    1421 (in-package :asdf/os)
     1460(in-package :uiop/os)
    14221461
    14231462;;; Features
     
    16231662        #+ecl (ext:getcwd)
    16241663        #+gcl (parse-namestring ;; this is a joke. Isn't there a better way?
    1625                (first (symbol-call :asdf/driver :run-program '("/bin/pwd") :output :lines)))
     1664               (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines)))
    16261665        #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical!
    16271666        #+lispworks (system:current-directory)
     
    17301769;; which all is necessary prior to any access the filesystem or environment.
    17311770
    1732 (asdf/package:define-package :asdf/pathname
    1733   (:recycle :asdf/pathname :asdf)
    1734   (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os)
     1771(uiop/package:define-package :uiop/pathname
     1772  (:nicknames :asdf/pathname)
     1773  (:recycle :uiop/pathname :asdf/pathname :asdf)
     1774  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os)
    17351775  (:export
    17361776   ;; Making and merging pathnames, portably
     
    17641804   #:translate-pathname*
    17651805   #:*output-translation-function*))
    1766 (in-package :asdf/pathname)
     1806(in-package :uiop/pathname)
    17671807
    17681808;;; Normalizing pathnames across implementations
     
    23942434;;;; Portability layer around Common Lisp filesystem access
    23952435
    2396 (asdf/package:define-package :asdf/filesystem
    2397   (:recycle :asdf/pathname :asdf)
    2398   (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname)
     2436(uiop/package:define-package :uiop/filesystem
     2437  (:nicknames :asdf/filesystem)
     2438  (:recycle :uiop/filesystem :asdf/pathname :asdf)
     2439  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname)
    23992440  (:export
    24002441   ;; Native namestrings
     
    24172458   #:rename-file-overwriting-target
    24182459   #:delete-file-if-exists))
    2419 (in-package :asdf/filesystem)
     2460(in-package :uiop/filesystem)
    24202461
    24212462;;; Native namestrings, as seen by the operating system calls rather than Lisp
     
    28732914;;;; Utilities related to streams
    28742915
    2875 (asdf/package:define-package :asdf/stream
    2876   (:recycle :asdf/stream)
    2877   (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/os :asdf/pathname :asdf/filesystem)
     2916(uiop/package:define-package :uiop/stream
     2917  (:nicknames :asdf/stream)
     2918  (:recycle :uiop/stream :asdf/stream :asdf)
     2919  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem)
    28782920  (:export
    28792921   #:*default-stream-element-type* #:*stderr* #:setup-stderr
     
    28812923   #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format
    28822924   #:*default-encoding* #:*utf-8-external-format*
    2883    #:with-safe-io-syntax #:call-with-safe-io-syntax
     2925   #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string
    28842926   #:with-output #:output-string #:with-input
    28852927   #:with-input-file #:call-with-input-file
     
    28962938   #:add-pathname-suffix #:tmpize-pathname
    28972939   #:call-with-staging-pathname #:with-staging-pathname))
    2898 (in-package :asdf/stream)
     2940(in-package :uiop/stream)
    28992941
    29002942(with-upgradability ()
     
    29152957;;; Encodings (mostly hooks only; full support requires asdf-encodings)
    29162958(with-upgradability ()
    2917   (defvar *default-encoding* :default
     2959  (defparameter *default-encoding*
     2960    ;; preserve explicit user changes to something other than the legacy default :default
     2961    (or (if-let (previous (and (boundp '*default-encoding*) (symbol-value '*default-encoding*)))
     2962          (unless (eq previous :default) previous))
     2963        :utf-8)
    29182964    "Default encoding for source files.
    2919 The default value :default preserves the legacy behavior.
    2920 A future default might be :utf-8 or :autodetect
     2965The default value :utf-8 is the portable thing.
     2966The legacy behavior was :default.
     2967If you (asdf:load-system :asdf-encodings) then
     2968you will have autodetection via *encoding-detection-hook* below,
    29212969reading emacs-style -*- coding: utf-8 -*- specifications,
    29222970and falling back to utf-8 or latin1 if nothing is specified.")
     
    29763024            (*print-readably* nil)
    29773025            (*read-eval* nil))
    2978         (funcall thunk)))))
     3026        (funcall thunk))))
     3027
     3028  (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace)
     3029    (with-safe-io-syntax (:package package)
     3030      (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace))))
    29793031
    29803032
     
    33263378;;;; Starting, Stopping, Dumping a Lisp image
    33273379
    3328 (asdf/package:define-package :asdf/image
    3329   (:recycle :asdf/image :xcvb-driver)
    3330   (:use :asdf/common-lisp :asdf/package :asdf/utility :asdf/pathname :asdf/stream :asdf/os)
     3380(uiop/package:define-package :uiop/image
     3381  (:nicknames :asdf/image)
     3382  (:recycle :uiop/image :asdf/image :xcvb-driver)
     3383  (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
    33313384  (:export
    33323385   #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments*
     
    33433396   #:restore-image #:dump-image #:create-image
    33443397))
    3345 (in-package :asdf/image)
     3398(in-package :uiop/image)
    33463399
    33473400(with-upgradability ()
     
    36543707;;;; run-program initially from xcvb-driver.
    36553708
    3656 (asdf/package:define-package :asdf/run-program
    3657   (:recycle :asdf/run-program :xcvb-driver)
    3658   (:use :asdf/common-lisp :asdf/utility :asdf/pathname :asdf/os :asdf/filesystem :asdf/stream)
     3709(uiop/package:define-package :uiop/run-program
     3710  (:nicknames :asdf/run-program)
     3711  (:recycle :uiop/run-program :asdf/run-program :xcvb-driver)
     3712  (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream)
    36593713  (:export
    36603714   ;;; Escaping the command invocation madness
     
    36693723   #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process
    36703724   ))
    3671 (in-package :asdf/run-program)
     3725(in-package :uiop/run-program)
    36723726
    36733727;;;; ----- Escaping strings for the shell -----
     
    40434097;;;; Support to build (compile and load) Lisp files
    40444098
    4045 (asdf/package:define-package :asdf/lisp-build
    4046   (:recycle :asdf/interface :asdf :asdf/lisp-build)
    4047   (:use :asdf/common-lisp :asdf/package :asdf/utility
    4048    :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
     4099(uiop/package:define-package :uiop/lisp-build
     4100  (:nicknames :asdf/lisp-build)
     4101  (:recycle :uiop/lisp-build :asdf/lisp-build :asdf)
     4102  (:use :uiop/common-lisp :uiop/package :uiop/utility
     4103   :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
    40494104  (:export
    40504105   ;; Variables
     
    40644119   #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings
    40654120   #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type*
     4121   #:enable-deferred-warnings-check #:disable-deferred-warnings-check
    40664122   #:current-lisp-file-pathname #:load-pathname
    40674123   #:lispize-pathname #:compile-file-type #:call-around-hook
     
    40694125   #:load* #:load-from-string #:combine-fasls)
    40704126  (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body))
    4071 (in-package :asdf/lisp-build)
     4127(in-package :uiop/lisp-build)
    40724128
    40734129(with-upgradability ()
     
    42344290      (cons (cons (reify-simple-sexp (car sexp)) (reify-simple-sexp (cdr sexp))))
    42354291      (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list))))))
    4236    
     4292
    42374293  (defun unreify-simple-sexp (sexp)
    42384294    (etypecase sexp
     
    42564312          (ccl::make-source-note :filename filename :start-pos start-pos :end-pos end-pos
    42574313                                 :source (unreify-source-note source)))))
     4314    (defun unsymbolify-function-name (name)
     4315      (if-let (setfed (gethash name ccl::%setf-function-name-inverses%))
     4316        `(setf ,setfed)
     4317        name))
     4318    (defun symbolify-function-name (name)
     4319      (if (and (consp name) (eq (first name) 'setf))
     4320          (let ((setfed (second name)))
     4321            (gethash setfed ccl::%setf-function-names%))
     4322          name))
    42584323    (defun reify-function-name (function-name)
    4259       (if-let (setfed (gethash function-name ccl::%setf-function-name-inverses%))
    4260               `(setf ,setfed)
    4261               function-name))
     4324      (let ((name (or (first function-name) ;; defun: extract the name
     4325                      (first (second function-name))))) ;; defmethod: keep gf name, drop method specializers
     4326        (list name)))
    42624327    (defun unreify-function-name (function-name)
    4263       (if (and (consp function-name) (eq (first function-name) 'setf))
    4264           (let ((setfed (second function-name)))
    4265             (gethash setfed ccl::%setf-function-names%))
    4266         function-name))
     4328      function-name)
    42674329    (defun reify-deferred-warning (deferred-warning)
    42684330      (with-accessors ((warning-type ccl::compiler-warning-warning-type)
     
    42724334        (list :warning-type warning-type :function-name (reify-function-name function-name)
    42734335              :source-note (reify-source-note source-note)
    4274               :args (destructuring-bind (fun . formals) args
    4275                       (cons (reify-function-name fun) formals)))))
     4336              :args (destructuring-bind (fun formals env) args
     4337                      (declare (ignorable env))
     4338                      (list (unsymbolify-function-name fun)
     4339                            (mapcar (constantly nil) formals)
     4340                            nil)))))
    42764341    (defun unreify-deferred-warning (reified-deferred-warning)
    42774342      (destructuring-bind (&key warning-type function-name source-note args)
     
    42834348                        :warning-type warning-type
    42844349                        :args (destructuring-bind (fun . formals) args
    4285                                 (cons (unreify-function-name fun) formals))))))
     4350                                (cons (symbolify-function-name fun) formals))))))
    42864351  #+(or cmu scl)
    42874352  (defun reify-undefined-warning (warning)
     
    44794544      ((:scl) "scl-warnings")))
    44804545
    4481   (defvar *warnings-file-type* (warnings-file-type)
     4546  (defvar *warnings-file-type* nil
    44824547    "Type for warnings files")
     4548
     4549  (defun enable-deferred-warnings-check ()
     4550    (setf *warnings-file-type* (warnings-file-type)))
     4551
     4552  (defun disable-deferred-warnings-check ()
     4553    (setf *warnings-file-type* nil))
    44834554
    44844555  (defun warnings-file-p (file &optional implementation-type)
     
    45034574             (handler-case (safe-read-file-form file)
    45044575               (error (c)
    4505                  (delete-file-if-exists file)
     4576                 ;;(delete-file-if-exists file) ;; deleting forces rebuild but prevents debugging
    45064577                 (push c file-errors)
    45074578                 nil))))))
     
    47124783;;;; Generic support for configuration files
    47134784
    4714 (asdf/package:define-package :asdf/configuration
    4715   (:recycle :asdf/configuration :asdf)
    4716   (:use :asdf/common-lisp :asdf/utility
    4717    :asdf/os :asdf/pathname :asdf/filesystem :asdf/stream :asdf/image)
     4785(uiop/package:define-package :uiop/configuration
     4786  (:nicknames :asdf/configuration)
     4787  (:recycle :uiop/configuration :asdf/configuration :asdf)
     4788  (:use :uiop/common-lisp :uiop/utility
     4789   :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image)
    47184790  (:export
    47194791   #:get-folder-path
     
    47274799   #:resolve-location #:location-designator-p #:location-function-p #:*here-directory*
    47284800   #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration))
    4729 (in-package :asdf/configuration)
     4801(in-package :uiop/configuration)
    47304802
    47314803(with-upgradability ()
     
    50095081;;; Hacks for backward-compatibility of the driver
    50105082
    5011 (asdf/package:define-package :asdf/backward-driver
    5012   (:recycle :asdf/backward-driver :asdf)
    5013   (:use :asdf/common-lisp :asdf/package :asdf/utility
    5014    :asdf/pathname :asdf/stream :asdf/os :asdf/image
    5015    :asdf/run-program :asdf/lisp-build
    5016    :asdf/configuration)
     5083(uiop/package:define-package :uiop/backward-driver
     5084  (:nicknames :asdf/backward-driver)
     5085  (:recycle :uiop/backward-driver :asdf/backward-driver :asdf)
     5086  (:use :uiop/common-lisp :uiop/package :uiop/utility
     5087   :uiop/pathname :uiop/stream :uiop/os :uiop/image
     5088   :uiop/run-program :uiop/lisp-build
     5089   :uiop/configuration)
    50175090  (:export
    50185091   #:coerce-pathname #:component-name-to-pathname-components
    50195092   #+(or ecl mkcl) #:compile-file-keeping-object
    50205093   ))
    5021 (in-package :asdf/backward-driver)
     5094(in-package :uiop/backward-driver)
    50225095
    50235096;;;; Backward compatibility with various pathname functions.
     
    50495122;;;; Re-export all the functionality in asdf/driver
    50505123
    5051 (asdf/package:define-package :asdf/driver
    5052   (:nicknames :asdf-driver :asdf-utils)
    5053   (:use :asdf/common-lisp :asdf/package :asdf/utility
    5054     :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
    5055    :asdf/run-program :asdf/lisp-build
    5056    :asdf/configuration :asdf/backward-driver)
     5124(uiop/package:define-package :uiop/driver
     5125  (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils)
     5126  (:use :uiop/common-lisp :uiop/package :uiop/utility
     5127    :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
     5128   :uiop/run-program :uiop/lisp-build
     5129   :uiop/configuration :uiop/backward-driver)
    50575130  (:reexport
    50585131   ;; NB: excluding asdf/common-lisp
    50595132   ;; which include all of CL with compatibility modifications on select platforms.
    5060    :asdf/package :asdf/utility
    5061     :asdf/os :asdf/pathname :asdf/stream :asdf/filesystem :asdf/image
    5062    :asdf/run-program :asdf/lisp-build
    5063    :asdf/configuration :asdf/backward-driver))
     5133   :uiop/package :uiop/utility
     5134   :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
     5135   :uiop/run-program :uiop/lisp-build
     5136   :uiop/configuration :uiop/backward-driver))
    50645137;;;; -------------------------------------------------------------------------
    50655138;;;; Handle upgrade as forward- and backward-compatibly as possible
     
    51165189         ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
    51175190         ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
    5118          (asdf-version "2.30")
     5191         (asdf-version "2.32")
    51195192         (existing-version (asdf-version)))
    51205193    (setf *asdf-version* asdf-version)
     
    51835256        (push new-version *previous-asdf-versions*)
    51845257        (when old-version
    5185           (cond
    5186             ((version-compatible-p new-version old-version)
    5187              (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
    5188                            old-version new-version))
    5189             ((version-compatible-p old-version new-version)
    5190              (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
    5191                    old-version new-version))
    5192             (t
    5193              (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%")
    5194                            old-version new-version)))
     5258          (if (version<= new-version old-version)
     5259              (error (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%")
     5260                     old-version new-version)
     5261              (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%")
     5262                            old-version new-version))
    51955263          (call-functions (reverse *post-upgrade-cleanup-hook*))
    51965264          t))))
     
    52015269    (let ((*load-print* nil)
    52025270          (*compile-print* nil))
    5203       (handler-bind (((or style-warning warning) #'muffle-warning))
     5271      (handler-bind (((or style-warning) #'muffle-warning))
    52045272        (symbol-call :asdf :load-system :asdf :verbose nil))))
    52055273
     
    52205288   #:source-file #:c-source-file #:java-source-file
    52215289   #:static-file #:doc-file #:html-file
    5222    #:source-file-type ;; backward-compatibility
     5290   #:file-type
     5291   #:source-file-type #:source-file-explicit-type ;; backward-compatibility
    52235292   #:component-in-order-to #:component-sibling-dependencies
    52245293   #:component-if-feature #:around-compile-hook
     
    53515420    ((type :accessor file-type :initarg :type))) ; no default
    53525421  (defclass source-file (file-component)
    5353     ((type :initform nil))) ;; NB: many systems have come to rely on this default.
     5422    ((type :accessor source-file-explicit-type ;; backward-compatibility
     5423           :initform nil))) ;; NB: many systems have come to rely on this default.
    53545424  (defclass c-source-file (source-file)
    53555425    ((type :initform "c")))
     
    56285698               value-list)))
    56295699
    5630   (defun consult-asdf-cache (key thunk)
     5700  (defun consult-asdf-cache (key &optional thunk)
    56315701    (if *asdf-cache*
    56325702        (multiple-value-bind (results foundp) (gethash key *asdf-cache*)
    56335703          (if foundp
    56345704              (apply 'values results)
    5635               (set-asdf-cache-entry key (multiple-value-list (funcall thunk)))))
    5636         (funcall thunk)))
     5705              (set-asdf-cache-entry key (multiple-value-list (call-function thunk)))))
     5706        (call-function thunk)))
    56375707
    56385708  (defmacro do-asdf-cache (key &body body)
     
    56675737  (:export
    56685738   #:remove-entry-from-registry #:coerce-entry-to-directory
    5669    #:coerce-name #:primary-system-name
     5739   #:coerce-name #:primary-system-name #:coerce-filename
    56705740   #:find-system #:locate-system #:load-asd #:with-system-definitions
    56715741   #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems
     
    57285798    ;; the first of the slash-separated components.
    57295799    (first (split-string (coerce-name name) :separator "/")))
     5800
     5801  (defun coerce-filename (name)
     5802    (frob-substrings (coerce-name name) '("/" ":" "\\") "--"))
    57305803
    57315804  (defvar *defined-systems* (make-hash-table :test 'equal)
     
    58925965                            (subseq *central-registry* (1+ position))))))))))
    58935966
     5967  (defvar *preloaded-systems* (make-hash-table :test 'equal))
     5968
     5969  (defun make-preloaded-system (name keys)
     5970    (apply 'make-instance (getf keys :class 'system)
     5971           :name name :source-file (getf keys :source-file)
     5972           (remove-plist-keys '(:class :name :source-file) keys)))
     5973
     5974  (defun sysdef-preloaded-system-search (requested)
     5975    (let ((name (coerce-name requested)))
     5976      (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
     5977        (when foundp
     5978          (make-preloaded-system name keys)))))
     5979
     5980  (defun register-preloaded-system (system-name &rest keys)
     5981    (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
     5982
     5983  (register-preloaded-system "asdf" :version *asdf-version*)
     5984  (register-preloaded-system "asdf-driver" :version *asdf-version*)
     5985
    58945986  (defmethod find-system ((name null) &optional (error-p t))
    58955987    (declare (ignorable name))
     
    59126004        (let ((*systems-being-defined* (make-hash-table :test 'equal)))
    59136005          (call-with-asdf-cache thunk))))
     6006
     6007  (defun clear-systems-being-defined ()
     6008    (when *systems-being-defined*
     6009      (clrhash *systems-being-defined*)))
     6010
     6011  (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined)
    59146012
    59156013  (defmacro with-system-definitions ((&optional) &body body)
     
    59416039              (load* pathname :external-format external-format)))))))
    59426040
     6041  (defvar *old-asdf-systems* (make-hash-table :test 'equal))
     6042
     6043  (defun check-not-old-asdf-system (name pathname)
     6044    (or (not (equal name "asdf"))
     6045        (null pathname)
     6046        (let* ((version-pathname (subpathname pathname "version.lisp-expr"))
     6047               (version (and (probe-file* version-pathname :truename nil)
     6048                             (read-file-form version-pathname)))
     6049               (old-version (asdf-version)))
     6050          (or (version<= old-version version)
     6051              (let ((old-pathname
     6052                      (if-let (pair (system-registered-p "asdf"))
     6053                        (system-source-file (cdr pair))))
     6054                    (key (list pathname old-version)))
     6055                (unless (gethash key *old-asdf-systems*)
     6056                  (setf (gethash key *old-asdf-systems*) t)
     6057                  (warn "~@<~
     6058        You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~
     6059        or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~
     6060        ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~
     6061        Having an ASDF installed and registered is the normal way of configuring ASDF to upgrade itself, ~
     6062        and having an old version registered is a configuration error. ~
     6063        ASDF will ignore this configured system rather than downgrade itself. ~
     6064        In the future, you may want to either: ~
     6065        (a) upgrade this configured ASDF to a newer version, ~
     6066        (b) install a newer ASDF and register it in front of the former in your configuration, or ~
     6067        (c) uninstall or unregister this and any other old version of ASDF from your configuration. ~
     6068        Note that the older ASDF might be registered implicitly through configuration inherited ~
     6069        from your system installation, in which case you might have to specify ~
     6070        :ignore-inherited-configuration in your in your ~~/.config/common-lisp/source-registry.conf ~
     6071        or other source-registry configuration file, environment variable or lisp parameter. ~
     6072        Indeed, a likely offender is an obsolete version of the cl-asdf debian or ubuntu package, ~
     6073        that you might want to upgrade (if a recent enough version is available) ~
     6074        or else remove altogether (since most implementations ship with a recent asdf); ~
     6075        if you lack the system administration rights to upgrade or remove this package, ~
     6076        then you might indeed want to either install and register a more recent version, ~
     6077        or use :ignore-inherited-configuration to avoid registering the old one. ~
     6078        Please consult ASDF documentation and/or experts.~@:>~%"
     6079                    old-version old-pathname version pathname)))))))
     6080
    59436081  (defun locate-system (name)
    59446082    "Given a system NAME designator, try to locate where to load the system from.
     
    59586096           (found (search-for-system-definition name))
    59596097           (found-system (and (typep found 'system) found))
    5960            (pathname (or (and (typep found '(or pathname string)) (pathname found))
    5961                          (and found-system (system-source-file found-system))
    5962                          (and previous (system-source-file previous))))
    5963            (pathname (ensure-pathname (resolve-symlinks* pathname) :want-absolute t))
     6098           (pathname (ensure-pathname
     6099                      (or (and (typep found '(or pathname string)) (pathname found))
     6100                          (and found-system (system-source-file found-system))
     6101                          (and previous (system-source-file previous)))
     6102                     :want-absolute t :resolve-symlinks *resolve-symlinks*))
    59646103           (foundp (and (or found-system pathname previous) t)))
    59656104      (check-type found (or null pathname system))
     6105      (unless (check-not-old-asdf-system name pathname)
     6106        (cond
     6107          (previous (setf found nil pathname nil))
     6108          (t
     6109           (setf found (sysdef-preloaded-system-search "asdf"))
     6110           (assert (typep found 'system))
     6111           (setf found-system found pathname nil))))
    59666112      (values foundp found-system pathname previous previous-time)))
    59676113
     
    59896135                                                      (translate-logical-pathname previous-pathname))))
    59906136                                            (stamp<= stamp previous-time))))))
    5991                   ;; only load when it's a pathname that is different or has newer content
     6137                  ;; only load when it's a pathname that is different or has newer content, and not an old asdf
    59926138                  (load-asd pathname :name name)))
    59936139              (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed
     
    60036149            :report (lambda (s)
    60046150                      (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name))
    6005             (initialize-source-registry))))))
    6006 
    6007   (defvar *preloaded-systems* (make-hash-table :test 'equal))
    6008 
    6009   (defun sysdef-preloaded-system-search (requested)
    6010     (let ((name (coerce-name requested)))
    6011       (multiple-value-bind (keys foundp) (gethash name *preloaded-systems*)
    6012         (when foundp
    6013           (apply 'make-instance 'system :name name :source-file (getf keys :source-file) keys)))))
    6014 
    6015   (defun register-preloaded-system (system-name &rest keys)
    6016     (setf (gethash (coerce-name system-name) *preloaded-systems*) keys))
    6017 
    6018   (register-preloaded-system "asdf" :version *asdf-version*)
    6019   (register-preloaded-system "asdf-driver" :version *asdf-version*))
     6151            (initialize-source-registry)))))))
    60206152
    60216153;;;; -------------------------------------------------------------------------
     
    61536285
    61546286(asdf/package:define-package :asdf/operation
    6155   (:recycle :asdf/operation :asdf)
     6287  (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5.
    61566288  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade)
    61576289  (:export
     
    61596291   #:operation-original-initargs ;; backward-compatibility only. DO NOT USE.
    61606292   #:build-op ;; THE generic operation
    6161    #:*operations*
    6162    #:make-operation
    6163    #:find-operation))
     6293   #:*operations* #:make-operation #:find-operation #:feature))
    61646294(in-package :asdf/operation)
    61656295
     
    62036333    spec)
    62046334  (defmethod find-operation (context (spec symbol))
    6205     (apply 'make-operation spec (operation-original-initargs context)))
     6335    (unless (member spec '(nil feature))
     6336      ;; NIL designates itself, i.e. absence of operation
     6337      ;; FEATURE is the ASDF1 misfeature that comes with IF-COMPONENT-DEP-FAILS
     6338      (apply 'make-operation spec (operation-original-initargs context))))
    62066339  (defmethod operation-original-initargs ((context symbol))
    62076340    (declare (ignorable context))
     
    62276360   #:action-status #:action-stamp #:action-done-p
    62286361   #:component-operation-time #:mark-operation-done #:compute-action-stamp
    6229    #:perform #:perform-with-restarts #:retry #:accept #:feature
     6362   #:perform #:perform-with-restarts #:retry #:accept
    62306363   #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan
    62316364   #:action-path #:find-action #:stamp #:done-p))
     
    63066439    the operation.  A dependency has one of the following forms:
    63076440
    6308       (<operation> <component>*), where <operation> is a class
    6309         designator and each <component> is a component
    6310         designator, which means that the component depends on
     6441      (<operation> <component>*), where <operation> is an operation designator
     6442        with respect to FIND-OPERATION in the context of the OPERATION argument,
     6443        and each <component> is a component designator with respect to
     6444        FIND-COMPONENT in the context of the COMPONENT argument,
     6445        and means that the component depends on
    63116446        <operation> having been performed on each <component>; or
    63126447
    63136448      (FEATURE <feature>), which means that the component depends
    6314         on <feature>'s presence in *FEATURES*.
     6449        on the <feature> expression satisfying FEATUREP.
     6450        (This is DEPRECATED -- use :IF-FEATURE instead.)
    63156451
    63166452    Methods specialized on subclasses of existing component types
    6317     should usually append the results of CALL-NEXT-METHOD to the
    6318     list."))
     6453    should usually append the results of CALL-NEXT-METHOD to the list."))
    63196454  (defgeneric component-self-dependencies (operation component))
    63206455  (define-convenience-action-methods component-depends-on (operation component))
     
    65216656  (:intern #:proclamations #:flags)
    65226657  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
    6523    :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/operation :asdf/action)
     6658   :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/find-system
     6659   :asdf/operation :asdf/action)
    65246660  (:export
    65256661   #:try-recompiling
     
    66226758
    66236759  (defun report-file-p (f)
    6624     (equal (pathname-type f) "build-report"))
     6760    (equalp (pathname-type f) "build-report"))
    66256761  (defun perform-lisp-warnings-check (o c)
    66266762    (let* ((expected-warnings-files (remove-if-not #'warnings-file-p (input-files o c)))
     
    66756811    (when (and *warnings-file-type* (not (builtin-system-p c)))
    66766812      (if-let ((pathname (component-pathname c)))
    6677         (list (subpathname pathname (component-name c) :type "build-report"))))))
     6813        (list (subpathname pathname (coerce-filename c) :type "build-report"))))))
    66786814
    66796815;;; load-op
     
    67726908    `((load-op ,c) ,@(call-next-method))))
    67736909
     6910
    67746911;;;; -------------------------------------------------------------------------
    67756912;;;; Plan
     
    69467083  (defun map-direct-dependencies (operation component fun)
    69477084    (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component)
    6948            :unless (eq dep-o-spec 'feature) ;; avoid the "FEATURE" misfeature
    6949            :do (loop :with dep-o = (find-operation operation dep-o-spec)
    6950                      :for dep-c-spec :in dep-c-specs
    6951                      :for dep-c = (resolve-dependency-spec component dep-c-spec)
    6952                      :do (funcall fun dep-o dep-c))))
     7085           :for dep-o = (find-operation operation dep-o-spec)
     7086           :when dep-o
     7087           :do (loop :for dep-c-spec :in dep-c-specs
     7088                     :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec))
     7089                     :when dep-c
     7090                       :do (funcall fun dep-o dep-c))))
    69537091
    69547092  (defun reduce-direct-dependencies (operation component combinator seed)
     
    72317369
    72327370(with-upgradability ()
    7233   (defgeneric* (operate) (operation component &key &allow-other-keys))
    7234   (define-convenience-action-methods
    7235       operate (operation component &key)
    7236       :operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
    7237       :if-no-component (error 'missing-component :requires component))
    7238 
    7239   (defvar *systems-being-operated* nil
    7240     "A boolean indicating that some systems are being operated on")
    7241 
    7242   (defmethod operate :around (operation component
    7243                               &key verbose
    7244                                 (on-warnings *compile-file-warnings-behaviour*)
    7245                                 (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
    7246     (declare (ignorable operation component))
    7247     ;; Setup proper bindings around any operate call.
    7248     (with-system-definitions ()
    7249       (let* ((*verbose-out* (and verbose *standard-output*))
    7250              (*compile-file-warnings-behaviour* on-warnings)
    7251              (*compile-file-failure-behaviour* on-failure))
    7252         (call-next-method))))
    7253 
    7254   (defmethod operate ((operation operation) (component component)
    7255                       &rest args &key version &allow-other-keys)
    7256     "Operate does three things:
     7371  (defgeneric* (operate) (operation component &key &allow-other-keys)
     7372    (:documentation
     7373     "Operate does three things:
    72577374
    725873751. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs.
     
    72727389  :ALL to force all systems including other systems we depend on to be rebuilt (resp. not).
    72737390  (SYSTEM1 SYSTEM2 ... SYSTEMN) to force systems named in a given list
    7274 :FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."
    7275     (let* (;; I'd like to remove-plist-keys :force :force-not :verbose,
    7276            ;; but swank.asd relies on :force (!).
    7277            (systems-being-operated *systems-being-operated*)
     7391:FORCE has precedence over :FORCE-NOT; builtin systems cannot be forced."))
     7392
     7393  (define-convenience-action-methods
     7394      operate (operation component &key)
     7395      ;; I'd like to at least remove-plist-keys :force :force-not :verbose,
     7396      ;; but swank.asd relies on :force (!).
     7397      :operation-initargs t ;; backward-compatibility with ASDF1. Yuck.
     7398      :if-no-component (error 'missing-component :requires component))
     7399
     7400  (defvar *systems-being-operated* nil
     7401    "A boolean indicating that some systems are being operated on")
     7402
     7403  (defmethod operate :around (operation component &rest keys
     7404                              &key verbose
     7405                                (on-warnings *compile-file-warnings-behaviour*)
     7406                                (on-failure *compile-file-failure-behaviour*) &allow-other-keys)
     7407    (declare (ignorable operation component))
     7408    (let* ((systems-being-operated *systems-being-operated*)
    72787409           (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal)))
    7279            (system (component-system component)))
    7280       (setf (gethash (coerce-name system) *systems-being-operated*) system)
    7281       (unless (version-satisfies component version)
    7282         (error 'missing-component-of-version :requires component :version version))
     7410           (operation-name (reify-symbol (etypecase operation
     7411                                           (operation (type-of operation))
     7412                                           (symbol operation))))
     7413           (component-path (typecase component
     7414                             (component (component-find-path component))
     7415                             (t component))))
    72837416      ;; Before we operate on any system, make sure ASDF is up-to-date,
    72847417      ;; for if an upgrade is ever attempted at any later time, there may be BIG trouble.
    72857418      (unless systems-being-operated
    7286         (let ((operation-name (reify-symbol (type-of operation)))
    7287               (component-path (component-find-path component)))
    7288           (when (upgrade-asdf)
    7289             ;; If we were upgraded, restart OPERATE the hardest of ways, for
    7290             ;; its function may have been redefined, its symbol uninterned, its package deleted.
    7291             (return-from operate
    7292               (apply (find-symbol* 'operate :asdf)
    7293                      (unreify-symbol operation-name)
    7294                      component-path args)))))
    7295       (let ((plan (apply 'traverse operation system args)))
    7296         (perform-plan plan)
    7297         (values operation plan))))
     7419        (when (upgrade-asdf)
     7420          ;; If we were upgraded, restart OPERATE the hardest of ways, for
     7421          ;; its function may have been redefined, its symbol uninterned, its package deleted.
     7422          (return-from operate
     7423            (apply (find-symbol* 'operate :asdf)
     7424                   (unreify-symbol operation-name)
     7425                   component-path keys))))
     7426      ;; Setup proper bindings around any operate call.
     7427      (with-system-definitions ()
     7428        (let* ((*verbose-out* (and verbose *standard-output*))
     7429               (*compile-file-warnings-behaviour* on-warnings)
     7430               (*compile-file-failure-behaviour* on-failure))
     7431          (call-next-method)))))
     7432
     7433  (defmethod operate :before ((operation operation) (component component)
     7434                              &key version &allow-other-keys)
     7435    (let ((system (component-system component)))
     7436      (setf (gethash (coerce-name system) *systems-being-operated*) system))
     7437    (unless (version-satisfies component version)
     7438      (error 'missing-component-of-version :requires component :version version)))
     7439
     7440  (defmethod operate ((operation operation) (component component)
     7441                      &rest keys &key &allow-other-keys)
     7442    (let ((plan (apply 'traverse operation component keys)))
     7443      (perform-plan plan)
     7444      (values operation plan)))
    72987445
    72997446  (defun oos (operation component &rest args &key &allow-other-keys)
     
    73557502    (apply 'load-system s :force-not (already-loaded-systems) keys))
    73567503
     7504  (defvar *modules-being-required* nil)
     7505
     7506  (defclass require-system (system)
     7507    ((module :initarg :module :initform nil :accessor required-module)))
     7508
     7509  (defmethod perform ((o compile-op) (c require-system))
     7510    (declare (ignorable o c))
     7511    nil)
     7512
     7513  (defmethod perform ((o load-op) (s require-system))
     7514    (declare (ignorable o))
     7515    (let* ((module (or (required-module s) (coerce-name s)))
     7516           (*modules-being-required* (cons module *modules-being-required*)))
     7517      (assert (null (component-children s)))
     7518      (require module)))
     7519
     7520  (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments)
     7521    (declare (ignorable component combinator))
     7522    (unless (length=n-p arguments 1)
     7523      (error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes only one argument~@:>")
     7524             (cons combinator arguments) component combinator))
     7525    (let* ((module (car arguments))
     7526           (name (string-downcase module))
     7527           (system (find-system name nil)))
     7528      (assert module)
     7529      ;;(unless (typep system '(or null require-system))
     7530      ;;  (warn "~S depends on ~S but ~S is registered as a ~S"
     7531      ;;        component (cons combinator arguments) module (type-of system)))
     7532      (or system (let ((system (make-instance 'require-system :name name)))
     7533                   (register-system system)
     7534                   system))))
     7535
    73577536  (defun module-provide-asdf (name)
    7358     (handler-bind
    7359         ((style-warning #'muffle-warning)
    7360          (missing-component (constantly nil))
    7361          (error #'(lambda (e)
    7362                     (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
    7363                             name e))))
    7364       (let ((*verbose-out* (make-broadcast-stream))
    7365             (system (find-system (string-downcase name) nil)))
    7366         (when system
    7367           (require-system system :verbose nil)
    7368           t)))))
     7537    (let ((module (string-downcase name)))
     7538      (unless (member module *modules-being-required* :test 'equal)
     7539        (let ((*modules-being-required* (cons module *modules-being-required*))
     7540              #+sbcl (sb-impl::*requiring* (remove module sb-impl::*requiring* :test 'equal)))
     7541          (handler-bind
     7542              ((style-warning #'muffle-warning)
     7543               (missing-component (constantly nil))
     7544               (error #'(lambda (e)
     7545                          (format *error-output* (compatfmt "~@<ASDF could not load ~(~A~) because ~A.~@:>~%")
     7546                                  name e))))
     7547            (let ((*verbose-out* (make-broadcast-stream)))
     7548              (let ((system (find-system module nil)))
     7549                (when system
     7550                  (require-system system :verbose nil)
     7551                  t)))))))))
    73697552
    73707553
     
    76467829
    76477830  (defun* (apply-output-translations) (path)
    7648     #+cormanlisp (resolve-symlinks* path) #-cormanlisp
    7649                                           (etypecase path
    7650                                             (logical-pathname
    7651                                              path)
    7652                                             ((or pathname string)
    7653                                              (ensure-output-translations)
    7654                                              (loop* :with p = (resolve-symlinks* path)
    7655                                                     :for (source destination) :in (car *output-translations*)
    7656                                                     :for root = (when (or (eq source t)
    7657                                                                           (and (pathnamep source)
    7658                                                                                (not (absolute-pathname-p source))))
    7659                                                                   (pathname-root p))
    7660                                                     :for absolute-source = (cond
    7661                                                                              ((eq source t) (wilden root))
    7662                                                                              (root (merge-pathnames* source root))
    7663                                                                              (t source))
    7664                                                     :when (or (eq source t) (pathname-match-p p absolute-source))
    7665                                                     :return (translate-pathname* p absolute-source destination root source)
    7666                                                     :finally (return p)))))
     7831    (etypecase path
     7832      (logical-pathname
     7833       path)
     7834      ((or pathname string)
     7835       (ensure-output-translations)
     7836       (loop* :with p = (resolve-symlinks* path)
     7837              :for (source destination) :in (car *output-translations*)
     7838              :for root = (when (or (eq source t)
     7839                                    (and (pathnamep source)
     7840                                         (not (absolute-pathname-p source))))
     7841                            (pathname-root p))
     7842              :for absolute-source = (cond
     7843                                       ((eq source t) (wilden root))
     7844                                       (root (merge-pathnames* source root))
     7845                                       (t source))
     7846              :when (or (eq source t) (pathname-match-p p absolute-source))
     7847              :return (translate-pathname* p absolute-source destination root source)
     7848              :finally (return p)))))
    76677849
    76687850  ;; Hook into asdf/driver's output-translation mechanism
     7851  #-cormanlisp
    76697852  (setf *output-translation-function* 'apply-output-translations)
    76707853
     
    81568339                               type
    81578340                               (find-symbol* type *package* nil)
    8158                                (find-symbol* type :asdf/interface nil))
    8159               :for class = (and symbol (find-class* symbol nil))
     8341                               (find-symbol* type :asdf/interface nil)
     8342                               (and (stringp type) (safe-read-from-string type :package :asdf/interface)))
     8343              :for class = (and symbol (symbolp symbol) (find-class* symbol nil))
    81608344              :when (and class
    81618345                         (#-cormanlisp subtypep #+cormanlisp cl::subclassp
     
    81758359    ((name :initarg :name :reader duplicate-names-name))
    81768360    (:report (lambda (c s)
    8177                (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~A~@:>")
     8361               (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>")
    81788362                       (duplicate-names-name c)))))
    81798363
     
    81958379                              type name components)))
    81968380
    8197   (defun normalize-version (form pathname)
    8198     (etypecase form
    8199       ((or string null) form)
    8200       (real
    8201        (asdf-message "Invalid use of real number ~D as :version in ~S. Substituting a string."
    8202                      form pathname)
    8203        (format nil "~D" form)) ;; 1.0 is "1.0"
    8204       (cons
    8205        (ecase (first form)
    8206          ((:read-file-form)
    8207           (destructuring-bind (subpath &key (at 0)) (rest form)
    8208             (safe-read-file-form (subpathname pathname subpath) :at at))))))))
     8381  (defun* (normalize-version) (form &key pathname component parent)
     8382    (labels ((invalid (&optional (continuation "using NIL instead"))
     8383               (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>")
     8384                     form component parent pathname continuation))
     8385             (invalid-parse (control &rest args)
     8386               (unless (builtin-system-p (find-component parent component))
     8387                 (apply 'warn control args)
     8388                 (invalid))))
     8389      (if-let (v (typecase form
     8390                   ((or string null) form)
     8391                   (real
     8392                    (invalid "Substituting a string")
     8393                    (format nil "~D" form)) ;; 1.0 becomes "1.0"
     8394                   (cons
     8395                    (case (first form)
     8396                      ((:read-file-form)
     8397                       (destructuring-bind (subpath &key (at 0)) (rest form)
     8398                         (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user)))
     8399                      ((:read-file-line)
     8400                       (destructuring-bind (subpath &key (at 0)) (rest form)
     8401                         (read-file-lines (subpathname pathname subpath) :at at)))
     8402                      (otherwise
     8403                       (invalid))))
     8404                   (t
     8405                    (invalid))))
     8406        (if-let (pv (parse-version v #'invalid-parse))
     8407          (unparse-version pv)
     8408          (invalid))))))
    82098409
    82108410
     
    82198419                                components pathname perform explain output-files operation-done-p
    82208420                                weakly-depends-on depends-on serial
    8221                                 do-first if-component-dep-fails (version nil versionp)
     8421                                do-first if-component-dep-fails version
    82228422                                ;; list ends
    82238423         &allow-other-keys) options
     
    82508450            (setf component (apply 'make-instance (class-for-type parent type) args)))
    82518451        (component-pathname component) ; eagerly compute the absolute pathname
    8252         (let ((sysdir (system-source-directory (component-system component)))) ;; requires the previous
     8452        (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous
    82538453          (when (and (typep component 'system) (not bspp))
    8254             (setf (builtin-system-p component) (lisp-implementation-pathname-p sysdir)))
    8255           (setf version (normalize-version version sysdir)))
    8256         (when (and versionp version (not (parse-version version nil)))
    8257           (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
    8258                 version name parent))
     8454            (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile)))
     8455          (setf version (normalize-version version :component name :parent parent :pathname sysfile)))
    82598456        ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8.
    82608457        ;; A better fix is required.
     
    83008497             (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect
    83018498                                           (resolve-dependency-spec nil spec))))
     8499        (setf (gethash name *systems-being-defined*) system)
    83028500        (apply 'load-systems defsystem-dependencies)
    83038501        ;; We change-class AFTER we loaded the defsystem-depends-on
     
    83258523   #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type
    83268524   #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op
    8327    #:monolithic-op #:monolithic-bundle-op #:direct-dependency-files
     8525   #:monolithic-op #:monolithic-bundle-op #:bundlable-file-p #:direct-dependency-files
    83288526   #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op
    83298527   #:program-op
     
    84598657      (setf (slot-value instance 'name-suffix)
    84608658            (unless (typep instance 'program-op)
    8461               (if (operation-monolithic-p instance) ".all-systems" #-ecl ".system"))))
     8659              (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames
    84628660    (when (typep instance 'monolithic-bundle-op)
    84638661      (destructuring-bind (&rest original-initargs
     
    84848682    (let ((type (pathname-type pathname)))
    84858683      (declare (ignorable type))
    8486       (or #+ecl (or (equal type (compile-file-type :type :object))
    8487                     (equal type (compile-file-type :type :static-library)))
    8488           #+mkcl (equal type (compile-file-type :fasl-p nil))
    8489           #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equal type (compile-file-type)))))
     8684      (or #+ecl (or (equalp type (compile-file-type :type :object))
     8685                    (equalp type (compile-file-type :type :static-library)))
     8686          #+mkcl (equalp type (compile-file-type :fasl-p nil))
     8687          #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
    84908688
    84918689  (defgeneric* (trivial-system-p) (component))
     
    86558853  (defmethod perform ((o load-fasl-op) (c compiled-file))
    86568854    (perform (find-operation o 'load-op) c))
    8657   (defmethod perform (o (c compiled-file))
     8855  (defmethod perform ((o operation) (c compiled-file))
    86588856    (declare (ignorable o c))
    86598857    nil))
     
    87148912  (defmethod perform ((o fasl-op) (c system))
    87158913    (let* ((input-files (input-files o c))
    8716            (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'string=))
    8717            (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'string=))
     8914           (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp))
     8915           (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp))
    87188916           (output-files (output-files o c))
    87198917           (output-file (first output-files)))
     
    87348932    (declare (ignorable o))
    87358933    (bundle-output-files (find-operation o 'fasl-op) s))
     8934
     8935  (defmethod perform ((o load-op) (s precompiled-system))
     8936    (perform-lisp-load-fasl o s))
    87368937
    87378938  (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system))
     
    90929293   #:operation-monolithic-p
    90939294   #:required-components
     9295   #:component-loaded-p
    90949296
    90959297   #:component #:parent-component #:child-component #:system #:module
     
    90979299   #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
    90989300   #:static-file #:doc-file #:html-file
     9301   #:file-type
    90999302   #:source-file-type
    91009303
     
    91779380   #:compile-file*
    91789381   #:compile-file-pathname*
    9179    #:*warnings-file-type*
     9382   #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check
    91809383   #:enable-asdf-binary-locations-compatibility
    91819384   #:*default-source-registries*
     
    92409443          (loop :for f :in #+ecl ext:*module-provider-functions*
    92419444                #+mkcl mk-ext::*module-provider-functions*
    9242                 :unless (eq f 'module-provide-asdf)
    9243                   :collect #'(lambda (name)
    9244                                (let ((l (multiple-value-list (funcall f name))))
    9245                                  (and (first l) (register-pre-built-system (coerce-name name)))
    9246                                  (values-list l)))))))
     9445                :collect
     9446                (if (eq f 'module-provide-asdf) f
     9447                    #'(lambda (name)
     9448                        (let ((l (multiple-value-list (funcall f name))))
     9449                          (and (first l) (register-pre-built-system (coerce-name name)))
     9450                          (values-list l))))))))
    92479451
    92489452
     
    92639467
    92649468
    9265 ;;; Local Variables:
    9266 ;;; mode: lisp
    9267 ;;; End:
Note: See TracChangeset for help on using the changeset viewer.