diff --git a/TODO b/TODO index da4f37e3dd2cb22ec6e1da54ae2694547ddf6999..7ea2554c68f5a2fa2d6e6f1987121d748b12e282 100644 --- a/TODO +++ b/TODO @@ -4,6 +4,8 @@ ** Have it pass test-lisp ** Have it pass test-upgrade ** Get package upgrade right + Try a newer CLISP than 2.44.1, and if it still breaks, try harder, + by e.g. having ensure-package return a working defpackage form. ** The unconditional ensure-package-unused breaks test-encodings.script, since asdf severs itself from its client package hosting the defsystem form during defsystem-depends-on. diff --git a/asdf.asd b/asdf.asd index b3ee9ef1613c18c58471084b54179f3e7ead803e..4f4b107c50e7fb418972effa0ba742ae5b42dc51 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.77" ;; to be automatically updated by bin/bump-revision + :version "2.26.78" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:module "build" :components ((:file "asdf"))))) diff --git a/header.lisp b/header.lisp index 9d21fd879bbd545250b2ad0c031e40e3d8d5fc9f..cd7618dd59dc854247587857eace8a02e18747fe 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.77: Another System Definition Facility. +;;; This is ASDF 2.26.78: 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 72c805a2c66dfa749142ed4d8a158a53f8b46811..3c71ce21c81e3fc3bfd57202f235b1749dfee8ea 100644 --- a/image.lisp +++ b/image.lisp @@ -78,9 +78,11 @@ This is designed to abstract away the implementation specific quit forms." (defun print-backtrace (out) "Print a backtrace (implementation-defined)" (declare (ignorable out)) + #+clisp (system::print-backtrace) #+clozure (let ((*debug-io* out)) (ccl:print-call-history :count 100 :start-frame-number 1) (finish-output out)) + #+ecl (si::tpl-backtrace) #+sbcl (sb-debug:backtrace #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream 'most-positive-fixnum) diff --git a/package.lisp b/package.lisp index 690846f77c400d98fa67fb6d98dffb3550ceb719..b03135547fcac4b55b80362a1e6f978f1a7be899 100644 --- a/package.lisp +++ b/package.lisp @@ -16,8 +16,7 @@ #:find-package* #:find-symbol* #:symbol-call #:intern* #:unintern* #:symbol-shadowing-p #:rehome-symbol #:delete-package* #:package-names #:packages-from-names - #:symbol-name-package #:package-data - #:ensure-package #:define-package)) + #:package-definition-form #:ensure-package #:define-package)) (in-package :asdf/package) @@ -83,6 +82,35 @@ or when loading the package is optional." (values nil nil)))) (defun symbol-shadowing-p (symbol package) (member symbol (package-shadowing-symbols package))) + #+(or clisp clozure) + (defun get-setf-function-symbol (symbol) + #+clisp (let ((sym (get symbol 'system::setf-function))) + (if sym (values sym :setf-function) + (let ((sym (get symbol 'system::setf-expander))) + (if sym (values sym :setf-expander) + (values nil nil))))) + #+clozure (gethash symbol ccl::%setf-function-names%)) + #+(or clisp clozure) + (defun set-setf-function-symbol (new-setf-symbol symbol &optional kind) + #+clisp (assert (member kind '(:setf-function :setf-expander))) + #+clozure (assert (eq kind t)) + #+clisp + (cond + ((null new-setf-symbol) + (remprop symbol 'system::setf-function) + (remprop symbol 'system::setf-expander)) + ((eq kind :setf-function) + (setf (get symbol 'system::setf-function) new-setf-symbol)) + ((eq kind :setf-expander) + (setf (get symbol 'system::setf-expander) new-setf-symbol))) + #+clozure + (progn + (gethash symbol ccl::%setf-function-names%) new-setf-symbol + (gethash new-setf-symbol ccl::%setf-function-name-inverses%) symbol)) + #+(or clisp clozure) + (defun create-setf-function-symbol (symbol) + #+clisp (system::setf-symbol symbol) + #+clozure (ccl::construct-setf-function-name symbol)) (defun rehome-symbol (symbol package-designator) "Changes the home package of a symbol, also leaving it present in its old home if any" (let* ((name (symbol-name symbol)) @@ -109,18 +137,17 @@ or when loading the package is optional." (if shadowing (shadowing-import symbol old-package) (import symbol old-package)) - #+ccl - (multiple-value-bind (setf-name foundp) - (gethash symbol ccl::%setf-function-names%) - (when foundp - (let* ((setf-function (fdefinition setf-name)) - (new-setf-name (ccl::construct-setf-function-name symbol))) - (setf (fdefinition new-setf-name) setf-function - (gethash symbol ccl::%setf-function-names%) new-setf-name - (gethash new-setf-name ccl::%setf-function-name-inverses%) symbol)))) - #+ccl + #+(or clisp clozure) + (multiple-value-bind (setf-symbol kind) + (get-setf-function-symbol symbol) + (when kind + (let* ((setf-function (fdefinition setf-symbol)) + (new-setf-symbol (create-setf-function-symbol symbol))) + (setf (fdefinition new-setf-symbol) setf-function) + (set-setf-function-symbol symbol new-setf-symbol kind)))) + #+(or clisp clozure) (multiple-value-bind (overwritten-setf foundp) - (gethash overwritten-symbol ccl::%setf-function-names%) + (get-setf-function-symbol overwritten-symbol) (when foundp (unintern overwritten-setf))) (when (eq old-status :external) @@ -145,34 +172,57 @@ or when loading the package is optional." ;;; Communicable representation of symbol and package information (eval-when (:load-toplevel :compile-toplevel :execute) - (defun symbol-name-package (symbol) - (cons (symbol-name symbol) (package-name (symbol-package symbol)))) - (defun package-data (package-designator &key name-package (error t)) - (let ((package (find-package* package-designator error))) + (defun package-definition-form (package-designator &key internp (error t)) + (let* ((package (find-package* package-designator error)) + (name (package-name package)) + (nicknames (package-nicknames package)) + (use (mapcar #'package-name (package-use-list package))) + (shadow ()) + (shadowing-import (make-hash-table :test 'equal)) + (import (make-hash-table :test 'equal)) + (export ()) + (intern ())) (when package - (labels ((marshall-symbols (symbols) - (if name-package (mapcar #'symbol-name-package symbols) symbols)) - (sort-symbols (symbols) - (marshall-symbols (sort symbols #'string<))) - (sort-packages (packages) - (sort (mapcar #'package-name packages) #'string<))) - (loop :with internal :with external :with inherited - :for sym :being :the :symbols :in package - :for status = (nth-value 1 (find-symbol* sym package)) :do - (ecase status - (:internal (push sym internal)) - (:external (push sym external)) - (:inherited (push sym inherited))) - :finally - (return - `(:name ,(package-name package) - :nicknames ,(package-nicknames package) - :internal ,(sort-symbols internal) - :external ,(sort-symbols external) - :inherited ,(sort-symbols inherited) - :shadowing ,(sort-symbols (package-shadowing-symbols package)) - :use ,(sort-packages (package-use-list package)) - :used-by ,(sort-packages (package-used-by-list package)))))))))) + (loop :for sym :being :the :symbols :in package + :for status = (nth-value 1 (find-symbol* sym package)) :do + (ecase status + ((nil :inherited)) + ((:internal :external) + (let* ((name (symbol-name sym)) + (external (eq status :external)) + (home (symbol-package sym)) + (home-name (package-name home)) + (imported (not (eq home package))) + (shadowing (symbol-shadowing-p sym package))) + (cond + ((and shadowing import) + (push name (gethash home-name shadowing-import))) + (shadowing + (push name shadow)) + (imported + (push name (gethash home-name import)))) + (cond + (external + (push name export)) + (imported) + (t (push name intern))))))) + (labels ((sort-names (names) + (sort names #'string<)) + (table-keys (table) + (loop :for k :being :the :hash-keys :of table :collect k)) + (when-relevant (key value) + (when value (list (cons key value)))) + (import-options (key table) + (loop :for i :in (sort-names (table-keys table)) + :collect `(,key ,i ,@(sort-names (gethash i table)))))) + `(defpackage ,name + ,@(when-relevant :nicknames (sort-names nicknames)) + (:use ,@(sort-names use)) + ,@(when-relevant :shadow (sort-names shadow)) + ,@(import-options :shadowing-import-from shadowing-import) + ,@(import-options :import-from import) + ,@(when-relevant :export (sort-names export)) + ,@(when-relevant :intern (and internp (sort-names intern))))))))) ;;; ensure-package, define-package @@ -189,6 +239,7 @@ or when loading the package is optional." (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)) (shadowed (make-hash-table :test 'equal)) ; string to bool @@ -196,7 +247,14 @@ or when loading the package is optional." (exported (make-hash-table :test 'equal)) ; string to bool (inherited (make-hash-table :test 'equal))) ; string to package name (labels - ((ensure-shadowing-import (sym p) + ((fresh-package-name (&optional (prefix :%TO-BE-DELETED) + (index (random most-positive-fixnum))) + (loop :for i :from index + :for n = (format nil "~A-~D" prefix i) + :thereis (and (not (find-package n)) n))) + (rename-package-away (p) + (rename-package p (fresh-package-name))) + (ensure-shadowing-import (sym p) (let* ((name (string sym)) (i (find-symbol* name p))) (cond @@ -300,7 +358,9 @@ or when loading the package is optional." :for n = (remove-if #'(lambda (x) (member x names :test 'equal)) (package-names p)) :do (if n (rename-package p (first n) (rest n)) - (delete-package* p))) + (progn + (rename-package-away p) + (push p to-delete)))) (rename-package package name nicknames) (loop :for p :in (set-difference (package-use-list package) (append mix use)) :do (unuse-package p package)) @@ -337,6 +397,7 @@ or when loading the package is optional." (ensure-symbol (string name) t)) (do-symbols (sym package) (ensure-symbol (symbol-name sym))) + (map () 'delete-package* to-delete) package)))) (eval-when (:load-toplevel :compile-toplevel :execute) @@ -373,5 +434,13 @@ or when loading the package is optional." (defmacro define-package (package &rest clauses) `(eval-when (:compile-toplevel :load-toplevel :execute) #+(or ecl gcl) (defpackage ,package (:use)) + #+clisp (macrolet ((foo () + (apply 'ensure-package ',(parse-define-package-form package clauses)) + (package-definition-form ',package))) + (foo)) (apply 'ensure-package ',(parse-define-package-form package clauses)))) +#+clisp +(eval-when (:compile-toplevel :load-toplevel :execute) + (when (find-package :asdf) (delete-package* :asdf))) + diff --git a/upgrade.lisp b/upgrade.lisp index efdaf85562873be9dd3188a58f3137a3a21983b6..87d411bec40b0ca7e0a0377abab9a97f05e3c8ed 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -31,7 +31,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.77") + (asdf-version "2.26.78") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version)))