Commit ba02b6a7 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

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
......@@ -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))))
......
......@@ -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)
......
;; -*- 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>.
......
......@@ -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))
......
......@@ -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)))))
......@@ -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)
......
......@@ -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)))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment