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

2.26.78: Try harder to make CLISP happy, yet fail.

Have a package-definition-form in defpackage format
rather than ad-hoc package-data.

Backtrace on clisp and ecl.
parent 7785079c
...@@ -4,6 +4,8 @@ ...@@ -4,6 +4,8 @@
** Have it pass test-lisp ** Have it pass test-lisp
** Have it pass test-upgrade ** Have it pass test-upgrade
** Get package upgrade right ** 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, ** The unconditional ensure-package-unused breaks test-encodings.script,
since asdf severs itself from its client package hosting the since asdf severs itself from its client package hosting the
defsystem form during defsystem-depends-on. defsystem form during defsystem-depends-on.
......
...@@ -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.77" ;; to be automatically updated by bin/bump-revision :version "2.26.78" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components ((:module "build" :components ((:file "asdf"))))) :components ((:module "build" :components ((:file "asdf")))))
......
;; -*- 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.77: Another System Definition Facility. ;;; This is ASDF 2.26.78: 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>.
......
...@@ -78,9 +78,11 @@ This is designed to abstract away the implementation specific quit forms." ...@@ -78,9 +78,11 @@ This is designed to abstract away the implementation specific quit forms."
(defun print-backtrace (out) (defun print-backtrace (out)
"Print a backtrace (implementation-defined)" "Print a backtrace (implementation-defined)"
(declare (ignorable out)) (declare (ignorable out))
#+clisp (system::print-backtrace)
#+clozure (let ((*debug-io* out)) #+clozure (let ((*debug-io* out))
(ccl:print-call-history :count 100 :start-frame-number 1) (ccl:print-call-history :count 100 :start-frame-number 1)
(finish-output out)) (finish-output out))
#+ecl (si::tpl-backtrace)
#+sbcl #+sbcl
(sb-debug:backtrace (sb-debug:backtrace
#.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream 'most-positive-fixnum) #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream 'most-positive-fixnum)
......
...@@ -16,8 +16,7 @@ ...@@ -16,8 +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
#:symbol-name-package #:package-data #:package-definition-form #:ensure-package #:define-package))
#:ensure-package #:define-package))
(in-package :asdf/package) (in-package :asdf/package)
...@@ -83,6 +82,35 @@ or when loading the package is optional." ...@@ -83,6 +82,35 @@ 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)
(member symbol (package-shadowing-symbols 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) (defun rehome-symbol (symbol package-designator)
"Changes the home package of a symbol, also leaving it present in its old home if any" "Changes the home package of a symbol, also leaving it present in its old home if any"
(let* ((name (symbol-name symbol)) (let* ((name (symbol-name symbol))
...@@ -109,18 +137,17 @@ or when loading the package is optional." ...@@ -109,18 +137,17 @@ or when loading the package is optional."
(if shadowing (if shadowing
(shadowing-import symbol old-package) (shadowing-import symbol old-package)
(import symbol old-package)) (import symbol old-package))
#+ccl #+(or clisp clozure)
(multiple-value-bind (setf-name foundp) (multiple-value-bind (setf-symbol kind)
(gethash symbol ccl::%setf-function-names%) (get-setf-function-symbol symbol)
(when foundp (when kind
(let* ((setf-function (fdefinition setf-name)) (let* ((setf-function (fdefinition setf-symbol))
(new-setf-name (ccl::construct-setf-function-name symbol))) (new-setf-symbol (create-setf-function-symbol symbol)))
(setf (fdefinition new-setf-name) setf-function (setf (fdefinition new-setf-symbol) setf-function)
(gethash symbol ccl::%setf-function-names%) new-setf-name (set-setf-function-symbol symbol new-setf-symbol kind))))
(gethash new-setf-name ccl::%setf-function-name-inverses%) symbol)))) #+(or clisp clozure)
#+ccl
(multiple-value-bind (overwritten-setf foundp) (multiple-value-bind (overwritten-setf foundp)
(gethash overwritten-symbol ccl::%setf-function-names%) (get-setf-function-symbol overwritten-symbol)
(when foundp (when foundp
(unintern overwritten-setf))) (unintern overwritten-setf)))
(when (eq old-status :external) (when (eq old-status :external)
...@@ -145,34 +172,57 @@ or when loading the package is optional." ...@@ -145,34 +172,57 @@ or when loading the package is optional."
;;; Communicable representation of symbol and package information ;;; Communicable representation of symbol and package information
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
(defun symbol-name-package (symbol) (defun package-definition-form (package-designator &key internp (error t))
(cons (symbol-name symbol) (package-name (symbol-package symbol)))) (let* ((package (find-package* package-designator error))
(defun package-data (package-designator &key name-package (error t)) (name (package-name package))
(let ((package (find-package* package-designator error))) (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 (when package
(labels ((marshall-symbols (symbols) (loop :for sym :being :the :symbols :in package
(if name-package (mapcar #'symbol-name-package symbols) symbols)) :for status = (nth-value 1 (find-symbol* sym package)) :do
(sort-symbols (symbols) (ecase status
(marshall-symbols (sort symbols #'string<))) ((nil :inherited))
(sort-packages (packages) ((:internal :external)
(sort (mapcar #'package-name packages) #'string<))) (let* ((name (symbol-name sym))
(loop :with internal :with external :with inherited (external (eq status :external))
:for sym :being :the :symbols :in package (home (symbol-package sym))
:for status = (nth-value 1 (find-symbol* sym package)) :do (home-name (package-name home))
(ecase status (imported (not (eq home package)))
(:internal (push sym internal)) (shadowing (symbol-shadowing-p sym package)))
(:external (push sym external)) (cond
(:inherited (push sym inherited))) ((and shadowing import)
:finally (push name (gethash home-name shadowing-import)))
(return (shadowing
`(:name ,(package-name package) (push name shadow))
:nicknames ,(package-nicknames package) (imported
:internal ,(sort-symbols internal) (push name (gethash home-name import))))
:external ,(sort-symbols external) (cond
:inherited ,(sort-symbols inherited) (external
:shadowing ,(sort-symbols (package-shadowing-symbols package)) (push name export))
:use ,(sort-packages (package-use-list package)) (imported)
:used-by ,(sort-packages (package-used-by-list package)))))))))) (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 ;;; ensure-package, define-package
...@@ -189,6 +239,7 @@ or when loading the package is optional." ...@@ -189,6 +239,7 @@ or when loading the package is optional."
(names (cons name nicknames)) (names (cons name nicknames))
(previous (packages-from-names names)) (previous (packages-from-names names))
(discarded (cdr previous)) (discarded (cdr previous))
(to-delete ())
(package (or (first previous) (make-package name :nicknames nicknames))) (package (or (first previous) (make-package name :nicknames nicknames)))
(recycle (packages-from-names recycle)) (recycle (packages-from-names recycle))
(shadowed (make-hash-table :test 'equal)) ; string to bool (shadowed (make-hash-table :test 'equal)) ; string to bool
...@@ -196,7 +247,14 @@ or when loading the package is optional." ...@@ -196,7 +247,14 @@ or when loading the package is optional."
(exported (make-hash-table :test 'equal)) ; string to bool (exported (make-hash-table :test 'equal)) ; string to bool
(inherited (make-hash-table :test 'equal))) ; string to package name (inherited (make-hash-table :test 'equal))) ; string to package name
(labels (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)) (let* ((name (string sym))
(i (find-symbol* name p))) (i (find-symbol* name p)))
(cond (cond
...@@ -300,7 +358,9 @@ or when loading the package is optional." ...@@ -300,7 +358,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 (if n (rename-package p (first n) (rest n)) :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) (rename-package package name nicknames)
(loop :for p :in (set-difference (package-use-list package) (append mix use)) (loop :for p :in (set-difference (package-use-list package) (append mix use))
:do (unuse-package p package)) :do (unuse-package p package))
...@@ -337,6 +397,7 @@ or when loading the package is optional." ...@@ -337,6 +397,7 @@ or when loading the package is optional."
(ensure-symbol (string name) t)) (ensure-symbol (string name) t))
(do-symbols (sym package) (do-symbols (sym package)
(ensure-symbol (symbol-name sym))) (ensure-symbol (symbol-name sym)))
(map () 'delete-package* to-delete)
package)))) package))))
(eval-when (:load-toplevel :compile-toplevel :execute) (eval-when (:load-toplevel :compile-toplevel :execute)
...@@ -373,5 +434,13 @@ or when loading the package is optional." ...@@ -373,5 +434,13 @@ or when loading the package is optional."
(defmacro define-package (package &rest clauses) (defmacro define-package (package &rest clauses)
`(eval-when (:compile-toplevel :load-toplevel :execute) `(eval-when (:compile-toplevel :load-toplevel :execute)
#+(or ecl gcl) (defpackage ,package (:use)) #+(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)))) (apply 'ensure-package ',(parse-define-package-form package clauses))))
#+clisp
(eval-when (:compile-toplevel :load-toplevel :execute)
(when (find-package :asdf) (delete-package* :asdf)))
...@@ -31,7 +31,7 @@ ...@@ -31,7 +31,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.77") (asdf-version "2.26.78")
(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)))
......
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