Commit 579ff410 authored by Robert P. Goldman's avatar Robert P. Goldman
Browse files
parents 4ef46a98 ab2e6a12
...@@ -153,6 +153,7 @@ test-all: doc test-all-lisps ...@@ -153,6 +153,7 @@ test-all: doc test-all-lisps
test-all-no-stop: test-all-no-stop:
-make doc ; for l in ${lisps} ; do make t l=$$l ; make u l=$$l ; done ; true -make doc ; for l in ${lisps} ; do make t l=$$l ; make u l=$$l ; done ; true
extract: extract-all-tagged-asdf
extract-all-tagged-asdf: build/asdf.lisp extract-all-tagged-asdf: build/asdf.lisp
./test/run-tests.sh -H ./test/run-tests.sh -H
......
...@@ -38,17 +38,26 @@ ...@@ -38,17 +38,26 @@
;;;; Convenience methods ;;;; Convenience methods
(with-upgradability () (with-upgradability ()
(defmacro define-convenience-action-methods (defmacro define-convenience-action-methods
(function (operation component &optional keyp) (function formals &key if-no-operation if-no-component operation-initargs)
&key if-no-operation if-no-component operation-initargs)
(let* ((rest (gensym "REST")) (let* ((rest (gensym "REST"))
(found (gensym "FOUND")) (found (gensym "FOUND"))
(keyp (equal (last formals) '(&key)))
(formals-no-key (if keyp (butlast formals) formals))
(len (length formals-no-key))
(operation 'operation)
(component 'component)
(opix (position operation formals))
(coix (position component formals))
(prefix (subseq formals 0 opix))
(suffix (subseq formals (1+ coix) len))
(more-args (when keyp `(&rest ,rest &key &allow-other-keys)))) (more-args (when keyp `(&rest ,rest &key &allow-other-keys))))
(assert (and (integerp opix) (integerp coix) (= coix (1+ opix))))
(flet ((next-method (o c) (flet ((next-method (o c)
(if keyp (if keyp
`(apply ',function ,o ,c ,rest) `(apply ',function ,@prefix ,o ,c ,@suffix ,rest)
`(,function ,o ,c)))) `(,function ,@prefix ,o ,c ,@suffix))))
`(progn `(progn
(defmethod ,function ((,operation symbol) ,component ,@more-args) (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args)
(if ,operation (if ,operation
,(next-method ,(next-method
(if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck. (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck.
...@@ -56,14 +65,13 @@ ...@@ -56,14 +65,13 @@
`(make-operation ,operation)) `(make-operation ,operation))
`(or (find-component () ,component) ,if-no-component)) `(or (find-component () ,component) ,if-no-component))
,if-no-operation)) ,if-no-operation))
(defmethod ,function ((,operation operation) ,component ,@more-args) (defmethod ,function (,@prefix (,operation operation) ,component ,@suffix ,@more-args)
(if (typep ,component 'component) (if (typep ,component 'component)
(error "No defined method for ~S on ~/asdf-action:format-action/" (error "No defined method for ~S on ~/asdf-action:format-action/"
',function (cons ,operation ,component)) ',function (cons ,operation ,component))
(let ((,found (find-component () ,component))) (if-let (,found (find-component () ,component))
(if ,found ,(next-method operation found)
,(next-method operation found) ,if-no-component))))))))
,if-no-component)))))))))
;;;; self-description ;;;; self-description
......
...@@ -74,7 +74,7 @@ ...@@ -74,7 +74,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 "3.0.1.3" ;; to be automatically updated by make bump-version :version "3.0.1.7" ;; to be automatically updated by make bump-version
:depends-on () :depends-on ()
#+asdf3 :encoding #+asdf3 :utf-8 #+asdf3 :encoding #+asdf3 :utf-8
;; For most purposes, asdf itself specially counts as a builtin system. ;; For most purposes, asdf itself specially counts as a builtin system.
......
...@@ -5,11 +5,11 @@ ...@@ -5,11 +5,11 @@
(:recycle :asdf/backward-interface :asdf) (:recycle :asdf/backward-interface :asdf)
(:use :uiop/common-lisp :uiop :asdf/upgrade (:use :uiop/common-lisp :uiop :asdf/upgrade
:asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
:asdf/lisp-action :asdf/operate :asdf/output-translations) :asdf/lisp-action :asdf/plan :asdf/operate :asdf/output-translations)
(:export (:export
#:*asdf-verbose* #:*asdf-verbose*
#:operation-error #:compile-error #:compile-failed #:compile-warned #:operation-error #:compile-error #:compile-failed #:compile-warned
#:error-component #:error-operation #:error-component #:error-operation #:traverse
#:component-load-dependencies #:component-load-dependencies
#:enable-asdf-binary-locations-compatibility #:enable-asdf-binary-locations-compatibility
#:operation-forced #:operation-forced
...@@ -62,7 +62,19 @@ We recommend you use ASDF:SYSTEM-SOURCE-FILE instead ...@@ -62,7 +62,19 @@ We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
for a mostly compatible replacement that we're supporting, for a mostly compatible replacement that we're supporting,
or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
if that's whay you mean." ;;) if that's whay you mean." ;;)
(system-source-file x))) (system-source-file x))
(defgeneric* (traverse) (operation component &key &allow-other-keys)
(:documentation
"Generate and return a plan for performing OPERATION on COMPONENT.
The plan returned is a list of dotted-pairs. Each pair is the CONS
of ASDF operation object and a COMPONENT object. The pairs will be
processed in order by OPERATE."))
(define-convenience-action-methods traverse (operation component &key))
(defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys)
(plan-actions (apply 'make-plan plan-class o c keys))))
;;;; ASDF-Binary-Locations compatibility ;;;; ASDF-Binary-Locations compatibility
......
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;; This is ASDF 3.0.1.3: Another System Definition Facility. ;;; This is ASDF 3.0.1.7: 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>.
......
...@@ -19,7 +19,7 @@ ...@@ -19,7 +19,7 @@
;; TODO: automatically generate interface with reexport? ;; TODO: automatically generate interface with reexport?
(:export (:export
#:defsystem #:find-system #:locate-system #:coerce-name #:defsystem #:find-system #:locate-system #:coerce-name
#:oos #:operate #:traverse #:perform-plan #:sequential-plan #:oos #:operate #:make-plan #:perform-plan #:sequential-plan
#:system-definition-pathname #:with-system-definitions #:system-definition-pathname #:with-system-definitions
#:search-for-system-definition #:find-component #:component-find-path #:search-for-system-definition #:find-component #:component-find-path
#:compile-system #:load-system #:load-systems #:compile-system #:load-system #:load-systems
...@@ -75,6 +75,7 @@ ...@@ -75,6 +75,7 @@
#:module-components ; backward-compatibility #:module-components ; backward-compatibility
#:operation-on-warnings #:operation-on-failure ; backward-compatibility #:operation-on-warnings #:operation-on-failure ; backward-compatibility
#:component-property ; backward-compatibility #:component-property ; backward-compatibility
#:traverse ; backward-compatibility
#:system-description #:system-description
#:system-long-description #:system-long-description
......
...@@ -86,8 +86,8 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: ...@@ -86,8 +86,8 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
(error 'missing-component-of-version :requires component :version version))) (error 'missing-component-of-version :requires component :version version)))
(defmethod operate ((operation operation) (component component) (defmethod operate ((operation operation) (component component)
&rest keys &key &allow-other-keys) &rest keys &key plan-class &allow-other-keys)
(let ((plan (apply 'traverse operation component keys))) (let ((plan (apply 'make-plan plan-class operation component keys)))
(apply 'perform-plan plan keys) (apply 'perform-plan plan keys)
(values operation plan))) (values operation plan)))
......
...@@ -20,7 +20,7 @@ ...@@ -20,7 +20,7 @@
#:visit-dependencies #:compute-action-stamp #:traverse-action #:visit-dependencies #:compute-action-stamp #:traverse-action
#:circular-dependency #:circular-dependency-actions #:circular-dependency #:circular-dependency-actions
#:call-while-visiting-action #:while-visiting-action #:call-while-visiting-action #:while-visiting-action
#:traverse #:plan-actions #:perform-plan #:plan-operates-on-p #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p
#:planned-p #:index #:forced #:forced-not #:total-action-count #:planned-p #:index #:forced #:forced-not #:total-action-count
#:planned-action-count #:planned-output-action-count #:visited-actions #:planned-action-count #:planned-output-action-count #:visited-actions
#:visiting-action-set #:visiting-action-list #:plan-actions-r #:visiting-action-set #:visiting-action-list #:plan-actions-r
...@@ -342,6 +342,8 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -342,6 +342,8 @@ the action of OPERATION on COMPONENT in the PLAN"))
((actions-r :initform nil :accessor plan-actions-r))) ((actions-r :initform nil :accessor plan-actions-r)))
(defgeneric plan-actions (plan)) (defgeneric plan-actions (plan))
(defmethod plan-actions ((plan list))
plan)
(defmethod plan-actions ((plan sequential-plan)) (defmethod plan-actions ((plan sequential-plan))
(reverse (plan-actions-r plan))) (reverse (plan-actions-r plan)))
...@@ -358,39 +360,40 @@ the action of OPERATION on COMPONENT in the PLAN")) ...@@ -358,39 +360,40 @@ the action of OPERATION on COMPONENT in the PLAN"))
;;;; high-level interface: traverse, perform-plan, plan-operates-on-p ;;;; high-level interface: traverse, perform-plan, plan-operates-on-p
(with-upgradability () (with-upgradability ()
(defgeneric* (traverse) (operation component &key &allow-other-keys) (defgeneric make-plan (plan-class operation component &key &allow-other-keys)
(:documentation (:documentation
"Generate and return a plan for performing OPERATION on COMPONENT. "Generate and return a plan for performing OPERATION on COMPONENT."))
(define-convenience-action-methods make-plan (plan-class operation component &key))
The plan returned is a list of dotted-pairs. Each pair is the CONS
of ASDF operation object and a COMPONENT object. The pairs will be
processed in order by OPERATE."))
(define-convenience-action-methods traverse (operation component &key))
(defgeneric perform-plan (plan &key)) (defgeneric perform-plan (plan &key))
(defgeneric plan-operates-on-p (plan component)) (defgeneric plan-operates-on-p (plan component))
(defvar *default-plan-class* 'sequential-plan) (defvar *default-plan-class* 'sequential-plan)
(defmethod traverse ((o operation) (c component) &rest keys &key plan-class &allow-other-keys) (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys)
(let ((plan (apply 'make-instance (let ((plan (apply 'make-instance
(or plan-class *default-plan-class*) (or plan-class *default-plan-class*)
:system (component-system c) (remove-plist-key :plan-class keys)))) :system (component-system c) keys)))
(traverse-action plan o c t) (traverse-action plan o c t)
(plan-actions plan))) plan))
(defmethod perform-plan :around (plan &key) (defmethod perform-plan :around ((plan t) &key)
(declare (ignorable plan))
(let ((*package* *package*) (let ((*package* *package*)
(*readtable* *readtable*)) (*readtable* *readtable*))
(with-compilation-unit () ;; backward-compatibility. (with-compilation-unit () ;; backward-compatibility.
(call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build.
(defmethod perform-plan ((plan t) &rest keys &key &allow-other-keys)
(apply 'perform-plan (plan-actions plan) keys))
(defmethod perform-plan ((steps list) &key force &allow-other-keys) (defmethod perform-plan ((steps list) &key force &allow-other-keys)
(loop* :for (o . c) :in steps (loop* :for (o . c) :in steps
:when (or force (not (nth-value 1 (compute-action-stamp nil o c)))) :when (or force (not (nth-value 1 (compute-action-stamp nil o c))))
:do (perform-with-restarts o c))) :do (perform-with-restarts o c)))
(defmethod plan-operates-on-p ((plan plan-traversal) (component-path list))
(plan-operates-on-p (plan-actions plan) component-path))
(defmethod plan-operates-on-p ((plan list) (component-path list)) (defmethod plan-operates-on-p ((plan list) (component-path list))
(find component-path (mapcar 'cdr plan) (find component-path (mapcar 'cdr plan)
:test 'equal :key 'component-find-path))) :test 'equal :key 'component-find-path)))
...@@ -422,9 +425,9 @@ processed in order by OPERATE.")) ...@@ -422,9 +425,9 @@ processed in order by OPERATE."))
(let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys))) (let ((plan (apply 'make-instance (or plan-class 'filtered-sequential-plan) keys)))
(loop* :for (o . c) :in actions :do (loop* :for (o . c) :in actions :do
(traverse-action plan o c t)) (traverse-action plan o c t))
(plan-actions plan))) plan))
(define-convenience-action-methods traverse-sub-actions (o c &key)) (define-convenience-action-methods traverse-sub-actions (operation component &key))
(defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys) (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys)
(apply 'traverse-actions (direct-dependencies operation component) (apply 'traverse-actions (direct-dependencies operation component)
:system (component-system component) keys)) :system (component-system component) keys))
...@@ -438,7 +441,8 @@ processed in order by OPERATE.")) ...@@ -438,7 +441,8 @@ processed in order by OPERATE."))
(defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys)
(remove-duplicates (remove-duplicates
(mapcar 'cdr (apply 'traverse-sub-actions goal-operation system (mapcar 'cdr (plan-actions
(remove-plist-key :goal-operation keys))) (apply 'traverse-sub-actions goal-operation system
(remove-plist-key :goal-operation keys))))
:from-end t))) :from-end t)))
...@@ -266,13 +266,13 @@ upgrade_tags () { ...@@ -266,13 +266,13 @@ upgrade_tags () {
# 2.26 (2012-10-30) was used by Quicklisp # 2.26 (2012-10-30) was used by Quicklisp
# 2.27 (2013-02-01) is the first ASDF 3 pre-release # 2.27 (2013-02-01) is the first ASDF 3 pre-release
# 2.32 (2013-03-05) is the first really stable ASDF 3 pre-release # 2.32 (2013-03-05) is the first really stable ASDF 3 pre-release
# # 3.0.1 (2013-05-16) is the first stable ASDF 3 release
echo REQUIRE 1.85 1.97 1.369 echo REQUIRE 1.85 1.97 1.369
# git tag -l '2.0??' # git tag -l '2.0??'
# git tag -l '2.??' # git tag -l '2.??'
echo 2.000 2.008 2.011 2.014.6 2.019 2.20 2.22 2.26 echo 2.000 2.008 2.011 2.014.6 2.019 2.20 2.22 2.26
echo 2.27 echo 2.27 2.32
git tag -l '2.3[2-9]' git tag -l '3.0.[1-9]'
} }
upgrade_methods () { upgrade_methods () {
if [ -n "$ASDF_UPGRADE_TEST_METHODS" ] ; then if [ -n "$ASDF_UPGRADE_TEST_METHODS" ] ; then
......
...@@ -559,7 +559,7 @@ is bound, write a message and exit on an error. If ...@@ -559,7 +559,7 @@ is bound, write a message and exit on an error. If
`(apply (asym :register-system-definition) ',name :pathname ,*test-directory* `(apply (asym :register-system-definition) ',name :pathname ,*test-directory*
:source-file nil ',rest)) :source-file nil ',rest))
(defun in-plan-p (plan x) (member x plan :key (asym :action-path) :test 'equal)) (defun in-plan-p (plan x) (member x (acall :plan-actions plan) :key (asym :action-path) :test 'equal))
(defmacro test-load-systems (&rest x) (defmacro test-load-systems (&rest x)
`(do-test-load-systems ',x)) `(do-test-load-systems ',x))
......
(load-system "test-asdf/test-module-depend") (load-system "test-asdf/test-module-depend")
(defparameter *plan* (traverse 'load-op "test-asdf/test-module-depend")) (defparameter *plan* (make-plan () 'load-op "test-asdf/test-module-depend"))
(DBG :foo *plan* (DBG :foo *plan*
(component-depends-on 'compile-op '("test-asdf/test-module-depend" "quux" "file3mod" "file3")) (component-depends-on 'compile-op '("test-asdf/test-module-depend" "quux" "file3mod" "file3"))
(asdf::component-if-feature (find-component "test-asdf/test-module-depend" '("quux" "file3mod" "file3")))) (asdf::component-if-feature (find-component "test-asdf/test-module-depend" '("quux" "file3mod" "file3"))))
......
;;; -*- Lisp -*- ;;; -*- Lisp -*-
;;;--------------------------------------------------------------------------- ;;;---------------------------------------------------------------------------
;;; Here's what we are trying to test. Let us say we have a system X that ;;; Here's what we are trying to test. Let us say we have a system X that
;;; contains a file, "file1" and a module, "quux" that depends on file 1. In ;;; contains a file, "file1" and a module, "quux" that depends on file 1. In
...@@ -76,7 +74,7 @@ ...@@ -76,7 +74,7 @@
#|(format t "~%Operation plan is:~%")(pprint plan)(terpri)|# #|(format t "~%Operation plan is:~%")(pprint plan)(terpri)|#
(when (loop :for (o . c) :in plan :thereis (and (eq c file3c) (typep o 'asdf:compile-op))) (when (loop :for (o . c) :in plan :thereis (and (eq c file3c) (typep o 'asdf:compile-op)))
(error "Excessive operations on file3-only system. Bad propagation of dependencies.")) (error "Excessive operations on file3-only system. Bad propagation of dependencies."))
(asdf:operate 'asdf:load-op 'test-module-excessive-depend) (operate 'load-op 'test-module-excessive-depend)
(assert (>= (file-write-date file1) before)) (assert (>= (file-write-date file1) before))
(assert (>= (file-write-date file2) before)) (assert (>= (file-write-date file2) before))
(unless (= (file-write-date file3) (unless (= (file-write-date file3)
......
;;; -*- Mode: common-lisp; Syntax: Common-Lisp; -*- ;;; -*- Mode: common-lisp; Syntax: Common-Lisp; -*-
(in-package :common-lisp-user)
(defpackage #:test-nested-components.system
(:use #:common-lisp #:asdf))
(in-package :test-nested-components.system)
(defsystem test-nested-components-a (defsystem test-nested-components-a
:components :components
((:module "nested-components" ((:module "nested-components"
...@@ -27,9 +20,3 @@ ...@@ -27,9 +20,3 @@
:pathname "preflight-checks" :pathname "preflight-checks"
:components :components
((:file "preflight"))) ((:file "preflight")))
#|
newer traverse always fails
older traverse fails when db-agraph-preflight is evaluated, ok
when loaded or compiled
|#
...@@ -2,66 +2,24 @@ ...@@ -2,66 +2,24 @@
;;; check that added nesting via modules doesn't confuse ASDF ;;; check that added nesting via modules doesn't confuse ASDF
(setf *central-registry* nil)
(load "test-nested-components-1.asd")
(progn (print
(setf asdf:*central-registry* nil) (list
(load "test-nested-components-1.asd") :a
(print (traverse 'compile-op 'test-nested-components-a)
(list (traverse 'compile-op 'test-nested-components-b)
:a :x
(asdf::traverse (make-instance 'asdf:compile-op) (traverse 'compile-op 'db-agraph-preflight)
(asdf:find-system 'test-nested-components-a)) (traverse 'compile-op 'db-agraph-preflight-2)))
(asdf::traverse (make-instance 'asdf:compile-op)
(asdf:find-system 'test-nested-components-b))
:x
(asdf::traverse (make-instance 'asdf:compile-op)
(asdf:find-system 'db-agraph-preflight))
(asdf::traverse (make-instance 'asdf:compile-op)
(asdf:find-system 'db-agraph-preflight-2))
))
#|
(asdf:oos 'asdf:compile-op 'test-nested-components-a)
(asdf:oos 'asdf:compile-op 'test-nested-components-b)
(print
(list
(asdf::traverse (make-instance 'asdf:load-op)
(asdf:find-system 'test-nested-components-a))
(asdf::traverse (make-instance 'asdf:load-op)
(asdf:find-system 'test-nested-components-b))))
|#
)
#| #|
(((#<ASDF:COMPILE-OP NIL {11DEB619}> (oos 'compile-op 'test-nested-components-a)
. #<ASDF:CL-SOURCE-FILE "preflight" {11B7B951}>) (oos 'compile-op 'test-nested-components-b)
(#<ASDF:COMPILE-OP NIL {11DEB619}>
. #<ASDF:MODULE "preflight-checks" {11B799A9}>)
(#<ASDF:COMPILE-OP NIL {11DEB619}>
. #<ASDF:SYSTEM "test-nested-components-a" {11AEDD59}>)
(#<ASDF:LOAD-OP NIL {11D04FE9}>
. #<ASDF:CL-SOURCE-FILE "preflight" {11B7B951}>)
(#<ASDF:LOAD-OP NIL {11D04FE9}>
. #<ASDF:MODULE "preflight-checks" {11B799A9}>)
(#<ASDF:LOAD-OP NIL {11D04FE9}>
. #<ASDF:SYSTEM "test-nested-components-a" {11AEDD59}>))
((#<ASDF:COMPILE-OP NIL {11E4D9B1}> (print
. #<ASDF:CL-SOURCE-FILE "preflight" {11C94B89}>) (list
(#<ASDF:COMPILE-OP NIL {11E4D9B1}> (traverse 'load-op 'test-nested-components-a)
. #<ASDF:SYSTEM "test-nested-components-b" {11C92819}>) (traverse 'load-op 'test-nested-components-b)))
(#<ASDF:LOAD-OP NIL {11E4A911}>
. #<ASDF:CL-SOURCE-FILE "preflight" {11C94B89}>)
(#<ASDF:LOAD-OP NIL {11E4A911}>
. #<ASDF:SYSTEM "test-nested-components-b" {11C92819}>)))
|# |#
...@@ -570,7 +570,7 @@ possibly in a different process. Otherwise just run the BODY." ...@@ -570,7 +570,7 @@ possibly in a different process. Otherwise just run the BODY."
(defun* (compile-file*) (input-file &rest keys (defun* (compile-file*) (input-file &rest keys
&key compile-check output-file warnings-file &key compile-check output-file warnings-file
#+clisp lib-file #+(or ecl mkcl) object-file #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl
&allow-other-keys) &allow-other-keys)
"This function provides a portable wrapper around COMPILE-FILE. "This function provides a portable wrapper around COMPILE-FILE.
It ensures that the OUTPUT-FILE value is only returned and It ensures that the OUTPUT-FILE value is only returned and
...@@ -611,12 +611,23 @@ it will filter them appropriately." ...@@ -611,12 +611,23 @@ it will filter them appropriately."
(or object-file (or object-file
(compile-file-pathname output-file :fasl-p nil))) (compile-file-pathname output-file :fasl-p nil)))
(tmp-file (tmpize-pathname output-file)) (tmp-file (tmpize-pathname output-file))
#+sbcl
(cfasl-file (etypecase emit-cfasl
(null nil)
((eql t) (make-pathname :type "cfasl" :defaults output-file))
(string (parse-namestring emit-cfasl))
(pathname emit-cfasl)))
#+sbcl
(tmp-cfasl (when cfasl-file (make-pathname :type "cfasl" :defaults tmp-file)))
#+clisp #+clisp
(tmp-lib (make-pathname :type "lib" :defaults tmp-file))) (tmp-lib (make-pathname :type "lib" :defaults tmp-file)))
(multiple-value-bind (output-truename warnings-p failure-p) (multiple-value-bind (output-truename warnings-p failure-p)
(with-saved-deferred-warnings (warnings-file) (with-saved-deferred-warnings (warnings-file)
(with-muffled-compiler-conditions () (with-muffled-compiler-conditions ()
(or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file keywords) (or #-(or ecl mkcl)
(apply 'compile-file input-file :output-file tmp-file
#+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords)
#-sbcl keywords)
#+ecl (apply 'compile-file input-file :output-file #+ecl (apply 'compile-file input-file :output-file
(if object-file (if object-file
(list* object-file :system-p t keywords) (list* object-file :system-p t keywords)
...@@ -641,11 +652,14 @@ it will filter them appropriately." ...@@ -641,11 +652,14 @@ it will filter them appropriately."
(delete-file-if-exists output-file) (delete-file-if-exists output-file)
(when output-truename (when output-truename
#+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file)) #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file))
#+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file))
(rename-file-overwriting-target output-truename output-file) (rename-file-overwriting-target output-truename output-file)
(setf output-truename (truename output-file))) (setf output-truename (truename output-file)))
#+clisp (delete-file-if-exists tmp-lib)) #+clisp (delete-file-if-exists tmp-lib))
(t ;; error or failed check (t ;; error or failed check
(delete-file-if-exists output-truename) (delete-file-if-exists output-truename)
#+clisp (delete-file-if-exists tmp-lib)
#+sbcl (delete-file-if-exists tmp-cfasl)
(setf output-truename nil))) (setf output-truename nil)))
(values output-truename warnings-p failure-p)))) (values output-truename warnings-p failure-p))))
......
...@@ -94,7 +94,7 @@ hopefully, if done consistently, that won't affect program behavior too much.") ...@@ -94,7 +94,7 @@ hopefully, if done consistently, that won't affect program behavior too much.")
and implementation-defined external-format's") and implementation-defined external-format's")
(defun encoding-external-format (encoding) (defun encoding-external-format (encoding)
(funcall *encoding-external-format-hook* encoding))) (funcall *encoding-external-format-hook* (or encoding *default-encoding*))))
;;; Safe syntax ;;; Safe syntax
......
...@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ...@@ -52,7 +52,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO
;; "3.4.5.67" would be a development version in the official upstream of 3.4.5. ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5.
;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5 ;; "3.4.5.0.8" would be your eighth local modification of official release 3.4.5
;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67 ;; "3.4.5.67.8" would be your eighth local modification of development version 3.4.5.67
(asdf-version "3.0.1.3") (asdf-version "3.0.1.7")