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

2.26.49: Debug GCL 2.6 support, fix tests to work with its limitations.

Remove debugging code from previous commit.
parent e51b3aca
......@@ -14,7 +14,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.48" ;; to be automatically updated by bin/bump-revision
:version "2.26.49" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components
((:file "asdf")))
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.48: Another System Definition Facility.
;;; This is ASDF 2.26.49: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......@@ -79,7 +79,8 @@
(make-package :asdf :use '(:common-lisp))))
#+gcl (defpackage :asdf (:use :cl) ;; GCL treats defpackage magically and needs this
#+gcl<2.7 (:shadowing-import-from :system :*load-pathname*))
#+gcl<2.7 (:shadowing-import-from :system :*load-pathname*) ;; GCL 2.6 sucks
#+gcl<2.7 (:shadow :type-of))
(in-package :asdf)
......@@ -119,7 +120,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.48")
(asdf-version "2.26.49")
(existing-asdf (find-class 'component nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
......@@ -494,7 +495,7 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
(fs:create-directories-recursively (pathname path))))
#+gcl<2.7
(progn
(progn ;; Doesn't support either logical-pathnames or output-translations.
(deftype logical-pathname () nil)
(defun wild-pathname-p (path) (declare (ignore path)) nil)
(defun translate-logical-pathname (x) x)
......@@ -503,8 +504,9 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
(declare (ignore in-wildname wild-wildname)) nil)
(defun translate-pathname (source from-wildname to-wildname &key)
(declare (ignore from-wildname to-wildname)) source)
(defun type-of (x) (class-name (class-of x)))
(defun %print-unreadable-object (object stream type identity thunk)
(format stream "<~@[~S ~] " (when type (class-name (class-of object))))
(format stream "#<~@[~S ~]" (when type (type-of object)))
(funcall thunk)
(format stream "~@[ ~X~]>" (when identity (system:address object))))
(defmacro with-compilation-unit (options &body body)
......@@ -517,22 +519,6 @@ or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
;;;; -------------------------------------------------------------------------
;;;; General Purpose Utilities
(defmacro DBG (tag &rest exprs)
"simple debug statement macro:
outputs a tag plus a list of variable and their values, returns the last value"
;"if not in debugging mode, just compute and return last value"
; #-do-test (declare (ignore tag)) #-do-test (car (last exprs)) #+do-test
(let ((res (gensym))(f (gensym)))
`(let (,res (*print-readably* nil))
(flet ((,f (fmt &rest args) (apply #'format *error-output* fmt args)))
(,f "~&~A~%" ,tag)
,@(mapcan
#'(lambda (x)
`((,f "~& ~S => " ',x)
(,f "~{~S~^ ~}~%" (setf ,res (multiple-value-list ,x)))))
exprs)
(apply 'values ,res)))))
(macrolet
((defdef (def* def)
`(defmacro ,def* (name formals &rest rest)
......@@ -577,18 +563,19 @@ and NIL NAME, TYPE and VERSION components"
(defun* normalize-pathname-directory-component (directory)
"Given a pathname directory component, return an equivalent form that is a list"
#+gcl<2.7 (setf directory (substitute :back :parent directory))
(cond
#-(or cmu sbcl scl) ;; these implementations already normalize directory components.
((stringp directory) `(:absolute ,directory))
#+gcl<2.7
((and (consp directory) (stringp (first directory)))
`(:relative ,@directory))
#+gcl<2.7
((and (consp directory) (eq :root (first directory)))
`(:absolute ,@(rest directory)))
((or (null directory)
(and (consp directory) (member (first directory) '(:absolute :relative))))
directory)
#+gcl<2.7
((consp directory)
`(:relative ,@directory))
(t
(error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory))))
......@@ -623,16 +610,15 @@ and NIL NAME, TYPE and VERSION components"
#+clisp (cons (mapcar 'make-pathname-component-logical x))
(t x)))
(defun* denormalize-pathname-directory-component (directory)
#-gcl<2.7 directory
(defun* denormalize-pathname-directory-component (directory-component)
#-gcl<2.7 directory-component
#+gcl<2.7
(cond
((and (consp directory) (eq :relative (first directory)))
(rest directory))
((and (consp directory) (eq :absolute (first directory)))
`(:root ,@(rest directory)))
(t
directory)))
(let ((d (substitute-if :parent (lambda (x) (member x '(:up :back)))
directory-component)))
(cond
((and (consp d) (eq :relative (first d))) (rest d))
((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d)))
(t d))))
(defun* make-pathname* (&key host device directory name type version defaults)
(make-pathname
......@@ -2171,7 +2157,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded.
(format stream "~{~S~^ ~}" (operation-original-initargs o)))))
(defun* node-for (o c)
(cons (class-name (class-of o)) c))
(cons (type-of o) c))
(defmethod operation-ancestor ((o operation))
(aif (operation-parent o)
......@@ -2436,7 +2422,6 @@ If true, an integer indexing the action in the list of actions planned."))
(operation-description o c)
missing-in (length missing-in) (and missing-in missing-out)
missing-out (length missing-out)))
;;(DBG :cas o c just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c))
;; Note that we use stamp<= instead of stamp< to play nice with generated files.
;; Any race condition is intrinsic to the limited timestamp resolution.
(if (or just-done ;; The done-stamp is valid: if we're just done, or
......@@ -2484,7 +2469,6 @@ If true, an integer indexing the action in the list of actions planned."))
(defmethod traverse-action (plan operation component needed-in-image-p)
(block nil
;;(DBG :ta operation component needed-in-image-p (plan-visiting-action-list plan))
(unless (action-valid-p operation component) (return nil))
(plan-record-dependency plan operation component)
(let* ((aniip (needed-in-image-p operation component))
......@@ -2492,7 +2476,6 @@ If true, an integer indexing the action in the list of actions planned."))
(status (plan-action-status plan operation component)))
(when (and status (or (action-done-p status) (action-planned-p status) (not eniip)))
;; Already visited with sufficient need-in-image level: just return the stamp.
;;(DBG :ad status eniip aniip)
(return (action-stamp status)))
(labels ((visit-action (niip)
(visit-dependencies operation component
......@@ -2500,7 +2483,6 @@ If true, an integer indexing the action in the list of actions planned."))
(multiple-value-bind (stamp done-p)
(compute-action-stamp operation component :plan plan)
(let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p)))))
;;(DBG :va operation component needed-in-image-p niip aniip eniip done-p stamp add-to-plan-p)
(cond
((and add-to-plan-p (not niip)) ;; if we need to do it,
(visit-action t)) ;; then we need to do it in the image!
......@@ -2745,7 +2727,8 @@ If true, an integer indexing the action in the list of actions planned."))
(defmethod perform ((o load-source-op) (c cl-source-file))
(declare (ignorable o))
(call-with-around-compile-hook
c #'(lambda () (load (component-pathname c) :external-format (component-external-format c)))))
c #'(lambda () (load (component-pathname c)
#-gcl<2.7 :external-format #-gcl<2.7 (component-external-format c)))))
(defmethod perform ((o load-source-op) (c static-file))
(declare (ignorable o c))
......
......@@ -51,14 +51,14 @@
#+scl :scl
#+xcl :xcl))))
(merge-pathnames
(make-pathname :directory `(#-gcl :relative "tmp" "fasls" ,impl)
(make-pathname :directory `(#-gcl<2.7 :relative "tmp" "fasls" ,impl)
:defaults *asdf-directory*)
*asdf-lisp*))))
(defun load-old-asdf (tag)
(let ((old-asdf
(merge-pathnames
(make-pathname :directory `(#-gcl :relative "tmp")
(make-pathname :directory `(#-gcl<2.7 :relative "tmp")
:name (format nil "asdf-~A" tag)
:defaults *asdf-directory*)
*asdf-lisp*)))
......@@ -74,7 +74,7 @@
(defun load-asdf ()
(load *asdf-fasl*)
(use-package :asdf :asdf-test)
;;(import 'DBG :asdf)
(import 'DBG :asdf)
(configure-asdf)
(setf *package* (find-package :asdf-test)))
......@@ -262,5 +262,5 @@ outputs a tag plus a list of variable and their values, returns the last value"
#|
(DBG :cas o c just-done base-stamp stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c))
(DBG :cas o c just-done plan stamp-lookup out-files in-files out-op op-time dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in up-to-date-p done-stamp (operation-done-p o c))
|#
......@@ -14,7 +14,7 @@
(when (find-package :test-package) (delete-package :test-package))
(asdf:defsystem :test-bundle-1 :components ((:file "file1") (:file "file3")))
(asdf:defsystem :test-bundle-2 :depends-on (:test-bundle-1) :components ((:file "file2")))
#-(or abcl (and ecl ecl-bytecmp))
#-(or abcl (and ecl ecl-bytecmp) gcl)
(let* ((op (make-instance 'asdf::fasl-op))
(bundle-1 (asdf:output-file op (find-system :test-bundle-1)))
(bundle-2 (asdf:output-file op (find-system :test-bundle-2))))
......
;;; -*- Lisp -*-
(load "script-support.lisp")
(load-asdf)
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
#-gcl<2.7
(assert (handler-case
(let ((asdf:*compile-file-failure-behaviour* :warn))
(asdf:load-system 'test-compile-file-failure :force t)
t)
(asdf:compile-error () nil)))
#-gcl<2.7
(assert (handler-case
(let ((asdf:*compile-file-failure-behaviour* :error))
(asdf:load-system 'test-compile-file-failure :force t)
......
......@@ -3,14 +3,11 @@
(load-asdf)
(in-package :asdf)
(use-package :asdf-test)
(defparameter *test-directory*
(merge-pathnames* (coerce-pathname "tmp/") *asdf-directory*))
#+gcl<2.7 (defmacro with-standard-io-syntax (&body body) `(progn ,@body))
(defun under-test-directory (designator &optional (defaults *test-directory*))
(namestring (merge-pathnames* (coerce-pathname designator) defaults)))
(namestring (subpathname defaults designator)))
(defun create-conf-files (&optional (path *test-directory*))
(let ((v `(("conf.d/conf1.conf"
......
......@@ -3,25 +3,16 @@
(load-asdf)
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:load-system 'test-module-pathnames)
(flet ((submodule (module name)
(find name (asdf:module-components module)
:key #'asdf:component-name :test #'equal))
(pathname-foo (x)
(list (pathname-directory x) (pathname-name x) (pathname-type x))))
(let* ((system (asdf:find-system "test-module-pathnames"))
(level1 (submodule system "sources/level1"))
(static (submodule level1 "level2/static.file"))
(test-tmp (submodule level1 "test-tmp.cl")))
(assert (member (pathname-foo (asdf:component-relative-pathname test-tmp))
'(((:relative) "test-tmp" "cl")
(nil "test-tmp" "cl")) :test 'equal)
() "Didn't get the name of test-tmp.cl right")
(assert (equal
(pathname-foo (asdf:component-relative-pathname static))
'((:relative "level2") "static" "file"))
() "Didn't get the name of static.file right")))
(flet ((pathname-foo (x)
(list (or (asdf::normalize-pathname-directory-component (pathname-directory x)) '(:relative))
(pathname-name x) (pathname-type x))))
(let* ((static (find-component "test-module-pathnames" '("sources/level1" "level2/static.file")))
(test-tmp (find-component "test-module-pathnames" '("sources/level1" "test-tmp.cl"))))
(assert-equal (pathname-foo (asdf:component-relative-pathname test-tmp))
'((:relative) "test-tmp" "cl"))
(assert-equal (pathname-foo (asdf:component-relative-pathname static))
'((:relative "level2") "static" "file"))))
(assert (find-package :test-package)
() "package test-package not found")
(assert (find-symbol (symbol-name '*file-tmp*) :test-package)
......@@ -29,28 +20,26 @@
(assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package))
() "symbol `*file-tmp*` has wrong value")
#| ; must be adapted to ABL
(assert (probe-file (merge-pathnames
(make-pathname
:name "file1"
:type (pathname-type (compile-file-pathname "x"))
:directory '(:relative "sources" "level1"))))
nil "compiled file not found")
|#
(assert (probe-file
(asdf::apply-output-translations
(asdf::merge-pathnames*
(asdf::make-pathname*
:name "file1"
:type (asdf::fasl-type)
:directory '(:relative "sources" "level1"))
*test-directory*)))
() "compiled file not found")
(assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil
"symbol `*file-tmp2*` not found")
(assert (find-symbol (symbol-name '*file-tmp2*) :test-package)
() "symbol `*file-tmp2*` not found")
(assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package))
nil "symbol `*file-tmp2*` has wrong value")
() "symbol `*file-tmp2*` has wrong value")
#| ; must be adapted to ABL
(assert (probe-file (merge-pathnames
(make-pathname
:name "file2"
:type (pathname-type (compile-file-pathname "x"))
:directory '(:relative "sources" "level1" "level2"))))
nil "compiled file not found")
|#
)
(assert (probe-file
(asdf::apply-output-translations
(asdf::merge-pathnames*
(asdf::make-pathname*
:name "file2"
:type (asdf::fasl-type)
:directory '(:relative "sources" "level1" "level2")))))
nil "compiled file not found"))
......@@ -6,14 +6,11 @@
(use-package :asdf-test)
(quit-on-error
(let* ((asd (merge-pathnames* (coerce-pathname "test-multiple.asd")
*test-directory*))
(tmp (merge-pathnames* (coerce-pathname "../tmp/")
*test-directory*))
(asd2 (merge-pathnames* (coerce-pathname "test-multiple-too.asd")
tmp))
(let* ((asd (subpathname *test-directory* "test-multiple.asd"))
(tmp (subpathname *test-directory* "../tmp/"))
(asd2 (subpathname tmp "test-multiple-too.asd"))
(file4 (compile-file-pathname* "file4")))
(setf *central-registry* `(*default-pathname-defaults* ,tmp))
(setf *central-registry* `(,*test-directory* ,tmp))
(assert (= 0 (run-shell-command
(format nil "/bin/ln -sf ~A ~A"
(native-namestring asd)
......
......@@ -3,25 +3,7 @@
(load-asdf)
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:load-system 'test-system-pathnames)
(flet ((submodule (module name)
(find name (asdf:module-components module)
:key #'asdf:component-name :test #'equal))
(pathname-foo (x)
(list (pathname-directory x) (pathname-name x) (pathname-type x))))
(let* ((system (asdf:find-system "test-module-pathnames"))
(level1 (submodule system "sources/level1"))
(static (submodule level1 "level2/static.file"))
(test-tmp (submodule level1 "test-tmp.cl")))
(assert (member (pathname-foo (asdf:component-relative-pathname test-tmp))
'(((:relative) "test-tmp" "cl")
(nil "test-tmp" "cl")) :test 'equal)
() "Didn't get the name of test-tmp.cl right")
(assert (equal
(pathname-foo (asdf:component-relative-pathname static))
'((:relative "level2") "static" "file"))
() "Didn't get the name of static.file right")))
(assert (find-package :test-package)
() "package test-package not found")
(assert (find-symbol (symbol-name '*file-tmp*) :test-package)
......@@ -29,28 +11,26 @@
(assert (symbol-value (find-symbol (symbol-name '*file-tmp*) :test-package))
() "symbol `*file-tmp*` has wrong value")
#| ; must be adapted to ABL
(assert (probe-file (merge-pathnames
(make-pathname
:name "file1"
:type (pathname-type (compile-file-pathname "x"))
:directory '(:relative "sources" "level1"))))
nil "compiled file not found")
|#
(assert (probe-file
(asdf::apply-output-translations
(asdf::merge-pathnames*
(asdf::make-pathname*
:name "file1"
:type (asdf::fasl-type)
:directory '(:relative "sources" "level1"))
*test-directory*)))
() "compiled file not found")
(assert (find-symbol (symbol-name '*file-tmp2*) :test-package) nil
"symbol `*file-tmp2*` not found")
(assert (symbol-value (find-symbol (symbol-name '*file-tmp2*) :test-package))
nil "symbol `*file-tmp2*` has wrong value")
#| ; must be adapted to ABL
(assert (probe-file (merge-pathnames
(make-pathname
:name "file2"
:type (pathname-type (compile-file-pathname "x"))
:directory '(:relative "sources" "level1" "level2"))))
nil "compiled file not found")
|#
)
(assert (probe-file
(asdf::apply-output-translations
(asdf::merge-pathnames*
(asdf::make-pathname*
:name "file2"
:type (asdf::fasl-type)
:directory '(:relative "sources" "level1" "level2")))))
nil "compiled file not found"))
......@@ -7,10 +7,7 @@
(defvar *caught-error* nil)
(quit-on-error
(run-shell-command "rm -f ~A"
(namestring
(compile-file-pathname "try-recompiling-1")))
(setf *central-registry* '(*default-pathname-defaults*))
(asdf::delete-file-if-exists (compile-file-pathname "try-recompiling-1"))
#-gcl
(handler-bind ((error (lambda (c)
(setf *caught-error* t)
......@@ -26,4 +23,5 @@
(when restart
(invoke-restart restart)))))))
(oos 'load-op 'try-recompiling-1))
#-gcl
(assert *caught-error*))
......@@ -2,17 +2,12 @@
(load "script-support.lisp")
(load-asdf)
#+gcl (trace load compile-file asdf:perform asdf::perform-plan)
(quit-on-error
(let ((*default-pathname-defaults* (make-pathname :name nil
:type nil
:defaults *load-truename*)))
(setf asdf:*central-registry* nil)
(push (merge-pathnames #p"xach-foo-1/") asdf:*central-registry*)
(asdf:load-system "foo")
(assert (symbol-value (find-symbol (string :loaded) :first-version)))
(push (merge-pathnames #p"xach-foo-2/") asdf:*central-registry*)
(asdf:load-system "foo")
(assert (symbol-value (find-symbol (string :loaded) :second-version)))
(assert (eql 42 (funcall (find-symbol (string :wtf) :second-version))))))
(setf asdf:*central-registry* (list (asdf::subpathname *test-directory* "xach-foo-1/")))
(asdf:load-system "foo")
(assert (symbol-value (find-symbol (string :loaded) :first-version)))
(setf asdf:*central-registry* (list (asdf::subpathname *test-directory* "xach-foo-2/")))
(asdf:load-system "foo")
(assert (symbol-value (find-symbol (string :loaded) :second-version)))
(assert (eql 42 (funcall (find-symbol (string :wtf) :second-version)))))
;;;; a.lisp
(defpackage #:first-version
(defpackage :first-version
(:use #:cl)
(:export #:loaded))
(in-package #:first-version)
(in-package :first-version)
(defparameter loaded t)
;;;; a.lisp
(defpackage #:second-version
(defpackage :second-version
(:use #:cl)
(:export #:loaded #:wtf))
(in-package #:second-version)
(in-package :second-version)
(defparameter loaded t)
......
;;;; b.lisp
(in-package #:second-version)
(in-package :second-version)
(defun wtf ()
42)
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