Changeset 14713 for trunk/abcl/src/org/armedbear

Timestamp:

05/17/14 10:51:33 (9 years ago)

Author:

Mark Evenson

Message:

Update to ASDF 3.1.2.2 version.

File:

• trunk/abcl/src/org/armedbear/lisp/asdf.lisp (modified) (36 diffs)

trunk/abcl/src/org/armedbear/lisp/asdf.lisp

@@ -1 +1 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*-
-;;; This is ASDF 3.1.0.103: Another System Definition Facility.
+;;; This is ASDF 3.1.2.2: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
@@ -820 +820 @@
           `(apply 'ensure-package ',(parse-define-package-form package clauses))))
     `(progn
-       #+(or ecl gcl) (defpackage ,package (:use))
+       #+(or ecl gcl mkcl) (defpackage ,package (:use))
        (eval-when (:compile-toplevel :load-toplevel :execute)
          ,ensure-form))))
@@ -1668 +1668 @@
 except on ABCL where it might change between FASL compilation and runtime."
     (loop* :with o
-           :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p)
-                                         (:os-macosx . os-macosx-p)
+           :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p)
+                                         (:os-windows . os-windows-p)
                                          (:genera . os-genera-p) (:os-oldmac . os-oldmac-p))
-           :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*)
+           :when (and (or (not o) (eq feature :os-macosx)) (funcall detect))
+           :do (setf o feature) (pushnew feature *features*)
            :else :do (setf *features* (remove feature *features*))
            :finally
@@ -1851 +1852 @@
   (defun getcwd ()
     "Get the current working directory as per POSIX getcwd(3), as a pathname object"
-    (or #+abcl (symbol-call :asdf/filesystem :parse-native-namestring
-                            (java:jstatic "getProperty" "java.lang.System" "user.dir")
-                                                     :ensure-directory t)
+    (or #+abcl (truename (symbol-call :asdf/filesystem :parse-native-namestring
+                          (java:jstatic "getProperty" "java.lang.System" "user.dir")
+                          :ensure-directory t))
         #+allegro (excl::current-directory)
         #+clisp (ext:default-directory)
@@ -3990 +3991 @@
     (assert (or streamp pathnamep))
     (let* ((afterp (position :close-stream body))
-           (before (if afterp (subseq body 0 (1- afterp)) body))
+           (before (if afterp (subseq body 0 afterp) body))
            (after (when afterp (subseq body (1+ afterp))))
            (beforef (gensym "BEFORE"))
@@ -4010 +4011 @@
           ,@(when type `(:type ,type))
           ,@(when keep `(:keep ,keep))
-          ,@(when after `(:after `#',afterf))
+          ,@(when after `(:after #',afterf))
           ,@(when element-type `(:element-type ,element-type))
           ,@(when external-format `(:external-format ,external-format))))))
@@ -4468 +4469 @@
                        &key kind output-name prologue-code epilogue-code extra-object-files
                          (prelude () preludep) (postlude () postludep)
-                         (entry-point () entry-point-p) build-args)
+                         (entry-point () entry-point-p) build-args no-uiop)
     (declare (ignorable destination lisp-object-files extra-object-files kind output-name
                         prologue-code epilogue-code prelude preludep postlude postludep
-                        entry-point entry-point-p build-args))
+                        entry-point entry-point-p build-args no-uiop))
     "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options"
     ;; Is it meaningful to run these in the current environment?
@@ -4478 +4479 @@
     #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image)
     #+(or ecl mkcl)
-    (let ((epilogue-forms
-            (append
-             (when epilogue-code `(,epilogue-code))
-             (when postludep `((setf *image-postlude* ',postlude)))
-             (when preludep `((setf *image-prelude* ',prelude)))
-             (when entry-point-p `((setf *image-entry-point* ',entry-point)))
-             (case kind
-               ((:image)
-                (setf kind :program) ;; to ECL, it's just another program.
-                `((setf *image-dumped-p* t)
-                  (si::top-level #+ecl t) (quit)))
-               ((:program)
-                `((setf *image-dumped-p* :executable)
-                  (shell-boolean-exit
-                   (restore-image))))))))
+    (let ((epilogue-code
+            (if no-uiop
+                epilogue-code
+                (let ((forms
+                        (append
+                         (when epilogue-code `(,epilogue-code))
+                         (when postludep `((setf *image-postlude* ',postlude)))
+                         (when preludep `((setf *image-prelude* ',prelude)))
+                         (when entry-point-p `((setf *image-entry-point* ',entry-point)))
+                         (case kind
+                           ((:image)
+                            (setf kind :program) ;; to ECL, it's just another program.
+                            `((setf *image-dumped-p* t)
+                              (si::top-level #+ecl t) (quit)))
+                           ((:program)
+                            `((setf *image-dumped-p* :executable)
+                              (shell-boolean-exit
+                               (restore-image))))))))
+                  (when forms `(progn ,@forms))))))
       #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl))
       (apply #+ecl 'c::builder #+ecl kind
@@ -4505 +4510 @@
              (append
               (when prologue-code `(:prologue-code ,prologue-code))
-              (when epilogue-forms `(:epilogue-code (progn ,@epilogue-forms)))
+              (when epilogue-code `(:epilogue-code ,epilogue-code))
               #+mkcl (when extra-object-files `(:object-files ,extra-object-files))
               build-args)))))
@@ -5428 +5433 @@
    #+sbcl #:sb-grovel-unknown-constant-condition
    ;; Functions & Macros
-   #:get-optimization-settings #:proclaim-optimization-settings
+   #:get-optimization-settings #:proclaim-optimization-settings #:with-optimization-settings
    #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions
    #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions
@@ -5468 +5473 @@
   (defvar *previous-optimization-settings* nil
     "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
+  (defparameter +optimization-variables+
+    ;; TODO: allegro genera corman mcl
+    (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*)
+        #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents)
+        #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety*
+                    ccl::*nx-debug* ccl::*nx-cspeed*)
+        #+(or cmu scl) '(c::*default-cookie*)
+        #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*))
+        #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*)
+        #+lispworks '(compiler::*optimization-level*)
+        #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*)
+        #+sbcl '(sb-c::*policy*)))
   (defun get-optimization-settings ()
     "Get current compiler optimization settings, ready to PROCLAIM again"
-    #-(or clisp clozure cmu ecl mkcl sbcl scl)
-    (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type))
-    #+clozure (ccl:declaration-information 'optimize nil)
-    #+(or clisp cmu ecl mkcl sbcl scl)
+    #-(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
+    (warn "~S does not support ~S. Please help me fix that."
+          'get-optimization-settings (implementation-type))
+    #+(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl)
     (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
-      #.`(loop :for x :in settings
-               ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
-                     #+mkcl '(:for v :in '(si::*speed* si::*space* si::*safety* si::*debug*))
-                     #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
-               :for y = (or #+clisp (gethash x system::*optimize*)
-                            #+(or ecl mkcl) (symbol-value v)
-                            #+(or cmu scl) (funcall f c::*default-cookie*)
+      #.`(loop #+(or allegro clozure)
+               ,@'(:with info = #+allegro (sys:declaration-information 'optimize)
+                   #+clozure (ccl:declaration-information 'optimize nil))
+               :for x :in settings
+               ,@(or #+(or abcl ecl gcl mkcl xcl) '(:for v :in +optimization-variables+))
+               :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order
+                            #+clisp (gethash x system::*optimize* 1)
+                            #+(or abcl ecl mkcl xcl) (symbol-value v)
+                            #+(or cmu scl) (slot-value c::*default-cookie*
+                                                       (case x (compilation-speed 'c::cspeed)
+                                                             (otherwise x)))
+                            #+lispworks (slot-value compiler::*optimization-level* x)
                             #+sbcl (cdr (assoc x sb-c::*policy*)))
                :when y :collect (list x y))))
@@ -5489 +5511 @@
     (let ((settings (get-optimization-settings)))
       (unless (equal *previous-optimization-settings* settings)
-        (setf *previous-optimization-settings* settings)))))
+        (setf *previous-optimization-settings* settings))))
+  (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body)
+    #+(or allegro clisp)
+    (let ((previous-settings (gensym "PREVIOUS-SETTINGS")))
+      `(let ((,previous-settings (get-optimization-settings)))
+         ,@(when settings `((proclaim `(optimize ,@,settings))))
+         (unwind-protect (progn ,@body)
+           (proclaim `(optimize ,@,previous-settings)))))
+    #-(or allegro clisp)
+    `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v))
+       ,@(when settings `((proclaim `(optimize ,@,settings))))
+       ,@body)))
 
 
@@ -6536 +6569 @@
    :uiop/configuration :uiop/backward-driver))
 
-#+mkcl (provide :uiop)
+;; Provide both lowercase and uppercase, to satisfy more people.
+(provide "uiop") (provide "UIOP")
 ;;;; -------------------------------------------------------------------------
 ;;;; Handle upgrade as forward- and backward-compatibly as possible
@@ -6606 +6640 @@
          ;; "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 "3.1.0.103")
+         (asdf-version "3.1.2.2")
          (existing-version (asdf-version)))
     (setf *asdf-version* asdf-version)
@@ -6964 +6998 @@
 ;;;; version-satisfies
 (with-upgradability ()
+  ;; short-circuit testing of null version specifications.
+  ;; this is an all-pass, without warning
+  (defmethod version-satisfies :around ((c t) (version null))
+    t)
   (defmethod version-satisfies ((c component) version)
     (unless (and version (slot-boundp c 'version) (component-version c))
       (when version
         (warn "Requested version ~S but ~S has no version" version c))
-      (return-from version-satisfies t))
+      (return-from version-satisfies nil))
     (version-satisfies (component-version c) version))
 
@@ -9127 +9165 @@
     ;; If we're in the middle of something, restart it.
     (when *asdf-cache*
-      (let ((l (loop* :for (x y) :being :the hash-keys :of *asdf-cache*
-                      :when (eq x 'find-system) :collect y)))
+      (let ((l (loop :for k :being :the hash-keys :of *asdf-cache*
+                     :when (eq (first k) 'find-system) :collect (second k))))
         (clrhash *asdf-cache*)
         (dolist (s l) (find-system s nil)))))
@@ -10163 +10201 @@
     ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code)
      (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code)
+     (no-uiop :initform nil :initarg :no-uiop :reader no-uiop)
      (prefix-lisp-object-files :initarg :prefix-lisp-object-files
                                :initform nil :accessor prefix-lisp-object-files)
@@ -10174 +10213 @@
   (defmethod prologue-code ((x t)) nil)
   (defmethod epilogue-code ((x t)) nil)
+  (defmethod no-uiop ((x t)) nil)
   (defmethod prefix-lisp-object-files ((x t)) nil)
   (defmethod postfix-lisp-object-files ((x t)) nil)
@@ -10273 +10313 @@
       ((member :dll :lib :shared-library :static-library :program :object :program)
        (compile-file-type :type bundle-type))
-      ((member :image) "image")
+      ((member :image) #-allegro "image" #+allegro "dxl")
       ((member :dll :shared-library) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
       ((member :lib :static-library) (cond ((os-unix-p) "a")
-             ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
+                                           ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
       ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
 
@@ -10337 +10377 @@
     (setf (extra-build-args instance)
           (remove-plist-keys
-           '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files)
+           '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files
+             :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments
            (operation-original-initargs instance))))
 
@@ -10587 +10628 @@
 
   (defun asdf-library-pathname ()
-    #+ecl (compile-file-pathname "sys:asdf" :type :lib)
+    #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style
+              (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style
     #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf"))
 
+  (defun compiler-library-pathname ()
+    #+ecl (compile-file-pathname "sys:cmp" :type :lib)
+    #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp"))
+
   (defun make-library-system (name pathname)
-    (make-instance 'prebuilt-system :name name :static-library (resolve-symlinks* pathname)))
+    (make-instance 'prebuilt-system
+                   :name (coerce-name name) :static-library (resolve-symlinks* pathname)))
 
   (defmethod component-depends-on :around ((o image-op) (c system))
@@ -10597 +10644 @@
       (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name)))
         `((,lib-op
-           #+mkcl ,@(unless (has-it-p "cmp")
-                      `(,(make-library-system
-                          "cmp" (make-pathname :type (bundle-pathname-type :lib)
-                                               :defaults #p"sys:cmp"))))
-           ,@(unless (or (has-it-p "asdf") (has-it-p "uiop"))
+           ,@(unless (or (no-uiop c) (has-it-p "cmp"))
+               `(,(make-library-system
+                   "cmp" (compiler-library-pathname))))
+           ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf"))
                `(,(cond
                     ((system-source-directory :uiop) (find-system :uiop))
                     ((system-source-directory :asdf) (find-system :asdf))
-                    (t (make-fake-asdf-system "asdf" (asdf-library-pathname))))))
+                    (t (make-library-system "asdf" (asdf-library-pathname))))))
            ,@deps)))))
 
@@ -10625 +10671 @@
                :build-args (or (extra-build-args o) (when programp (extra-build-args c)))
                :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c)))
+               :no-uiop (no-uiop c)
                (when programp `(:entry-point ,(component-entry-point c))))))))
 
@@ -10638 +10685 @@
 
 
-;;; Backward compatibility with pre-3.1.1 names
+;;; Backward compatibility with pre-3.1.2 names
 (defclass fasl-op (selfward-operation)
   ((selfward-operation :initform 'compile-bundle-op :allocation :class)))
@@ -10918 +10965 @@
 ;;;; Package systems in the style of quick-build or faslpath
 
-(uiop:define-package :asdf/package-system
-  (:recycle :asdf/package-system :asdf)
+(uiop:define-package :asdf/package-inferred-system
+  (:recycle :asdf/package-inferred-system :asdf/package-system :asdf)
   (:use :uiop/common-lisp :uiop
         :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility
         :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action)
   (:export
-   #:package-system #:register-system-packages #:sysdef-package-system-search
-   #:*defpackage-forms* #:*package-systems* #:package-system-missing-package-error))
-(in-package :asdf/package-system)
-
-(with-upgradability ()
-  (defparameter *defpackage-forms* '(cl:defpackage uiop:define-package))
-
-  (defun initial-package-systems-table ()
+   #:package-inferred-system #:sysdef-package-inferred-system-search
+   #:package-system ;; backward compatibility only. To be removed.
+   #:register-system-packages
+   #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error))
+(in-package :asdf/package-inferred-system)
+
+(with-upgradability ()
+  (defparameter *defpackage-forms* '(defpackage define-package))
+
+  (defun initial-package-inferred-systems-table ()
     (let ((h (make-hash-table :test 'equal)))
       (dolist (p (list-all-packages))
@@ -10938 +10987 @@
       h))
 
-  (defvar *package-systems* (initial-package-systems-table))
-
-  (defclass package-system (system)
+  (defvar *package-inferred-systems* (initial-package-inferred-systems-table))
+
+  (defclass package-inferred-system (system)
     ())
+
+  ;; For backward compatibility only. To be removed in an upcoming release:
+  (defclass package-system (package-inferred-system) ())
 
   (defun defpackage-form-p (form)
@@ -10956 +11008 @@
       (stream-defpackage-form f)))
 
-  (define-condition package-system-missing-package-error (system-definition-error)
+  (define-condition package-inferred-system-missing-package-error (system-definition-error)
     ((system :initarg :system :reader error-system)
      (pathname :initarg :pathname :reader error-pathname))
     (:report (lambda (c s)
                (format s (compatfmt "~@<No package form found while ~
-                                     trying to define package-system ~A from file ~A~>")
+                                     trying to define package-inferred-system ~A from file ~A~>")
                        (error-system c) (error-pathname c)))))
 
@@ -10990 +11042 @@
     (let ((name (or (eq system t) (coerce-name system))))
       (dolist (p (ensure-list packages))
-        (setf (gethash (package-designator-name p) *package-systems*) name))))
+        (setf (gethash (package-designator-name p) *package-inferred-systems*) name))))
 
   (defun package-name-system (package-name)
@@ -10996 +11048 @@
 otherwise return a default system name computed from PACKAGE-NAME."
     (check-type package-name string)
-    (if-let ((system-name (gethash package-name *package-systems*)))
+    (if-let ((system-name (gethash package-name *package-inferred-systems*)))
       system-name
       (string-downcase package-name)))
 
-  (defun package-system-file-dependencies (file &optional system)
+  (defun package-inferred-system-file-dependencies (file &optional system)
     (if-let (defpackage-form (file-defpackage-form file))
       (remove t (mapcar 'package-name-system (package-dependencies defpackage-form)))
-      (error 'package-system-missing-package-error :system system :pathname file)))
-
-  (defun same-package-system-p (system name directory subpath dependencies)
-    (and (eq (type-of system) 'package-system)
+      (error 'package-inferred-system-missing-package-error :system system :pathname file)))
+
+  (defun same-package-inferred-system-p (system name directory subpath dependencies)
+    (and (eq (type-of system) 'package-inferred-system)
          (equal (component-name system) name)
          (pathname-equal directory (component-pathname system))
@@ -11018 +11070 @@
                             (equal (slot-value child 'relative-pathname) subpath))))))))
 
-  (defun sysdef-package-system-search (system)
+  (defun sysdef-package-inferred-system-search (system)
     (let ((primary (primary-system-name system)))
       (unless (equal primary system)
         (let ((top (find-system primary nil)))
-          (when (typep top 'package-system)
+          (when (typep top 'package-inferred-system)
             (if-let (dir (system-source-directory top))
               (let* ((sub (subseq system (1+ (length primary))))
@@ -11028 +11080 @@
                                      :truename *resolve-symlinks*)))
                 (when (file-pathname-p f)
-                  (let ((dependencies (package-system-file-dependencies f system))
+                  (let ((dependencies (package-inferred-system-file-dependencies f system))
                         (previous (cdr (system-registered-p system))))
-                    (if (same-package-system-p previous system dir sub dependencies)
+                    (if (same-package-inferred-system-p previous system dir sub dependencies)
                         previous
                         (eval `(defsystem ,system
-                                 :class package-system
+                                 :class package-inferred-system
                                  :source-file nil
                                  :pathname ,dir
@@ -11040 +11092 @@
 
 (with-upgradability ()
-  (pushnew 'sysdef-package-system-search *system-definition-search-functions*))
+  (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*)
+  (setf *system-definition-search-functions*
+        (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil)
+                *system-definition-search-functions*)))
 ;;;; ---------------------------------------------------------------------------
 ;;;; Handle ASDF package upgrade, including implementation-dependent magic.
@@ -11055 +11110 @@
    :asdf/output-translations :asdf/source-registry
    :asdf/plan :asdf/operate :asdf/parse-defsystem :asdf/bundle :asdf/concatenate-source
-   :asdf/backward-internals :asdf/backward-interface :asdf/package-system)
+   :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system)
   ;; Note: (1) we are NOT automatically reexporting everything from previous packages.
   ;; (2) we only reexport UIOP functionality when backward-compatibility requires it.
@@ -11102 +11157 @@
    #:file-type #:source-file-type
 
-   #:package-system #:register-system-packages
+   #:package-inferred-system #:register-system-packages
+   #:package-system ;; backward-compatibility during migration, to be removed in a further release.
 
    #:component-children          ; component accessors
@@ -11165 +11221 @@
    #:circular-dependency        ; errors
    #:duplicate-names #:non-toplevel-system #:non-system-system
-   #:package-system-missing-package-error
+   #:package-inferred-system-missing-package-error
    #:operation-definition-warning #:operation-definition-error
 
@@ -11215 +11271 @@
 (uiop/package:define-package :asdf/user
   (:nicknames :asdf-user)
-  ;; NB: releases before 3.1.1 this :use'd only uiop/package instead of uiop below.
+  ;; NB: releases before 3.1.2 this :use'd only uiop/package instead of uiop below.
   ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop.
   ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo.