2.26.89: Be nicer with :read-file-form versions. Don't consider equal inherited symbo...

Also settle on names for resume-image API.

diff --git a/asdf.asd b/asdf.asd
index 4062e0c..00a197c 100644 (file)
--- a/asdf.asd
+++ b/asdf.asd
@@ -15,7 +15,7 @@
   :licence "MIT"
   :description "Another System Definition Facility"
   :long-description "ASDF builds Common Lisp software organized into defined systems."
-  :version "2.26.88" ;; to be automatically updated by bin/bump-revision
+  :version "2.26.89" ;; to be automatically updated by bin/bump-revision
   :depends-on ()
   :components ((:module "build" :components ((:file "asdf"))))
   :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))

diff --git a/defsystem.lisp b/defsystem.lisp
index f150be2..2b703f4 100644 (file)
--- a/defsystem.lisp
+++ b/defsystem.lisp
@@ -127,7 +127,7 @@
       (component-pathname ret) ; eagerly compute the absolute pathname
       (when versionp
         (unless (parse-version (normalize-version
-                                version (component-pathname (component-system ret))) nil)
+                                version (system-source-directory (component-system ret))) nil)
           (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
                 version name parent)))
       (when (typep ret 'parent-component)

diff --git a/header.lisp b/header.lisp
index 1abe3e2..9a1cd8d 100644 (file)
--- a/header.lisp
+++ b/header.lisp
@@ -1,5 +1,5 @@
 ;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.26.88: Another System Definition Facility.
+;;; This is ASDF 2.26.89: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.

diff --git a/image.lisp b/image.lisp
index e02fe2c..04ecebb 100644 (file)
--- a/image.lisp
+++ b/image.lisp
@@ -13,7 +13,7 @@
    #:register-image-resume-hook #:register-image-dump-hook
    #:call-image-resume-hook #:call-image-dump-hook
    #:initialize-asdf-utilities
-   #:resume-image #:run-resumed-program #:dump-image 
+   #:resume-image #:run-resumed-image #:dump-image 
 ))
 (in-package :asdf/image)
 
@@ -216,9 +216,9 @@ if we are not called from a directly executable image dumped by XCVB."
   (when entry-point
     (apply entry-point *command-line-arguments*)))
 
-(defun* run-resumed-program ()
+(defun* run-resumed-image ()
   (with-coded-exit ()
-    (let ((ret (resume-program)))
+    (let ((ret (resume-image)))
       (if (typep ret 'integer)
           (quit ret)
           (quit 99)))))
@@ -253,26 +253,26 @@ if we are not called from a directly executable image dumped by XCVB."
      (list
       :norc t
       :script nil
-      :init-function #'resume
+      :init-function #'run-resumed-image
       ;; :parse-options nil ;--- requires a non-standard patch to clisp.
       )))
   #+clozure
   (ccl:save-application filename :prepend-kernel t
-                        :toplevel-function (when executable #'resume))
+                        :toplevel-function (when executable #'run-resumed-image))
   #+(or cmu scl)
   (progn
    (ext:gc :full t)
    (setf ext:*batch-mode* nil)
    (setf ext::*gc-run-time* 0)
    (apply 'ext:save-lisp filename #+cmu :executable #+cmu t
-          (when executable '(:init-function resume :process-command-line nil))))
+          (when executable '(:init-function run-resumed-image :process-command-line nil))))
   #+gcl
   (progn
    (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
    (si::save-system filename))
   #+lispworks
   (if executable
-      (lispworks:deliver 'resume filename 0 :interface nil)
+      (lispworks:deliver 'run-resumed-image filename 0 :interface nil)
       (hcl:save-image filename :environment nil))
   #+sbcl
   (progn
@@ -280,7 +280,7 @@ if we are not called from a directly executable image dumped by XCVB."
    (setf sb-ext::*gc-run-time* 0)
    (apply 'sb-ext:save-lisp-and-die filename
     :executable t ;--- always include the runtime that goes with the core
-    (when executable (list :toplevel #'resume :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
+    (when executable (list :toplevel #'run-resumed-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables
   #-(or allegro clisp clozure cmu gcl lispworks sbcl scl)
   (die 98 "Can't dump ~S: asdf doesn't support image dumping with this Lisp implementation.~%" filename))
 

diff --git a/lisp-build.lisp b/lisp-build.lisp
index e5aaf3f..6d4c346 100644 (file)
--- a/lisp-build.lisp
+++ b/lisp-build.lisp
@@ -119,7 +119,7 @@ a simple vector of length 2, arguments to find-symbol* with result as above,
 or a string describing the format-control of a simple-condition."
   (etypecase x
     (symbol (typep condition x))
-    ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))
+    ((simple-vector 2) (typep condition (unreify-symbol x)))
     (function (funcall x condition))
     (string (and (typep condition 'simple-condition)
                  #+(or allegro clozure cmu scl) ;; On SBCL, it's always set & the check warns
@@ -334,4 +334,3 @@ for processing later (possibly in a different process)."
            (scm:concatenate-system output :fasls-to-concatenate))
       (loop :for f :in fasls :do (ignore-errors (delete-file f)))
       (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))
-

diff --git a/package.lisp b/package.lisp
index aeef011..903c373 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -16,6 +16,7 @@
    #:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern*
    #:symbol-shadowing-p #:rehome-symbol
    #:delete-package* #:package-names #:packages-from-names
+   #:reify-symbol #:unreify-symbol
    #:package-definition-form #:ensure-package #:define-package))
 
 (in-package :asdf/package)
@@ -64,18 +65,41 @@ or when loading the package is optional."
         (values nil nil))))
   (defun symbol-shadowing-p (symbol package)
     (and (member symbol (package-shadowing-symbols package)) t))
+  (defun home-package-p (symbol package)
+    (eq (symbol-package symbol) (find-package* package))))
+
+(eval-when (:load-toplevel :compile-toplevel :execute)
   (defun symbol-package-name (symbol)
     (let ((package (symbol-package symbol)))
       (and package (package-name package))))
-  (defun symbol-vector (symbol)
-    (vector (symbol-name symbol) (symbol-package-name symbol)))
-  (defun vector-symbol (vector)
-    (let* ((symbol-name (aref vector 0))
-           (package-name (aref vector 1)))
-      (if package-name (intern symbol-name package-name)
-          (make-symbol symbol-name))))
-  (defun home-package-p (symbol package)
-    (eq (symbol-package symbol) (find-package* package))))
+  (defun standard-common-lisp-symbol-p (symbol)
+    (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
+      (and (eq sym symbol) (eq status :external))))
+  (defun reify-package (package &optional package-context)
+    (if (eq package package-context) t
+        (etypecase package
+          (null nil)
+          ((eql (find-package :cl)) :cl)
+          (package (package-name package)))))
+  (defun unreify-package (package &optional package-context)
+    (etypecase package
+      (null nil)
+      ((eql t) package-context)
+      ((or symbol string) (find-package package))))
+  (defun reify-symbol (symbol &optional package-context)
+    (etypecase symbol
+      ((or keyword (satisfies standard-common-lisp-symbol-p)) symbol)
+      (symbol (vector (symbol-name symbol)
+                      (reify-package (symbol-package symbol) package-context)))))
+  (defun unreify-symbol (symbol &optional package-context)
+    (etypecase symbol
+      (symbol symbol)
+      ((simple-vector 2)
+       (let* ((symbol-name (svref symbol 0))
+              (package-foo (svref symbol 1))
+              (package (unreify-package package-foo package-context)))
+         (if package (intern symbol-name package)
+             (make-symbol symbol-name)))))))
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
   #+(or clisp clozure)
@@ -260,37 +284,45 @@ or when loading the package is optional."
 ;;; ensure-package, define-package
 
 (eval-when (:load-toplevel :compile-toplevel :execute)
-  (defvar *fishy-package-changes* '(t))
-  (defun ensure-package (name &key
-                                (fishyp *fishy-package-changes*)
-                                nicknames documentation use
-                                shadow shadowing-import-from
-                                import-from export intern
-                                recycle mix reexport
-                                unintern)
-    (let* ((name (string name))
-           (nicknames (mapcar #'string nicknames))
-           (names (cons name nicknames))
-           (previous (packages-from-names names))
-           (discarded (cdr previous))
-           (to-delete ())
-           (package (or (first previous) (make-package name :nicknames nicknames)))
-           (recycle (packages-from-names recycle))
-           (use (mapcar 'find-package* use))
-           (mix (mapcar 'find-package* mix))
-           (reexport (mapcar 'find-package* reexport))
-           (shadow (mapcar 'string shadow))
-           (export (mapcar 'string export))
-           (intern (mapcar 'string intern))
-           (unintern (mapcar 'string unintern))
-           (shadowed (make-hash-table :test 'equal)) ; string to bool
-           (imported (make-hash-table :test 'equal)) ; string to bool
-           (exported (make-hash-table :test 'equal)) ; string to bool
-           ;; string to list canonical package and providing package:
-           (inherited (make-hash-table :test 'equal))
-           (fishy ())) ; fishy stuff we did
-      (macrolet ((fishy (&rest info)
-                   `(when fishyp (push (list ,@info) fishy))))
+  (defvar *record-fishy-package-changes* '(t))
+  (defvar *fishy-package-changes* '())
+  (defun flush-fishy ()
+    (when *fishy-package-changes*
+      (push (nreverse *fishy-package-changes*) *record-fishy-package-changes*)
+      (setf *fishy-package-changes* nil)))
+  (defun record-fishy (info)
+    (push info *fishy-package-changes*))
+  (macrolet ((when-fishy (&body body)
+               `(when *record-fishy-package-changes* ,@body))
+             (fishy (&rest info)
+               `(when-fishy (record-fishy (list ,@info)))))
+    (defun ensure-package (name &key
+                                  nicknames documentation use
+                                  shadow shadowing-import-from
+                                  import-from export intern
+                                  recycle mix reexport
+                                  unintern)
+      (let* ((name (string name))
+             (nicknames (mapcar #'string nicknames))
+             (names (cons name nicknames))
+             (previous (packages-from-names names))
+             (discarded (cdr previous))
+             (to-delete ())
+             (package (or (first previous) (make-package name :nicknames nicknames)))
+             (recycle (packages-from-names recycle))
+             (use (mapcar 'find-package* use))
+             (mix (mapcar 'find-package* mix))
+             (reexport (mapcar 'find-package* reexport))
+             (shadow (mapcar 'string shadow))
+             (export (mapcar 'string export))
+             (intern (mapcar 'string intern))
+             (unintern (mapcar 'string unintern))
+             (shadowed (make-hash-table :test 'equal)) ; string to bool
+             (imported (make-hash-table :test 'equal)) ; string to bool
+             (exported (make-hash-table :test 'equal)) ; string to bool
+             ;; string to list home package and use package:
+             (inherited (make-hash-table :test 'equal)))
+        (when-fishy (record-fishy name))
         (labels
             ((ensure-shadowing-import (name p)
                (let ((import (find-symbol* name p)))
@@ -367,7 +399,7 @@ or when loading the package is optional."
                                name (package-name sp) (package-name xp))))
                      (t
                       (setf (gethash name inherited) (list sp p))
-                      (when status
+                      (when (and status (not (eq sp xp)))
                         (let ((shadowing (symbol-shadowing-p existing package)))
                           (fishy :inherited name (package-name p) (package-name sp)
                                  (package-name xp))
@@ -436,10 +468,9 @@ or when loading the package is optional."
                 :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
                                     (package-names p))
                 :do (fishy :nickname (package-names p))
-                    (if n (rename-package p (first n) (rest n))
-                        (progn
-                          (rename-package-away p)
-                          (push p to-delete))))
+                    (cond (n (rename-package p (first n) (rest n)))
+                          (t (rename-package-away p)
+                             (push p to-delete))))
           (rename-package package name nicknames)
           (dolist (name unintern)
             (multiple-value-bind (existing status) (find-symbol name package)
@@ -494,7 +525,7 @@ or when loading the package is optional."
           (do-symbols (sym package)
             (ensure-symbol (symbol-name sym)))
           (map () 'delete-package* to-delete)
-          (when fishy (push (cons name fishy) *fishy-package-changes*))
+          (flush-fishy)
           package)))))
 
 (eval-when (:load-toplevel :compile-toplevel :execute)

diff --git a/upgrade.lisp b/upgrade.lisp
index e8bc6cc..1d3a8da 100644 (file)
--- a/upgrade.lisp
+++ b/upgrade.lisp
@@ -32,7 +32,7 @@
          ;; "2.345.6" would be a development version in the official upstream
          ;; "2.345.0.7" would be your seventh local modification of official release 2.345
          ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
-         (asdf-version "2.26.88")
+         (asdf-version "2.26.89")
          (existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))

diff --git a/version.lisp-expr b/version.lisp-expr
index 1fc9452..f50f767 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -1 +1 @@
-"2.26.88"
+"2.26.89"