diff --git a/asdf.asd b/asdf.asd index 4818b35f6d695697bdf0245c2fbb7c5c1a3a598a..9ab5e5b43af3154a0983ffbf2b5ff050545f481b 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.83" ;; to be automatically updated by bin/bump-revision + :version "2.26.84" ;; to be automatically updated by bin/bump-revision :depends-on () :components ((:module "build" :components ((:file "asdf")))) :in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf)))) diff --git a/bundle.lisp b/bundle.lisp index 4bc8f6e525ecb0d47c7fb5b7699542fbb370813d..8e05a1c3cb0ad4f8ce69834558ee06080c8aa244 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -277,7 +277,7 @@ nil) (defmethod perform ((o load-fasl-op) (c system)) - (if-bind (it (first (input-files o c))) (load it))) + (perform-lisp-load-fasl o c)) (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) (mark-operation-done (find-operation o 'load-op) c)) ; need we recurse on gather-components? @@ -299,8 +299,7 @@ (declare (ignorable o)) (component-pathname c)) (defmethod perform ((o load-op) (c compiled-file)) - (declare (ignorable o)) - (load (first (input-files o c)))) + (perform-lisp-load-fasl o c)) (defmethod perform ((o load-source-op) (c compiled-file)) (perform (find-operation o 'load-op) c)) (defmethod perform ((o load-fasl-op) (c compiled-file)) diff --git a/compatibility.lisp b/compatibility.lisp index f8ef8fe3292b094f33ea922158399ced0bb5d4d1..f5b62c6dfbb27620fca24665d2ca5fcddfb9aff9 100644 --- a/compatibility.lisp +++ b/compatibility.lisp @@ -54,7 +54,9 @@ (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 lacks output-translations and more. (and (= system::*gcl-major-version* 2) (< system::*gcl-minor-version* 7))) + (format t "Detected an old GCL 2.6. Only limited functionality available.~%") (shadow 'type-of :asdf/compatibility) + (export 'with-standard-io-syntax) (pushnew 'ignorable pcl::*variable-declarations-without-argument*) (pushnew :gcl<2.7 *features*)) (unless (member :ansi-cl *features*) @@ -81,6 +83,7 @@ #+gcl<2.7 (progn ;; Doesn't support either logical-pathnames or output-translations. + (defvar *gcl<2.7* t) (deftype logical-pathname () nil) (defun type-of (x) (class-name (class-of x))) (defun wild-pathname-p (path) (declare (ignore path)) nil) @@ -94,6 +97,8 @@ (format stream "#<~@[~S ~]" (when type (type-of object))) (funcall thunk) (format stream "~@[ ~X~]>" (when identity (system:address object)))) + (defmacro with-standard-io-syntax (&body body) + `(progn ,@body)) (defmacro with-compilation-unit (options &body body) (declare (ignore options)) `(progn ,@body)) (defmacro print-unreadable-object ((object stream &key type identity) &body body) diff --git a/find-system.lisp b/find-system.lisp index 6719843e7e6b1274c014432174c3cb97e37d4ead..9ce4800ce927f86d0ded4537f41ea1694dc4d9a0 100644 --- a/find-system.lisp +++ b/find-system.lisp @@ -4,7 +4,7 @@ (asdf/package:define-package :asdf/find-system (:recycle :asdf/find-system :asdf) (:use :common-lisp :asdf/compatibility :asdf/utility :asdf/pathname :asdf/stream :asdf/os - :asdf/upgrade :asdf/component :asdf/system) + :asdf/lisp-build :asdf/upgrade :asdf/component :asdf/system) (:export #:coerce-name #:find-system #:locate-system #:load-sysdef #:with-system-definitions #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems @@ -251,7 +251,8 @@ Going forward, we recommend new users should be using the source-registry. (external-format (encoding-external-format (detect-encoding pathname)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%") pathname package) - (load pathname #-gcl<2.7 :external-format #-gcl<2.7 external-format))) + (with-controlled-loader-conditions () + (load* pathname :external-format external-format)))) (delete-package package))))) (defun* locate-system (name) diff --git a/header.lisp b/header.lisp index 34f588da8a7c74e7efef95227450923a9abf1034..09735bd9d78490d3c93248e722ab964b3251bf99 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.83: Another System Definition Facility. +;;; This is ASDF 2.26.84: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel@common-lisp.net>. diff --git a/lisp-action.lisp b/lisp-action.lisp index 9d29f4fc5eb30d280ca0a03c7b0fb8c129ec378a..70911cb632aa21859e025f19f23c12eb26d99eab 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -158,8 +158,8 @@ (component-name c))) (perform (find-operation o 'compile-op) c))))) (defun* perform-lisp-load-fasl (o c) - (with-controlled-loader-conditions () - (load (first (input-files o c))))) + (if-bind (fasl (first (input-files o c))) + (with-controlled-loader-conditions () (load* fasl)))) (defmethod perform ((o load-op) (c cl-source-file)) (perform-lisp-load-fasl o c)) (defmethod perform ((o load-op) (c static-file)) diff --git a/lisp-build.lisp b/lisp-build.lisp index 92098647f458300107f36d6441dcb037688215a7..01438f5731901b410110798c0df3c5930571cc6a 100644 --- a/lisp-build.lisp +++ b/lisp-build.lisp @@ -145,13 +145,13 @@ or a string describing the format-control of a simple-condition." (defun* call-with-controlled-compiler-conditions (thunk) (call-with-muffled-uninteresting-conditions thunk *uninteresting-compiler-conditions*)) -(defmacro with-controlled-compiler-conditions (() &body body) +(defmacro with-controlled-compiler-conditions ((&optional) &body body) "Run BODY where uninteresting compiler conditions are muffled" `(call-with-controlled-compiler-conditions #'(lambda () ,@body))) (defun* call-with-controlled-loader-conditions (thunk) (call-with-muffled-uninteresting-conditions thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*))) -(defmacro with-controlled-loader-conditions (() &body body) +(defmacro with-controlled-loader-conditions ((&optional) &body body) "Run BODY where uninteresting compiler and additional loader conditions are muffled" `(call-with-muffled-uninteresting-conditions #'(lambda () ,@body))) @@ -261,10 +261,9 @@ for processing later (possibly in a different process)." (remove-keys `(#+(and allegro (not (version>= 8 2))) :external-format ,@(unless output-file '(:output-file))) keys))))) -(defun* load* (x &rest keys &key external-format &allow-other-keys) - (declare (ignorable external-format)) +(defun* load* (x &rest keys &key &allow-other-keys) (etypecase x - ((or pathname string #-(or gcl-pre2.7 clozure allegro) stream) + ((or pathname string #-(or gcl<2.7 clozure allegro) stream) (apply 'load x #-gcl<2.7 keys #+gcl<2.7 (remove-keyword :external-format keys))) #-(or gcl<2.7 clozure allegro) @@ -272,9 +271,10 @@ for processing later (possibly in a different process)." ;; ClozureCL 1.6 can only load from file input stream ;; Allegro 5, I don't remember but it must have been broken when I tested. (stream ;; make do this way - (let ((*load-pathname* nil) - (*load-truename* nil) - #+clozure (ccl::*default-external-format* external-format)) + (let ((*package* *package*) + (*readtable* *readtable*) + (*load-pathname* nil) + (*load-truename* nil)) (eval-input x))))) (defun* load-from-string (string) @@ -293,8 +293,8 @@ for processing later (possibly in a different process)." (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys) #+mkcl progn (let ((object-file - (apply 'compile-file-pathname - output-file #+ecl :type #+ecl :object #+mkcl :fasl-p #+mkcl nil))) + (compile-file-pathname + output-file #+ecl :type #+ecl :object #+mkcl :fasl-p #+mkcl nil))) (multiple-value-bind (result flags1 flags2) (apply 'compile-file* input-file #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil diff --git a/os.lisp b/os.lisp index 3c1024504f63919e3f696262c8d900002f426d36..8f6abe1f9a2ea025a2ab961e0bea048fb383b0a3 100644 --- a/os.lisp +++ b/os.lisp @@ -14,7 +14,8 @@ #:implementation-type #:operating-system #:architecture #:lisp-version-string #:hostname #:user-homedir #:lisp-implementation-directory #:getcwd #:chdir #:call-with-current-directory #:with-current-directory - #:*temporary-directory* #:temporary-directory #:default-temporary-directory #:with-temporary-file)) + #:*temporary-directory* #:temporary-directory #:default-temporary-directory + #:call-with-temporary-file #:with-temporary-file)) (in-package :asdf/os) ;;; Features @@ -282,6 +283,7 @@ then returning the non-empty string value of the variable" prefix keep (direction :io) (element-type *default-stream-element-type*) (external-format :default)) + #+gcl<2.7 (declare (ignorable external-format)) (check-type direction (member :output :io)) (loop :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory)))) @@ -292,7 +294,8 @@ then returning the non-empty string value of the variable" ;; TODO: on Unix, use CFFI and mkstemp -- but the master is precisely meant to not depend on CFFI or on anything! Grrrr. (with-open-file (stream pathname :direction direction - :element-type element-type :external-format external-format + :element-type element-type + #-gcl<2.7 :external-format #-gcl<2.7 external-format :if-exists nil :if-does-not-exist :create) (when stream (return diff --git a/package.lisp b/package.lisp index 493b07213a02d25a39688040c9bf7f8accfe8d5b..57b7052e693dd7e32e44141c851ae68fe5b1fe23 100644 --- a/package.lisp +++ b/package.lisp @@ -38,7 +38,7 @@ If optional ERROR argument is NIL, return NIL instead of an error when the symbol is not found." (block nil (let ((package (find-package* package-designator error))) - (when package + (when package ;; package error handled by find-package* already (multiple-value-bind (symbol status) (find-symbol (string name) package) (cond (status (return (values symbol status))) diff --git a/run-program.lisp b/run-program.lisp index 77e62f1424a9537e03f28797e0988f161ccc3d8d..f262cf2de574de8f63b8c67b09549ddaa8690a64 100644 --- a/run-program.lisp +++ b/run-program.lisp @@ -134,12 +134,14 @@ by /bin/sh in POSIX" (defgeneric* slurp-input-stream (processor input-stream &key &allow-other-keys)) +#-(or gcl<2.7 genera) (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys) (funcall function input-stream)) (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys) (apply (first list) (cons input-stream (rest list)))) +#-(or gcl<2.7 genera) (defmethod slurp-input-stream ((output-stream stream) input-stream &key (element-type 'character) &allow-other-keys) (copy-stream-to-stream @@ -165,6 +167,18 @@ by /bin/sh in POSIX" (declare (ignorable x)) (slurp-stream-forms stream)) +(defmethod slurp-input-stream (x stream &key (element-type 'character) &allow-other-keys) + (declare (ignorable stream element-type)) + (cond + #+(or gcl<2.7 genera) + ((functionp x) + (funcall x stream)) + #+(or gcl<2.7 genera) + ((output-stream-p x) + (copy-stream-to-stream stream x :element-type element-type)) + (t + (error "Invalid ~S destination ~S" 'slurp-input-stream x)))) + ;;;; ----- Running an external program ----- ;;; Simple variant of run-program with no input, and capturing output @@ -261,8 +275,8 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process :output (if pipe :stream t) . #.(append #+(or clozure cmu ecl sbcl scl) '(:error t) - #+sbcl '(:search t - #|:external-format external-format ; not in old SBCLs|#))))) + ;; note: :external-format requires a recent SBCL + #+sbcl '(:search t :external-format external-format))))) (process #+(or allegro lispworks) (if pipe (third process*) (first process*)) #+ecl (third process*) @@ -352,7 +366,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process :direction :input :if-does-not-exist :error :element-type element-type - :external-format external-format) + #-gcl<2.7 :external-format #-gcl<2.7 external-format) (slurp-input-stream output stream))) (call-system (system-command command) :interactive interactive))))) (if (and (not force-shell) diff --git a/stream.lisp b/stream.lisp index 6f428712d13a97ce3a2d62b86077782311e9e497..675d6cc0b9f9538232c0c2f865e75898c74e185a 100644 --- a/stream.lisp +++ b/stream.lisp @@ -44,34 +44,24 @@ ;;; Output to a stream or string, FORMAT-style -(defgeneric call-with-output (x thunk) - (:documentation - ;; code from fare-utils base/streams where it's now named - ;; call-with-output-stream to avoid the package clash in a lot of my code. - "Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing: +(defun* call-with-output (x thunk) + "Calls FUN with an actual stream argument, behaving like FORMAT with respect to stream'ing: If OBJ is a stream, use it as the stream. If OBJ is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string. If OBJ is T, use *STANDARD-OUTPUT* as the stream. If OBJ is a string with a fill-pointer, use it as a string-output-stream. -Otherwise, signal an error.") - (:method ((x null) thunk) - (declare (ignorable x)) - (with-output-to-string (s) (funcall thunk s))) - (:method ((x (eql t)) thunk) - (declare (ignorable x)) - (funcall thunk *standard-output*) nil) - #-genera - (:method ((x stream) thunk) - (funcall thunk x) nil) - (:method ((x string) thunk) - (assert (fill-pointer x)) - (with-output-to-string (s x) (funcall thunk s))) - (:method (x thunk) - (declare (ignorable thunk)) - (cond - #+genera - ((typep x 'stream) (funcall thunk x) nil) - (t (error "not a valid stream designator ~S" x))))) +Otherwise, signal an error." + (typecase x + (null + (with-output-to-string (s) (funcall thunk s))) + ((eql t) + (funcall thunk *standard-output*)) + (stream + (funcall thunk x)) + (string + (assert (fill-pointer x)) + (with-output-to-string (s x) (funcall thunk s))) + (t (error "not a valid stream designator ~S" x)))) (defmacro with-output ((x &optional (value x)) &body body) "Bind X to an output stream, coercing VALUE (default: previous binding of X) @@ -112,8 +102,10 @@ Otherwise, signal an error." &key (element-type *default-stream-element-type*) (external-format :default)) "Open FILE for input with given options, call THUNK with the resulting stream." + #+gcl<2.7 (declare (ignore external-format)) (with-open-file (s pathname :direction :input - :element-type element-type :external-format external-format + :element-type element-type + #-gcl<2.7 :external-format #-gcl<2.7 external-format :if-does-not-exist :error) (funcall thunk s))) diff --git a/test/asdf-pathname-test.script b/test/asdf-pathname-test.script index 18b3f3cbd766ce5aacd09ee98e816530babdebb9..8e738d9d917d1c23e6c5361614e80b71d3d0a8de 100644 --- a/test/asdf-pathname-test.script +++ b/test/asdf-pathname-test.script @@ -49,7 +49,9 @@ (*print-pretty* nil) (start-time 0)) - (with-open-file (result-stream (asdf::merge-pathnames* "output.txt" root) + (with-open-file (result-stream (asdf::subpathname + *build-directory* + (format nil "results/~(~A~)-pathnames.txt" *implementation*)) :direction :output :if-exists :supersede :if-does-not-exist :create) (flet ((src-dir (&rest path) (append (or (pathname-directory root) (list :relative)) @@ -122,7 +124,7 @@ :defaults root) ,(make-pathname :directory (src-dir "system2" "module4") :name "file" :type "lisp" :defaults root) - ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name "file" :type "lisp" + ,(make-pathname :host "ASDFTEST" :directory '(:absolute "system2" "module4") :name "file" :type "lisp" :version nil :defaults root) ,(parse-namestring "ASDFTEST:system2;module4;file.lisp") ,@(when support-string-pathnames @@ -221,9 +223,7 @@ ((error (lambda (c) (incf system-failures) (format *error-output* "~&error! ~a~%sysdef:~% ~S~%" c system-definition) - #+sbcl (sb-debug:backtrace 69) - #+clozure (ccl:print-call-history :count 69 :start-frame-number 1) - #+clisp (system::print-backtrace) + (asdf::print-condition-backtrace c :stream *error-output*) (format result-stream "~&~%***~%error: ~a~%~s" c system-definition) (return-from :test-system)))) diff --git a/test/run-tests.sh b/test/run-tests.sh index d33559946100a2a49d05a5e7cf5987b56d45cec4..0bc6f79771c6d4f44fa6a9da6f9a0189881c55dd 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -288,6 +288,9 @@ clean_up () { rm -rf ../build/test-source-registry-conf.d ../build/test-asdf-output-translations-conf.d } test_clean_load () { + case $lisp in + gcl) return 0 ;; # GCL 2.6 is hopeless + esac nop=build/results/${lisp}-nop.text load=build/results/${lisp}-load.text ${command} ${eval} \ diff --git a/test/script-support.lisp b/test/script-support.lisp index 71b3711d29b0a1a816010ee5cd51920c92a80dd1..bcc61983e5285086751ef4d79cf9c229302ff5ad 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -31,7 +31,7 @@ Some constraints: #+(or cmu scl) (c::brevity 2))) (defvar *trace-symbols* - '(;; If you want to trace some stuff while debugging ASDF, + `(;; If you want to trace some stuff while debugging ASDF, ;; here's a nice place to say what. ;; These string designators will be interned in ASDF after it is loaded. )) @@ -57,7 +57,10 @@ Some constraints: ;;; Survival utilities (defun asym (name) - (find-symbol (string name) :asdf)) + (let ((asdf (find-package :asdf))) + (unless asdf (error "Can't find package ASDF")) + (or (find-symbol (string name) asdf) + (error "Can't find symbol ~A in ASDF" name)))) (defun acall (name &rest args) (apply (asym name) args)) @@ -98,7 +101,7 @@ Some constraints: #+cmu :cmucl #+corman :cormanlisp #+digitool :mcl - #+ecl :ecl + #+ecl (or #+ecl-bytecmp :ecl_bytecodes :ecl) #+gcl :gcl #+lispworks :lispworks #+mkcl :mkcl @@ -181,7 +184,7 @@ Some constraints: (finish-outputs) (throw :asdf-test-done return)) -(defmacro with-test (() &body body) +(defmacro with-test ((&optional) &body body) `(call-with-test (lambda () ,@body))) (defun call-with-test (thunk) diff --git a/test/static-and-serial.asd b/test/static-and-serial.asd deleted file mode 100644 index 2e4842aa04676f9a363d4b4058392794804c8e44..0000000000000000000000000000000000000000 --- a/test/static-and-serial.asd +++ /dev/null @@ -1,12 +0,0 @@ -#| -make sure that serial t and static-files don't cause full rebuilds all -the time... -|# - -(defsystem static-and-serial - :version "0.1" - :serial t - :components - ((:static-file "file2.lisp") - (:static-file "run-tests.sh") - (:file "file1"))) diff --git a/test/test-encodings.script b/test/test-encodings.script index 600f7cc6b3cb685f5b2b1f394dfdec40298bbad8..502db2f4fa68f9aecb61ebb95e1459f00022aa0e 100644 --- a/test/test-encodings.script +++ b/test/test-encodings.script @@ -43,6 +43,9 @@ (defsystem :test-encoding-explicit-u8 :components ((:file "lambda" :encoding :utf-8)))) + #-asdf-unicode + (leave-test "No Unicode support to test on this lisp implementation" 0) + ;; NB: recent clozure can autodetect without asdf-encodings with :default (!) #+(and asdf-unicode sbcl) diff --git a/test/test-static-and-serial.script b/test/test-static-and-serial.script index b39596a982ba1a5898d06a12d7293dec4f50205a..0276664848891b3c2a0f1b71caf8b24445c85fef 100644 --- a/test/test-static-and-serial.script +++ b/test/test-static-and-serial.script @@ -1,17 +1,17 @@ ;;; -*- Lisp -*- +#| +make sure that serial t and static-files +don't cause full rebuilds all the time... +|# (load "script-support.lisp") (load-asdf) (in-package :asdf-test) -#+gcl (trace coerce-pathname) - (with-test () - (format t "dpd: ~S~%f1: ~S~%" *default-pathname-defaults* (asdf::merge-pathnames* "file1")) - (setf asdf:*central-registry* '(*default-pathname-defaults*)) + (load-test-system 'static-and-serial) - (asdf:operate 'asdf:load-op 'static-and-serial) (let* ((file1 (asdf:compile-file-pathname* "file1.lisp")) (file1-date (file-write-date file1)) (date1 (- file1-date 600)) @@ -22,9 +22,10 @@ (format t "file: ~S~%date: ~S~%" file1 file1-date) ;; date should stay same - (asdf:clear-system 'static-and-serial) + (clear-system 'static-and-serial) + (touch-file "static-and-serial.asd" :offset -10000) (touch-file "file2.lisp" :timestamp date1) (touch-file "file1.lisp" :timestamp date2) (touch-file file1 :timestamp date3) - (asdf:operate 'asdf:load-op 'static-and-serial) - (assert (equal (file-write-date file1) date3)))) + (DBG "load again" (oos 'load-op 'static-and-serial)) + (assert-equal (file-write-date file1) date3))) diff --git a/test/wild-module.script b/test/wild-module.script index e6dd5ead0d5ab967702951b78b9aff206b0102c1..f6d14ade8f16887711087318547028f7aa3c7dc7 100644 --- a/test/wild-module.script +++ b/test/wild-module.script @@ -6,4 +6,5 @@ (asdf:defsystem :wild-module :version "0.0" :components ((:wild-module "systems" :pathname #p"*.asd"))) + #-gcl<2.7 (load-system :wild-module)) diff --git a/upgrade.lisp b/upgrade.lisp index e7773b3ae7c3dfdf276dca95ad93f186c86c1232..790bf11d9ffeeb6cdcfd0fd3a419080fffb7b67a 100644 --- a/upgrade.lisp +++ b/upgrade.lisp @@ -32,7 +32,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.83") + (asdf-version "2.26.84") (existing-asdf (find-class (find-symbol* :component :asdf nil) nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version)))