From ba02b6a7762f000f2ca7daee94a616f90fe88a5b Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Sun, 13 Jan 2013 21:23:10 -0500 Subject: [PATCH] 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. --- asdf.asd | 2 +- defsystem.lisp | 2 +- header.lisp | 2 +- image.lisp | 16 +++--- lisp-build.lisp | 3 +- package.lisp | 123 +++++++++++++++++++++++++++++----------------- upgrade.lisp | 2 +- version.lisp-expr | 2 +- 8 files changed, 91 insertions(+), 61 deletions(-) diff --git a/asdf.asd b/asdf.asd index 4062e0c4a..00a197c7e 100644 --- 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 f150be24e..2b703f44a 100644 --- 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 1abe3e2f9..9a1cd8da9 100644 --- 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 e02fe2c84..04ecebb10 100644 --- 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 e5aaf3f6e..6d4c3463a 100644 --- 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 aeef01151..903c373f4 100644 --- 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 e8bc6ccc4..1d3a8daa3 100644 --- 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 1fc945218..f50f76775 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -1 +1 @@ -"2.26.88" +"2.26.89" -- GitLab