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

2.26.48: make ASDF work somewhat on GCL<2.7. Further simplify traverse-action.

parent bdc9efaf
No related branches found
No related tags found
No related merge requests found
Showing
with 326 additions and 257 deletions
......@@ -11,6 +11,7 @@ lisps ?= ccl clisp sbcl ecl ecl_bytecodes cmucl abcl scl allegro lispworks alleg
endif
export ASDF_OUTPUT_TRANSLATIONS := (:output-translations (t ("${sourceDirectory}/tmp/fasls" :implementation)) :ignore-inherited-configuration)
export CL_SOURCE_REGISTRY := (:source-registry (:tree "${sourceDirectory}") :ignore-inherited-configuration)
## MAJOR FAIL: gclcvs -- COMPILER BUG! Upstream fixed it, but upstream fails to compile.
## NOT SUPPORTED BY OUR TESTS: cormancl genera lispworks-personal-edition mkcl rmcl. Manually tested once in a while.
......@@ -29,6 +30,7 @@ SCL ?= scl
ALLEGRO ?= alisp
ALLEGROMODERN ?= mlisp
LISPWORKS ?= lispworks
GCL ?= gcl
# website, tag, install
......@@ -98,6 +100,7 @@ test-upgrade:
use_abcl () { li="${ABCL} --noinit --nosystem --noinform" ; ev="--eval" ; } ; \
use_xcl () { li="${XCL} --noinit --nosystem --noinform" ; ev="--eval" ; } ; \
use_scl () { li="${SCL} -noinit" ; ev="-eval" ; } ; \
use_gcl () { li="GCL_ANSI=t ${GCL}" ; ev="-eval" ; } ; \
use_allegro () { li="${ALLEGRO} -q" ; ev="-e" ; } ; \
use_allegromodern () { li="${ALLEGROMODERN} -q" ; ev="-e" ; } ; \
use_lispworks () { li="${LISPWORKS} -siteinit - -init -" ; ev="-eval" ; } ; \
......
......@@ -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.47" ;; to be automatically updated by bin/bump-revision
:version "2.26.48" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components
((:file "asdf")))
......
This diff is collapsed.
......@@ -56,6 +56,7 @@
(cons "asdf-src" path)))
(bin-dir (&rest path) (append (or (pathname-directory root) (list :relative))
(cons "asdf-bin" path))))
#-gcl<2.7
(setf (logical-pathname-translations "ASDFTEST")
`((,(format nil "**;*.~a" bin-type)
,(make-pathname :directory (bin-dir :wild-inferiors)
......@@ -316,7 +317,7 @@
(format t "output translations: ~S~%" (asdf::output-translations))
#+gcl (format t "~&~A~&" (progn (defvar *x* -1) (incf *x*)))
#-xcl ;;---*** pathnames are known to be massively broken on XCL
#-(or xcl gcl<2.7) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6
(flet ((same (s1 s2 p1 p2)
(unless (equal (namestring p1) (namestring p2))
(describe p1) (describe p2)
......@@ -331,7 +332,7 @@
#-gcl
(x (asdf::resolve-location '("/foo" "bar" :**/ "baz" #p"*.*") :directory nil :wilden t) #p"/foo/bar/**/baz/*.*")))
#-xcl ;;---*** pathnames are known to be massively broken on XCL
#-(or xcl gcl<2.7) ;;---*** pathnames are known to be massively broken on XCL and GCL 2.6
(or (test-component-pathnames :delete-host t :support-string-pathnames nil)
(leave-lisp "test failed" 1)))
......
(in-package #:common-lisp-user)
(cl:in-package :common-lisp-user)
(load (make-pathname :name "script-support" :defaults *load-pathname*))
(defun load-pathname ()
#-gcl *load-pathname*
#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011
(symbol-value
(find-symbol
"*LOAD-PATHNAME*"
(if (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all
(and (= system::*gcl-major-version* 2)
(< system::*gcl-minor-version* 7)))
:system :cl))))
(in-package #:asdf-test)
(load (make-pathname :name "script-support" :type "lisp" :defaults (load-pathname))
#+gcl :print #+gcl t)
(declaim (optimize (speed 2) (safety 3) #-allegro (debug 3)
(in-package :asdf-test)
(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)
#+(or cmu scl) (c::brevity 2)))
(proclaim '(optimize (speed 2) (safety 3) #-allegro (debug 3)
(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)
#+(or cmu scl) (c::brevity 2)))
(defun my-compile-file (&rest args) (apply 'compile-file args))
#+ecl (trace my-compile-file)
(cond
((not (probe-file *asdf-lisp*))
(leave-lisp "Testsuite failed: unable to find ASDF source" 3))
......@@ -20,27 +29,10 @@
(ignore-errors (load *asdf-fasl*)))
(leave-lisp "Reusing previously-compiled ASDF" 0))
(t
#+clisp (load-asdf-lisp)
(load-asdf-lisp)
(let ((tmp (make-pathname :name "asdf-tmp" :defaults *asdf-fasl*)))
(ensure-directories-exist *asdf-fasl*)
(multiple-value-bind (result warnings-p errors-p)
;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
(handler-bind (#+sbcl (sb-c::simple-compiler-note #'muffle-warning)
#+(and ecl (not ecl-bytecmp))
((or c:compiler-note c::compiler-debug-note
c:compiler-warning) ;; ECL emits more serious warnings than it should.
#'muffle-warning)
#+mkcl
((or compiler:compiler-note)
#'muffle-warning)
#-(or cmu scl)
(style-warning
#'(lambda (w)
;; escalate style-warnings to warnings - we don't want them.
(warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A"
(type-of w) w)
(muffle-warning w))))
(my-compile-file *asdf-lisp* :output-file tmp :print t :verbose t))
(compile-asdf tmp)
(declare (ignore result))
(cond
(errors-p
......
......@@ -12,7 +12,7 @@ usage () {
echo " - quit with exit status >0 if an unhandled error occurs"
echo " you need to supply the .script in the second argument"
echo " lisps include abcl, allegro, allegromodern, ccl (clozure),"
echo " clisp, cmucl, ecl, gclcvs, sbcl, and scl."
echo " clisp, cmucl, ecl, gcl, gclcvs, sbcl, scl and xcl."
echo "OPTIONS:"
echo " -d -- debug mode"
echo " -u -h -- show this message."
......@@ -143,9 +143,14 @@ case "$lisp" in
command="${ECL:-ecl}"
flags="-norc -eval (ext::install-bytecodes-compiler)"
eval="-eval" ;;
gcl)
export GCL_ANSI=t
command="${GCL:-gcl}"
flags="-batch"
eval="-eval" ;;
gclcvs)
export GCL_ANSI=t
command="${GCL:-gclcvs}"
command="${GCLCVS:-gclcvs}"
flags="-batch"
eval="-eval" ;;
lispworks)
......
......@@ -3,17 +3,17 @@
(:export
#:*test-directory* #:*asdf-directory*
#:load-asdf
#:register-directory #:asdf-load
#:register-directory #:asdf-load
#:load-asdf-lisp #:compile-asdf #:load-asdf-fasl #:compile-load-asdf #:load-asdf-system
#:quit-on-error #:test-asdf
#:native-namestring
#:exit-lisp #:leave-lisp
#:quietly))
(in-package #:asdf-test)
(in-package :asdf-test)
(declaim (optimize (speed 2) (safety 3) #-allegro (debug 3)))
(proclaim '(optimize (speed 2) (safety 3) #-allegro (debug 3)))
(declaim (optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)))
(proclaim '(optimize (speed 2) (safety 3) #-(or allegro gcl) (debug 3)))
;;(format t "Evaluating asdf/test/script-support~%")
......@@ -21,11 +21,13 @@
;; We still want to work despite and host/device funkiness.
(defparameter *test-directory*
(make-pathname :name nil :type nil :version nil
:defaults (or *load-truename* *compile-file-truename*)))
:defaults (or #+gcl (truename system:*load-pathname*)
*load-truename* *compile-file-truename*)))
(defparameter *asdf-directory*
(merge-pathnames
(make-pathname :directory '(:relative :back) :defaults *test-directory*)
*test-directory*))
(truename
(merge-pathnames
(make-pathname :directory '(#-gcl :relative #-gcl :back #+gcl :parent) :defaults *test-directory*)
*test-directory*)))
(defparameter *asdf-lisp*
(make-pathname :name "asdf" :type "lisp" :defaults *asdf-directory*))
(defparameter *asdf-fasl*
......@@ -49,26 +51,37 @@
#+scl :scl
#+xcl :xcl))))
(merge-pathnames
(make-pathname :directory `(:relative "tmp" "fasls" ,impl)
(make-pathname :directory `(#-gcl :relative "tmp" "fasls" ,impl)
:defaults *asdf-directory*)
*asdf-lisp*))))
(defun load-old-asdf (tag)
(let ((old-asdf
(merge-pathnames
(make-pathname :directory `(:relative "tmp")
(make-pathname :directory `(#-gcl :relative "tmp")
:name (format nil "asdf-~A" tag)
:defaults *asdf-directory*)
*asdf-lisp*)))
(handler-bind (#+sbcl (sb-kernel:redefinition-warning #'muffle-warning))
(load old-asdf))))
(defun configure-asdf ()
(funcall (find-symbol (string :initialize-source-registry) :asdf)
`(:source-registry :ignore-inherited-configuration))
(let ((registry (find-symbol (string :*central-registry*) :asdf)))
(set registry `(,*asdf-directory* ,*test-directory*))))
(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)))
(defun hash-table->alist (table)
(loop :for key :being :the :hash-keys :of table :using (:hash-value value)
:collect (cons key value)))
(defun common-lisp-user::load-asdf ()
(load-asdf))
......@@ -164,9 +177,31 @@ is bound, write a message and exit on an error. If
(defun load-asdf-lisp ()
(load *asdf-lisp*))
(defun compile-asdf ()
#+(or gcl genera)
(unless (fboundp 'ensure-directories-exist)
(defun ensure-directories-exist (path)
#+genera (fs:create-directories-recursively (pathname path))
#+gcl (lisp:system (format nil "mkdir -p ~S" (namestring (make-pathname :name nil :type nil :defaults path))))))
(defun compile-asdf (&optional (output *asdf-fasl*))
(ensure-directories-exist *asdf-fasl*)
(compile-file *asdf-lisp* :output-file *asdf-fasl* :verbose t :print t))
;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
(handler-bind (#+sbcl (sb-c::simple-compiler-note #'muffle-warning)
#+(and ecl (not ecl-bytecmp))
((or c:compiler-note c::compiler-debug-note
c:compiler-warning) ;; ECL emits more serious warnings than it should.
#'muffle-warning)
#+mkcl
((or compiler:compiler-note)
#'muffle-warning)
#-(or cmu scl)
(style-warning
#'(lambda (w)
;; escalate style-warnings to warnings - we don't want them.
(warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A"
(type-of w) w)
(muffle-warning w))))
(compile-file *asdf-lisp* :output-file output #-gcl :verbose #-gcl t :print t)))
(defun load-asdf-fasl ()
(load *asdf-fasl*))
......@@ -220,6 +255,12 @@ outputs a tag plus a list of variable and their values, returns the last value"
(pushnew :DBG *features*)
#+gcl
(eval-when (:compile-toplevel :load-toplevel :execute)
(DBG :script-support *package* *test-directory* *asdf-directory* *asdf-lisp* *asdf-fasl*
))
#|
#+DBG (DBG :cas o c just-done base-stamp stamp-lookup out-files in-files file-op null-op op-time op-stamp dep-stamp out-stamps in-stamps missing-in missing-out all-present earliest-out latest-in done-stamp (stamp<= latest-in earliest-out) (operation-done-p o c))
(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))
|#
......@@ -6,8 +6,7 @@
(quit-on-error
(format t "~D~%" (asdf:asdf-version))
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:load-system 'test-builtin-source-file-type-1 :verbose t)
(load-system 'test-builtin-source-file-type-1 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))
(assert-equal
(mapcar #'pathname-type
......@@ -24,5 +23,4 @@
'("lisp" "cl"))
(delete-package :test-package)
(asdf:load-system 'test-builtin-source-file-type-4 :verbose t)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*")))
)
(assert (symbol-value (read-from-string "test-package::*test-tmp-cl*"))))
......@@ -2,6 +2,7 @@
(load "script-support.lisp")
(load-asdf)
#-gcl<2.7
(setf (logical-pathname-translations "ASDF")
#+(or allegro clisp)
`(("**;*.*.*" ,(asdf::wilden *asdf-directory*)))
......@@ -16,14 +17,14 @@
(format t "~S~%" (translate-logical-pathname "ASDF:test;test-force.asd"))
(format t "~S~%" (truename "ASDF:test;test-force.asd"))
#-xcl
#-(or xcl gcl<2.7)
(progn
(format t "Test logical pathnames in central registry~%")
(setf *central-registry* '(#p"ASDF:test;"))
(initialize-source-registry '(:source-registry :ignore-inherited-configuration))
(load-system :test-logical-pathname :force t))
#-xcl
#-(or xcl gcl<2.7)
(progn
(format t "Test logical pathnames in source-registry, non-recursive~%")
(clear-system :test-logical-pathname)
......@@ -32,7 +33,7 @@
'(:source-registry (:directory #p"ASDF:test;") :ignore-inherited-configuration))
(load-system :test-logical-pathname :force t))
#-xcl
#-(or xcl gcl<2.7)
(progn
(format t "Test logical pathnames in source-registry, recursive~%")
(clear-system :test-logical-pathname)
......
(in-package #:asdf-test)
(in-package :asdf-test)
;;; -*- Mode: common-lisp; Syntax: Common-Lisp; -*-
(in-package #:common-lisp-user)
(in-package :common-lisp-user)
(defpackage #:test-nested-components.system
(:use #:common-lisp #:asdf))
(in-package #:test-nested-components.system)
(in-package :test-nested-components.system)
(defsystem test-nested-components-a
:components
......
......@@ -4,35 +4,27 @@
(load "script-support.lisp")
(load-asdf)
;(trace asdf::find-component)
;(trace asdf:run-shell-command asdf:oos asdf:perform asdf:operate)
;#+allegro
;(trace excl.osi:command-output)
(defvar *caught-error* nil)
(quit-on-error
;;(format t "trlc1 1~%")
(when (probe-file "try-reloading-dependency.asd")
(asdf:run-shell-command "rm -f ~A"
(namestring "try-reloading-dependency.asd")))
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(DBG "trlc1 1")
(asdf::delete-file-if-exists "try-reloading-dependency.asd")
(setf asdf::*defined-systems* (asdf::make-defined-systems-table))
;;(format t "trlc1 2~%")
(DBG "trlc1 2")
(handler-bind ((error (lambda (c)
(format t "~&Caught error ~s" c)
(setf *caught-error* t)
(asdf:run-shell-command
"cp try-reloading-dependency.hidden try-reloading-dependency.asd")
;;(format t "trlc1 5~%")
(DBG "trlc1 5")
(multiple-value-bind (name mode)
(find-symbol (symbol-name 'retry) :asdf)
(DBG "trlc1 6" name mode)
(assert (eq mode :external) nil "Mode of ~s was not external" name)
;;(format t "trlc1 6~%")
(let ((restart (find-restart name c)))
;;(format t "trlc1 7~%")
(DBG "trlc1 7" restart)
(assert restart)
(format t "~&restart: ~S~&" restart)
(when restart (invoke-restart restart)))))))
;;(format t "trlc1 3~%")
(DBG "trlc1 3")
(asdf:oos 'asdf:load-op 'try-reloading-1))
;;(format t "trlc1 4~%")
(DBG "trlc1 4")
(assert *caught-error*))
;; part of the test-module-pathnames test
(in-package #:test-package)
(in-package :test-package)
(defparameter *test-tmp-cl* t)
......
;; part of the test-module-pathnames test
(in-package #:test-package)
(in-package :test-package)
(defparameter *test-tmp-cl* t)
......
......@@ -10,9 +10,9 @@
(assert
(every #'directory-pathname-p
(list
(make-pathname :name nil :type "" :directory '(:absolute "tmp"))
(make-pathname :name "" :directory '(:absolute "tmp"))
(make-pathname :type "" :directory '(:absolute "tmp"))
(make-pathname* :name nil :type "" :directory '(:absolute "tmp"))
(make-pathname* :name "" :directory '(:absolute "tmp"))
(make-pathname* :type "" :directory '(:absolute "tmp"))
;; CLHS 19.2.2.2.3 says we can't portably specify :unspecific here,
;; and some implementations will enforce it.
;; (make-pathname :type :unspecific :directory '(:absolute "tmp"))
......@@ -22,11 +22,11 @@
(assert
(every (complement #'directory-pathname-p)
(list
(make-pathname :name "foo" :type nil :directory '(:absolute "tmp"))
(make-pathname :name nil :type "bar" :directory '(:absolute "tmp")))))
(make-pathname* :name "foo" :type nil :directory '(:absolute "tmp"))
(make-pathname* :name nil :type "bar" :directory '(:absolute "tmp")))))
;; These are funky and non portable. Omit from tests.
;; (make-pathname :name "." :type nil :directory '(:absolute "tmp"))
;; (make-pathname :name "." :type "" :directory '(:absolute "tmp"))
;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp"))
;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp"))
(assert (equal (multiple-value-list (component-name-to-pathname-components "" :force-directory t))
'(:relative nil nil)))
(assert (equal (multiple-value-list (component-name-to-pathname-components "" :force-directory nil))
......
(in-package #:asdf-test)
(in-package :asdf-test)
(setf *test6* :yes)
......@@ -4,7 +4,7 @@
(load "script-support.lisp")
(load-asdf)
(in-package #:asdf-test)
(in-package :asdf-test)
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
......
(in-package #:asdf-test)
(in-package :asdf-test)
#+clisp (eval-when (:compile-toplevel) (fmakunbound 'try-recompiling-1))
......
......@@ -2,6 +2,5 @@
(load "script-support.lisp")
(load-asdf)
(quit-on-error
(load "../wild-modules.lisp")
(setf *central-registry* '(*default-pathname-defaults*))
(load (asdf:system-relative-pathname :asdf "wild-modules.lisp"))
(load-system :wild-module))
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