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

2.26.68: self-upgrade now works somewhat on SBCL and CCL.

Fixed corner bugs in the package surgery.
Stopped using fmakunbound as part of the package definition;
it should happen as part of with-upgrade,
or, for now, systematically with defgeneric* and defun*.
Added special magic for ASDF fixup, that will have to be enhanced.
parent fe4086bb
No related branches found
No related tags found
No related merge requests found
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,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.67" ;; to be automatically updated by bin/bump-revision :version "2.26.68" ;; to be automatically updated by bin/bump-revision
:depends-on () :depends-on ()
:components :components
((:file "asdf"))) ((: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.67: Another System Definition Facility. ;;; This is ASDF 2.26.68: 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>.
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
(:nicknames :asdf) (:nicknames :asdf)
(:recycle :asdf/interface :asdf) (:recycle :asdf/interface :asdf)
(:unintern (:unintern
#:*asdf-revision* #:around #:asdf-method-combination #:*asdf-revision* #:around #:asdf-method-combination #:intern*
#:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p #:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p
#:split #:make-collector #:split #:make-collector
#:loaded-systems ; makes for annoying SLIME completion #:loaded-systems ; makes for annoying SLIME completion
......
...@@ -9,7 +9,7 @@ ...@@ -9,7 +9,7 @@
(:export (:export
#:compile-error #:compile-failed #:compile-warned #:try-recompiling #:compile-error #:compile-failed #:compile-warned #:try-recompiling
#:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp
#:basic-load-op #:basic-compile-op #:basic-load-op #:basic-compile-op #:compile-op-flags #:compile-op-proclamations
#:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op #:load-op #:prepare-op #:compile-op #:test-op #:load-source-op #:prepare-source-op
#:call-with-around-compile-hook #:call-with-around-compile-hook
#:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source)) #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source))
......
...@@ -179,10 +179,10 @@ when the symbol is not found." ...@@ -179,10 +179,10 @@ when the symbol is not found."
((gethash name shadowed) ((gethash name shadowed)
(error "Can't both shadow ~S and import it from ~S" name (package-name p))) (error "Can't both shadow ~S and import it from ~S" name (package-name p)))
(t (t
(when (and xp (not (eq i x)))
(unintern* x package))
(setf (gethash name imported) t) (setf (gethash name imported) t)
(import i package)))))) (unless (and xp (eq i x))
(when xp (unintern* x p))
(import i package)))))))
(ensure-mix (sym p) (ensure-mix (sym p)
(let* ((name (string sym)) (let* ((name (string sym))
(sp (string p))) (sp (string p)))
...@@ -197,22 +197,24 @@ when the symbol is not found." ...@@ -197,22 +197,24 @@ when the symbol is not found."
(ensure-inherited sym sp))))))) (ensure-inherited sym sp)))))))
(ensure-inherited (sym p) (ensure-inherited (sym p)
(let* ((name (string sym)) (let* ((name (string sym))
(sp (string p)) (symbol (find-symbol* name p))
(s (find-symbol* name sp)) (sp (symbol-package symbol))
(ip (gethash name inherited))) (spn (package-name sp))
(ipn (gethash name inherited)))
(multiple-value-bind (x xp) (find-symbol name package) (multiple-value-bind (x xp) (find-symbol name package)
(cond (cond
(ip (ipn
(unless (eq ip sp) (unless (eq spn ipn)
(error "Can't inherit ~S from ~S, it is inherited from ~S" (error "Can't inherit ~S from ~S, it is inherited from ~S"
name sp ip))) name spn ipn)))
((gethash name imported) ((gethash name imported)
(unless (eq s x) (unless (eq symbol x)
(error "Can't inherit ~S from ~S, it is imported from ~S" (error "Can't inherit ~S from ~S, it is imported from ~S"
name sp (package-name (symbol-package x))))) name sp (package-name (symbol-package x)))))
((gethash name shadowed) ((gethash name shadowed)
(error "Can't inherit ~S from ~S, it is shadowed" name sp)) (error "Can't inherit ~S from ~S, it is shadowed" name spn))
(t (t
(setf (gethash name inherited) spn)
(when xp (when xp
(unintern* x package))))))) (unintern* x package)))))))
(recycle-symbol (name) (recycle-symbol (name)
...@@ -353,6 +355,7 @@ when the symbol is not found." ...@@ -353,6 +355,7 @@ when the symbol is not found."
(error "define-package: bad :upgrade directive")) (error "define-package: bad :upgrade directive"))
(setf upgrade (car args)) :else (setf upgrade (car args)) :else
:do (error "unrecognized define-package keyword ~S" kw) :do (error "unrecognized define-package keyword ~S" kw)
(progn fmakunbound fmakunbound-setf)
:finally (return `(,package :finally (return `(,package
:nicknames ,nicknames :documentation ,documentation :nicknames ,nicknames :documentation ,documentation
:use ,(if use-p use '(:common-lisp)) :use ,(if use-p use '(:common-lisp))
...@@ -361,9 +364,24 @@ when the symbol is not found." ...@@ -361,9 +364,24 @@ when the symbol is not found."
:recycle ,(if recycle-p recycle (cons package nicknames)) :recycle ,(if recycle-p recycle (cons package nicknames))
:mix ,mix :reexport ,reexport :unintern ,unintern :mix ,mix :reexport ,reexport :unintern ,unintern
,@(when upgrade `(:upgrade ,upgrade)) ,@(when upgrade `(:upgrade ,upgrade))
:fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf))))) #|:fmakunbound ,fmakunbound :fmakunbound-setf ,fmakunbound-setf|#)))))
(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)
#+gcl (defpackage ,package (:use)) #+gcl (defpackage ,package (:use))
(apply 'ensure-package ',(parse-define-package-form package clauses)))) (apply 'ensure-package ',(parse-define-package-form package clauses))))
;;;; MAGIC FIXUP FOR ASDF.
;; For bootstrapping reason, define-package can't do its magic on the asdf/package package itself,
;; so instead do something ugly and special purpose. However, other packages could have imported
;; from ASDF and be in trouble. There ought to be a better solution to merging packages without tears.
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *extirpated-symbols* ())
(when (find-package :asdf)
(let (l)
(do-external-symbols (sym :asdf/package)
(multiple-value-bind (symbol lstatus) (find-symbol* sym :asdf nil)
(when (and lstatus (not (eq sym symbol)))
(push symbol l))))
(push (cons :asdf (mapcar #'symbol-name-package (sort l 'string<))) *extirpated-symbols*))))
...@@ -24,7 +24,7 @@ ...@@ -24,7 +24,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.67") (asdf-version "2.26.68")
(existing-asdf (find-class 'component nil)) (existing-asdf (find-class 'component nil))
(existing-version *asdf-version*) (existing-version *asdf-version*)
(already-there (equal asdf-version existing-version))) (already-there (equal asdf-version existing-version)))
......
...@@ -26,7 +26,7 @@ ...@@ -26,7 +26,7 @@
((defdef (def* def) ((defdef (def* def)
`(defmacro ,def* (name formals &rest rest) `(defmacro ,def* (name formals &rest rest)
`(progn `(progn
#+(or ecl gcl) ;; #+(or ecl gcl)
,(when (and #+gcl<2.7 (symbolp name)) ,(when (and #+gcl<2.7 (symbolp name))
`(fmakunbound ',name)) `(fmakunbound ',name))
#-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-(
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment