Skip to content
Snippets Groups Projects
Commit ba02b6a7 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

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

Also settle on names for resume-image API.
parent d862e5a9
No related branches found
No related tags found
No related merge requests found
...@@ -15,7 +15,7 @@ ...@@ -15,7 +15,7 @@
:licence "MIT" :licence "MIT"
:description "Another System Definition Facility" :description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems." :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 () :depends-on ()
:components ((:module "build" :components ((:file "asdf")))) :components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
...@@ -127,7 +127,7 @@ ...@@ -127,7 +127,7 @@
(component-pathname ret) ; eagerly compute the absolute pathname (component-pathname ret) ; eagerly compute the absolute pathname
(when versionp (when versionp
(unless (parse-version (normalize-version (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~]~@:>") (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>")
version name parent))) version name parent)))
(when (typep ret 'parent-component) (when (typep ret 'parent-component)
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- ;; -*- 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: ;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>. ;;; please mail to <asdf-devel@common-lisp.net>.
......
...@@ -13,7 +13,7 @@ ...@@ -13,7 +13,7 @@
#:register-image-resume-hook #:register-image-dump-hook #:register-image-resume-hook #:register-image-dump-hook
#:call-image-resume-hook #:call-image-dump-hook #:call-image-resume-hook #:call-image-dump-hook
#:initialize-asdf-utilities #:initialize-asdf-utilities
#:resume-image #:run-resumed-program #:dump-image #:resume-image #:run-resumed-image #:dump-image
)) ))
(in-package :asdf/image) (in-package :asdf/image)
...@@ -216,9 +216,9 @@ if we are not called from a directly executable image dumped by XCVB." ...@@ -216,9 +216,9 @@ if we are not called from a directly executable image dumped by XCVB."
(when entry-point (when entry-point
(apply entry-point *command-line-arguments*))) (apply entry-point *command-line-arguments*)))
(defun* run-resumed-program () (defun* run-resumed-image ()
(with-coded-exit () (with-coded-exit ()
(let ((ret (resume-program))) (let ((ret (resume-image)))
(if (typep ret 'integer) (if (typep ret 'integer)
(quit ret) (quit ret)
(quit 99))))) (quit 99)))))
...@@ -253,26 +253,26 @@ if we are not called from a directly executable image dumped by XCVB." ...@@ -253,26 +253,26 @@ if we are not called from a directly executable image dumped by XCVB."
(list (list
:norc t :norc t
:script nil :script nil
:init-function #'resume :init-function #'run-resumed-image
;; :parse-options nil ;--- requires a non-standard patch to clisp. ;; :parse-options nil ;--- requires a non-standard patch to clisp.
))) )))
#+clozure #+clozure
(ccl:save-application filename :prepend-kernel t (ccl:save-application filename :prepend-kernel t
:toplevel-function (when executable #'resume)) :toplevel-function (when executable #'run-resumed-image))
#+(or cmu scl) #+(or cmu scl)
(progn (progn
(ext:gc :full t) (ext:gc :full t)
(setf ext:*batch-mode* nil) (setf ext:*batch-mode* nil)
(setf ext::*gc-run-time* 0) (setf ext::*gc-run-time* 0)
(apply 'ext:save-lisp filename #+cmu :executable #+cmu t (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 #+gcl
(progn (progn
(si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t)
(si::save-system filename)) (si::save-system filename))
#+lispworks #+lispworks
(if executable (if executable
(lispworks:deliver 'resume filename 0 :interface nil) (lispworks:deliver 'run-resumed-image filename 0 :interface nil)
(hcl:save-image filename :environment nil)) (hcl:save-image filename :environment nil))
#+sbcl #+sbcl
(progn (progn
...@@ -280,7 +280,7 @@ if we are not called from a directly executable image dumped by XCVB." ...@@ -280,7 +280,7 @@ if we are not called from a directly executable image dumped by XCVB."
(setf sb-ext::*gc-run-time* 0) (setf sb-ext::*gc-run-time* 0)
(apply 'sb-ext:save-lisp-and-die filename (apply 'sb-ext:save-lisp-and-die filename
:executable t ;--- always include the runtime that goes with the core :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) #-(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)) (die 98 "Can't dump ~S: asdf doesn't support image dumping with this Lisp implementation.~%" filename))
......
...@@ -119,7 +119,7 @@ a simple vector of length 2, arguments to find-symbol* with result as above, ...@@ -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." or a string describing the format-control of a simple-condition."
(etypecase x (etypecase x
(symbol (typep condition 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)) (function (funcall x condition))
(string (and (typep condition 'simple-condition) (string (and (typep condition 'simple-condition)
#+(or allegro clozure cmu scl) ;; On SBCL, it's always set & the check warns #+(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)." ...@@ -334,4 +334,3 @@ for processing later (possibly in a different process)."
(scm:concatenate-system output :fasls-to-concatenate)) (scm:concatenate-system output :fasls-to-concatenate))
(loop :for f :in fasls :do (ignore-errors (delete-file f))) (loop :for f :in fasls :do (ignore-errors (delete-file f)))
(ignore-errors (lispworks:delete-system :fasls-to-concatenate))))) (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))
...@@ -16,6 +16,7 @@ ...@@ -16,6 +16,7 @@
#:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern* #:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern*
#:symbol-shadowing-p #:rehome-symbol #:symbol-shadowing-p #:rehome-symbol
#:delete-package* #:package-names #:packages-from-names #:delete-package* #:package-names #:packages-from-names
#:reify-symbol #:unreify-symbol
#:package-definition-form #:ensure-package #:define-package)) #:package-definition-form #:ensure-package #:define-package))
(in-package :asdf/package) (in-package :asdf/package)
...@@ -64,18 +65,41 @@ or when loading the package is optional." ...@@ -64,18 +65,41 @@ or when loading the package is optional."
(values nil nil)))) (values nil nil))))
(defun symbol-shadowing-p (symbol package) (defun symbol-shadowing-p (symbol package)
(and (member symbol (package-shadowing-symbols package)) t)) (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) (defun symbol-package-name (symbol)
(let ((package (symbol-package symbol))) (let ((package (symbol-package symbol)))
(and package (package-name package)))) (and package (package-name package))))
(defun symbol-vector (symbol) (defun standard-common-lisp-symbol-p (symbol)
(vector (symbol-name symbol) (symbol-package-name symbol))) (multiple-value-bind (sym status) (find-symbol* symbol :common-lisp nil)
(defun vector-symbol (vector) (and (eq sym symbol) (eq status :external))))
(let* ((symbol-name (aref vector 0)) (defun reify-package (package &optional package-context)
(package-name (aref vector 1))) (if (eq package package-context) t
(if package-name (intern symbol-name package-name) (etypecase package
(make-symbol symbol-name)))) (null nil)
(defun home-package-p (symbol package) ((eql (find-package :cl)) :cl)
(eq (symbol-package symbol) (find-package* package)))) (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) (eval-when (:load-toplevel :compile-toplevel :execute)
#+(or clisp clozure) #+(or clisp clozure)
...@@ -260,37 +284,45 @@ or when loading the package is optional." ...@@ -260,37 +284,45 @@ or when loading the package is optional."
;;; ensure-package, define-package ;;; ensure-package, define-package
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(defvar *fishy-package-changes* '(t)) (defvar *record-fishy-package-changes* '(t))
(defun ensure-package (name &key (defvar *fishy-package-changes* '())
(fishyp *fishy-package-changes*) (defun flush-fishy ()
nicknames documentation use (when *fishy-package-changes*
shadow shadowing-import-from (push (nreverse *fishy-package-changes*) *record-fishy-package-changes*)
import-from export intern (setf *fishy-package-changes* nil)))
recycle mix reexport (defun record-fishy (info)
unintern) (push info *fishy-package-changes*))
(let* ((name (string name)) (macrolet ((when-fishy (&body body)
(nicknames (mapcar #'string nicknames)) `(when *record-fishy-package-changes* ,@body))
(names (cons name nicknames)) (fishy (&rest info)
(previous (packages-from-names names)) `(when-fishy (record-fishy (list ,@info)))))
(discarded (cdr previous)) (defun ensure-package (name &key
(to-delete ()) nicknames documentation use
(package (or (first previous) (make-package name :nicknames nicknames))) shadow shadowing-import-from
(recycle (packages-from-names recycle)) import-from export intern
(use (mapcar 'find-package* use)) recycle mix reexport
(mix (mapcar 'find-package* mix)) unintern)
(reexport (mapcar 'find-package* reexport)) (let* ((name (string name))
(shadow (mapcar 'string shadow)) (nicknames (mapcar #'string nicknames))
(export (mapcar 'string export)) (names (cons name nicknames))
(intern (mapcar 'string intern)) (previous (packages-from-names names))
(unintern (mapcar 'string unintern)) (discarded (cdr previous))
(shadowed (make-hash-table :test 'equal)) ; string to bool (to-delete ())
(imported (make-hash-table :test 'equal)) ; string to bool (package (or (first previous) (make-package name :nicknames nicknames)))
(exported (make-hash-table :test 'equal)) ; string to bool (recycle (packages-from-names recycle))
;; string to list canonical package and providing package: (use (mapcar 'find-package* use))
(inherited (make-hash-table :test 'equal)) (mix (mapcar 'find-package* mix))
(fishy ())) ; fishy stuff we did (reexport (mapcar 'find-package* reexport))
(macrolet ((fishy (&rest info) (shadow (mapcar 'string shadow))
`(when fishyp (push (list ,@info) fishy)))) (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 (labels
((ensure-shadowing-import (name p) ((ensure-shadowing-import (name p)
(let ((import (find-symbol* name p))) (let ((import (find-symbol* name p)))
...@@ -367,7 +399,7 @@ or when loading the package is optional." ...@@ -367,7 +399,7 @@ or when loading the package is optional."
name (package-name sp) (package-name xp)))) name (package-name sp) (package-name xp))))
(t (t
(setf (gethash name inherited) (list sp p)) (setf (gethash name inherited) (list sp p))
(when status (when (and status (not (eq sp xp)))
(let ((shadowing (symbol-shadowing-p existing package))) (let ((shadowing (symbol-shadowing-p existing package)))
(fishy :inherited name (package-name p) (package-name sp) (fishy :inherited name (package-name p) (package-name sp)
(package-name xp)) (package-name xp))
...@@ -436,10 +468,9 @@ or when loading the package is optional." ...@@ -436,10 +468,9 @@ or when loading the package is optional."
:for n = (remove-if #'(lambda (x) (member x names :test 'equal)) :for n = (remove-if #'(lambda (x) (member x names :test 'equal))
(package-names p)) (package-names p))
:do (fishy :nickname (package-names p)) :do (fishy :nickname (package-names p))
(if n (rename-package p (first n) (rest n)) (cond (n (rename-package p (first n) (rest n)))
(progn (t (rename-package-away p)
(rename-package-away p) (push p to-delete))))
(push p to-delete))))
(rename-package package name nicknames) (rename-package package name nicknames)
(dolist (name unintern) (dolist (name unintern)
(multiple-value-bind (existing status) (find-symbol name package) (multiple-value-bind (existing status) (find-symbol name package)
...@@ -494,7 +525,7 @@ or when loading the package is optional." ...@@ -494,7 +525,7 @@ or when loading the package is optional."
(do-symbols (sym package) (do-symbols (sym package)
(ensure-symbol (symbol-name sym))) (ensure-symbol (symbol-name sym)))
(map () 'delete-package* to-delete) (map () 'delete-package* to-delete)
(when fishy (push (cons name fishy) *fishy-package-changes*)) (flush-fishy)
package))))) package)))))
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
......
...@@ -32,7 +32,7 @@ ...@@ -32,7 +32,7 @@
;; "2.345.6" would be a development version in the official upstream ;; "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.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 ;; "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-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))) (already-there (equal asdf-version existing-version)))
......
"2.26.88" "2.26.89"
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment