- cmucl-cvs - mailman3.common-lisp.net

[git] CMU Common Lisp annotated tag snapshot-2014-08 created. snapshot-2014-08
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The annotated tag, snapshot-2014-08 has been created at 3d3259cd2f0d437388b69ecf50feedc73246096d (tag) tagging 98319835e05b93ea62e17f6bc3da4144f96ac2c5 (commit) replaces snapshot-2014-06 tagged by Raymond Toy on Thu Aug 7 21:30:43 2014 -0700 - Log ----------------------------------------------------------------- Snapshot 2014-08 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.13 (Darwin) iEYEABECAAYFAlPkUnoACgkQJ5IjUmgZO7JzgwCgt4mPwW0Qx0sI3qtsXPOttVrq klAAnAxpd/KCElQ6ggJf82ZSVlhRBOJm =4mEx -----END PGP SIGNATURE----- Raymond Toy (101): Change max gen to GC to 3; add inteface to set it. Fix declaration of min-av-mem-age in generation-stats. Import fdlibm trig functions; as is, from netlib. Update to use unions, using the style of e_rem_pio2.c. Add declarations for the fdlibm trig functions. Compile fdlibm trig functions on linux and darwin. Darwin doesn't need fdlibm because the system library is good. Add implmeentation of sincos in C. Comment out all of the trig functions in lisp in favor of calling out Oops. Didn't comment out quite enough. Add sincos for x86 linux. For consistency with sincos, we need to include the fdlibm trig ppc doesn't have sincos in libm so use our own version. Oops. Need k_sin and k_cos for sincos. Add rest of fdblim trig functios so that sincos is consistent with sin Put back the deftransforms for sin/cos/tan so we can call out directly Add fdlibm trig for sparc. Add fdlibm trig routines for NetBSD. Fix stupid typo that causes sin to converted to asin. All platforms have sincos now, so remove the deftransform for cis that Add declaration to ignore unused variable. Rename sin/cos/tan/sincos so we don't collide with libm. Add include guard. Some cleanup of the trig code. Comment code, add license header, and conform to cmucl C style. Ignore emacs ~ files and fasls. Finally remove the Lisp implementation of the trig functions that are Add expm1 to match log1p. All platforms seem to have expm1 as well. Remove the mathcalls section. It's not used and some of it (log1p) is Update to 3.1.3. Fix ticket ##104: Source location for define-condition Add README to document the naming convention of boot files. Add info for cross-compile scripts. CLEAR-OUTPUT should call STREAM-CLEAR-OUTPUT for Gray streams. Implement CLEAR-OUTPUT for FD-STREAM's. Add tests for CLEAR-OUTPUT. Import log1p from fdlibm, as is. Import expm1 from fdlibm, as is. Modify to use unions and change name to include fdlibm prefix. Compile s_log1p and s_expm1. Use fdlibm versions of log1p and expm1. Import pow (ieee754_pow) from fdlibm, as is. Update to use unions. Compile e_pow as a part of lisp. Use __ieee754_pow instead of pow. Compile the new fdlibm routines. Compile the new fdlibm routines. Compile the new fdlibm routines. Add fdlibm routines e_exp and e_log, as is. Update to use unions. Compile fdlibm routines e_exp.c and e_log.c Use the fdlibm routines for exp and log. Import inverse trig functions from fdlibm, as is. Use unions to access the high and low parts of a double. Compile the asin, acos, and atan routines. Use the fdlibm asin, acos, and atan routines. Initialize t to get rid of a compiler warning from clang. Initialize k to get rid of a compiler warning from clang. Remove the sccsid variable. Add some braces to silence the warning from clang about dangling else Add some braces to silence the warning from clang about dangling else Import hyperbolic functions from fdlibm, as is. Use unions to access the high and low parts of a double and update Add parens around && expressions to silence a clang warning. Compile the fdlibm hyperbolic functions. Use fdlibm hyperbolic functions instead of libm. Import inverse hyperbolic functions from fdlibm, as is. Fix up the inverse hyperbolics. Compile the fdlibm inverse hyperbolics. Use the fdlibm inverse hyperbolic functions. Import atan2 function from fdlibm, as is. Fix up atan2 by using unions. Use fdlibm_atan instead of atan. Compile the fdlibm atan2. Use fdlibm atan2. Use correct flags to generate sse2 instructions in the C code and Clean up config files. Remove the list of fdlibm files from here because they're in Forgot to remove e_rem_pio2 and friends. -march=pentium4 imples -msse2, so drop the latter. Update netbsd config. Untested. Forgot to remove e_rem_pio2 and friends from a few more Config files Remove CC_REM_PIO2 and add new CPPFLAGS to force compiling with sse2 add -mtune=generic to get optimization for the most common x86 Update from commit logs. Initialize c to get rid of a compiler warning on Linux with gcc 4.4.1. Add parens around operands of | to silence a compiler warning with gcc Initilize hi and lo to get rid of a compiler warning from gcc 4.4.1 on Fix aliasing issue noted by gcc 4.4.1 on Linux. Fix aliasing issue noted by gcc 4.4.1 on Linux. Oops. Fix typo by removing the extraneous comma that was left in. Fix bug in DOUBLE-FLOAT-BITS vop. Remove -mtune=generic from Config.x86_common. Update LDFLAGS for NetBSD so motifd will build and run correctly on Oops. x86-assem needs -m32. Document that the argument/result timespec starts at 0, not 1. Simplify SSE2-FLOATING-POINT-MODES vop by removing an unneeded Addresses ticket #84 for Linux. Fix typo and add -m32 to LDFLAGS. Remove commented-out LDFLAGS. Regenerated and updated. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-12-a-43-gca2bf8c
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via ca2bf8c29d22aaf44caf31f1d7b6ba77ab418be5 (commit) from 894af6c4aaa3b83f3c13d2e59735c33f79abdc20 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit ca2bf8c29d22aaf44caf31f1d7b6ba77ab418be5 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Dec 24 12:57:45 2013 -0800 Fix ticket:90 src/code/irrat.lisp: src/code/irrat-dd.lisp: * Remove the special case that made atanh continuous with quadrant III for x < -1 on the branch cut. tests/trig.lisp: * Update tests for atanh * Rename rel-or-abs-error to close-to. diff --git a/src/code/irrat-dd.lisp b/src/code/irrat-dd.lisp index 024ec93..dbe9159 100644 --- a/src/code/irrat-dd.lisp +++ b/src/code/irrat-dd.lisp @@ -1663,63 +1663,59 @@ Z may be any number, but the result is always a complex." (defun dd-complex-atanh (z) _N"Compute atanh z = (log(1+z) - log(1-z))/2" (declare (number z)) - (cond ((and (realp z) (< z -1)) - ;; ATANH is continuous with quadrant III in this case. - (dd-complex-atanh (complex z -0d0))) - (t - (let* ( ;; Constants - (theta (/ (sqrt most-positive-double-float) 4.0w0)) - (rho (/ 4.0w0 (sqrt most-positive-double-float))) - (half-pi dd-pi/2) - (rp (float (realpart z) 1.0w0)) - (beta (float-sign rp 1.0w0)) - (x (* beta rp)) - (y (* beta (- (float (imagpart z) 1.0w0)))) - (eta 0.0w0) - (nu 0.0w0)) - ;; Shouldn't need this declare. - (declare (double-double-float x y)) - (locally - (declare (optimize (speed 3) - (inhibit-warnings 3))) - (cond ((or (> x theta) - (> (abs y) theta)) - ;; To avoid overflow... - (setf nu (float-sign y half-pi)) - ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), - ;; which can cause overflow. Arrange this computation so - ;; that it won't overflow. - (setf eta (let* ((x-bigger (> x (abs y))) - (r (if x-bigger (/ y x) (/ x y))) - (d (+ 1.0d0 (* r r)))) - (if x-bigger - (/ (/ x) d) - (/ (/ r y) d))))) - ((= x 1.0w0) - ;; Should this be changed so that if y is zero, eta is set - ;; to +infinity instead of approx 176? In any case - ;; tanh(176) is 1.0d0 within working precision. - (let ((t1 (+ 4w0 (square y))) - (t2 (+ (abs y) rho))) - (setf eta (dd-%log (/ (sqrt (sqrt t1)) - (sqrt t2)))) - (setf nu (* 0.5d0 - (float-sign y - (+ half-pi (dd-%atan (* 0.5d0 t2)))))))) - (t - (let ((t1 (+ (abs y) rho))) - ;; Normal case using log1p(x) = log(1 + x) - (setf eta (* 0.25d0 - (dd-%log1p (/ (* 4.0d0 x) - (+ (square (- 1.0d0 x)) - (square t1)))))) - (setf nu (* 0.5d0 - (dd-%atan2 (* 2.0d0 y) - (- (* (- 1.0d0 x) - (+ 1.0d0 x)) - (square t1)))))))) - (complex (* beta eta) - (- (* beta nu)))))))) + (let* ( ;; Constants + (theta (/ (sqrt most-positive-double-float) 4.0w0)) + (rho (/ 4.0w0 (sqrt most-positive-double-float))) + (half-pi dd-pi/2) + (rp (float (realpart z) 1.0w0)) + (beta (float-sign rp 1.0w0)) + (x (* beta rp)) + (y (* beta (- (float (imagpart z) 1.0w0)))) + (eta 0.0w0) + (nu 0.0w0)) + ;; Shouldn't need this declare. + (declare (double-double-float x y)) + (locally + (declare (optimize (speed 3) + (inhibit-warnings 3))) + (cond ((or (> x theta) + (> (abs y) theta)) + ;; To avoid overflow... + (setf nu (float-sign y half-pi)) + ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), + ;; which can cause overflow. Arrange this computation so + ;; that it won't overflow. + (setf eta (let* ((x-bigger (> x (abs y))) + (r (if x-bigger (/ y x) (/ x y))) + (d (+ 1.0d0 (* r r)))) + (if x-bigger + (/ (/ x) d) + (/ (/ r y) d))))) + ((= x 1.0w0) + ;; Should this be changed so that if y is zero, eta is set + ;; to +infinity instead of approx 176? In any case + ;; tanh(176) is 1.0d0 within working precision. + (let ((t1 (+ 4w0 (square y))) + (t2 (+ (abs y) rho))) + (setf eta (dd-%log (/ (sqrt (sqrt t1)) + (sqrt t2)))) + (setf nu (* 0.5d0 + (float-sign y + (+ half-pi (dd-%atan (* 0.5d0 t2)))))))) + (t + (let ((t1 (+ (abs y) rho))) + ;; Normal case using log1p(x) = log(1 + x) + (setf eta (* 0.25d0 + (dd-%log1p (/ (* 4.0d0 x) + (+ (square (- 1.0d0 x)) + (square t1)))))) + (setf nu (* 0.5d0 + (dd-%atan2 (* 2.0d0 y) + (- (* (- 1.0d0 x) + (+ 1.0d0 x)) + (square t1)))))))) + (complex (* beta eta) + (- (* beta nu)))))) (defun dd-complex-tanh (z) _N"Compute tanh z = sinh z / cosh z" diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index ff23a5e..e4e744d 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -1741,62 +1741,59 @@ Z may be any number, but the result is always a complex." (when (typep z '(or double-double-float (complex double-double-float))) (return-from complex-atanh (dd-complex-atanh z))) - (if (and (realp z) (< z -1)) - ;; atanh is continuous in quadrant III in this case. - (complex-atanh (complex z -0f0)) - (let* ( ;; Constants - (theta (/ (sqrt most-positive-double-float) 4.0d0)) - (rho (/ 4.0d0 (sqrt most-positive-double-float))) - (half-pi (/ pi 2.0d0)) - (rp (float (realpart z) 1.0d0)) - (beta (float-sign rp 1.0d0)) - (x (* beta rp)) - (y (* beta (- (float (imagpart z) 1.0d0)))) - (eta 0.0d0) - (nu 0.0d0)) - ;; Shouldn't need this declare. - (declare (double-float x y)) - (locally - (declare (optimize (speed 3))) - (cond ((or (> x theta) - (> (abs y) theta)) - ;; To avoid overflow... - (setf nu (float-sign y half-pi)) - ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), - ;; which can cause overflow. Arrange this computation so - ;; that it won't overflow. - (setf eta (let* ((x-bigger (> x (abs y))) - (r (if x-bigger (/ y x) (/ x y))) - (d (+ 1.0d0 (* r r)))) - (if x-bigger - (/ (/ x) d) - (/ (/ r y) d))))) - ((= x 1.0d0) - ;; Should this be changed so that if y is zero, eta is set - ;; to +infinity instead of approx 176? In any case - ;; tanh(176) is 1.0d0 within working precision. - (let ((t1 (+ 4d0 (square y))) - (t2 (+ (abs y) rho))) - (setf eta (log (/ (sqrt (sqrt t1)) - (sqrt t2)))) - (setf nu (* 0.5d0 - (float-sign y - (+ half-pi (atan (* 0.5d0 t2)))))))) - (t - (let ((t1 (+ (abs y) rho))) - ;; Normal case using log1p(x) = log(1 + x) - (setf eta (* 0.25d0 - (%log1p (/ (* 4.0d0 x) - (+ (square (- 1.0d0 x)) - (square t1)))))) - (setf nu (* 0.5d0 - (atan (* 2.0d0 y) - (- (* (- 1.0d0 x) - (+ 1.0d0 x)) - (square t1)))))))) - (coerce-to-complex-type (* beta eta) - (- (* beta nu)) - z))))) + (let* ( ;; Constants + (theta (/ (sqrt most-positive-double-float) 4.0d0)) + (rho (/ 4.0d0 (sqrt most-positive-double-float))) + (half-pi (/ pi 2.0d0)) + (rp (float (realpart z) 1.0d0)) + (beta (float-sign rp 1.0d0)) + (x (* beta rp)) + (y (* beta (- (float (imagpart z) 1.0d0)))) + (eta 0.0d0) + (nu 0.0d0)) + ;; Shouldn't need this declare. + (declare (double-float x y)) + (locally + (declare (optimize (speed 3))) + (cond ((or (> x theta) + (> (abs y) theta)) + ;; To avoid overflow... + (setf nu (float-sign y half-pi)) + ;; eta is real part of 1/(x + iy). This is x/(x^2+y^2), + ;; which can cause overflow. Arrange this computation so + ;; that it won't overflow. + (setf eta (let* ((x-bigger (> x (abs y))) + (r (if x-bigger (/ y x) (/ x y))) + (d (+ 1.0d0 (* r r)))) + (if x-bigger + (/ (/ x) d) + (/ (/ r y) d))))) + ((= x 1.0d0) + ;; Should this be changed so that if y is zero, eta is set + ;; to +infinity instead of approx 176? In any case + ;; tanh(176) is 1.0d0 within working precision. + (let ((t1 (+ 4d0 (square y))) + (t2 (+ (abs y) rho))) + (setf eta (log (/ (sqrt (sqrt t1)) + (sqrt t2)))) + (setf nu (* 0.5d0 + (float-sign y + (+ half-pi (atan (* 0.5d0 t2)))))))) + (t + (let ((t1 (+ (abs y) rho))) + ;; Normal case using log1p(x) = log(1 + x) + (setf eta (* 0.25d0 + (%log1p (/ (* 4.0d0 x) + (+ (square (- 1.0d0 x)) + (square t1)))))) + (setf nu (* 0.5d0 + (atan (* 2.0d0 y) + (- (* (- 1.0d0 x) + (+ 1.0d0 x)) + (square t1)))))))) + (coerce-to-complex-type (* beta eta) + (- (* beta nu)) + z)))) (defun complex-tanh (z) "Compute tanh z = sinh z / cosh z" diff --git a/tests/trig.lisp b/tests/trig.lisp index 05437e5..df76231 100644 --- a/tests/trig.lisp +++ b/tests/trig.lisp @@ -215,18 +215,20 @@ (assert-eql nil (sincos-test (scale-float 1d0 1023) 1000))) -;; Compute the relative error between actual and expected if expected -;; is not zero. Otherwise, return absolute error between actual and -;; expected. If the error is less than the threshold, return T. -;; Otherwise return the actual (relative or absolute) error. -(defun rel-or-abs-error (actual expected &optional (threshold double-float-epsilon)) +(defun close-to (actual expected &optional (threshold double-float-epsilon)) + "Determine if Actual is close to Expected. If Expected is not zero, + then close-to returns t if |Actual - Expected|/|Expected| <= + Threshold. If Expected is 0, then close-to returns T if |Actual - + Expected| <= threshold. In either of these conditions does not + hold, then a list of the actual error (relative or absolute), the + actual value and the expected value is returned." (let ((err (if (zerop expected) (abs (- actual expected)) (/ (abs (- actual expected)) (abs expected))))) (if (<= err threshold) t - err))) + (list err actual expected)))) ;;; Tests for double-double-floats @@ -239,11 +241,11 @@ (define-test dd-sin.no-reduction "Test sin for small args without reduction" (:tag :sin :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin .5w0) 4.794255386042030002732879352155713880818033679406006751886166131w-1 1w-32)) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin -0.5w0) -4.794255386042030002732879352155713880818033679406006751886166131w-1 1w-32))) @@ -251,7 +253,7 @@ (define-test dd-sin.pi/2 "Test for arg near pi/2" (:tag :sin :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (/ kernel:dd-pi 2)) 1w0 1w-50))) @@ -265,27 +267,27 @@ "Test for sin with arg reduction" (:tag :sin :double-double) ;; Test for argument reduction with n mod 4 = 0 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (* 7/4 kernel:dd-pi)) -7.07106781186547524400844362104849691328261037289050238659653433w-1 0w0)) ;; Test for argument reduction with n mod 4 = 1 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (* 9/4 kernel:dd-pi)) 7.07106781186547524400844362104858161816423215627023442400880643w-1 0w0)) ;; Test for argument reduction with n mod 4 = 2 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (* 11/4 kernel:dd-pi)) 7.071067811865475244008443621048998682901731241858306822215522497w-1 8.716w-33)) ;; Test for argument reduction with n mod 4 = 3 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (* 13/4 kernel:dd-pi)) -7.071067811865475244008443621048777109664479707052746581685893187w-1 8.716w-33)) ;; Test for argument reduction, big value - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (sin (scale-float 1w0 120)) 3.778201093607520226555484700569229919605866976512306642257987199w-1 8.156w-33))) @@ -299,11 +301,11 @@ (define-test dd-cos.no-reduction "Test cos for small args without reduction" (:tag :cos :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos .5w0) 8.775825618903727161162815826038296519916451971097440529976108683w-1 0w0)) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos -0.5w0) 8.775825618903727161162815826038296519916451971097440529976108683w-1 0w0))) @@ -311,7 +313,7 @@ (define-test dd-cos.pi/2 "Test for arg near pi/2" (:tag :cos :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (/ kernel:dd-pi 2)) -1.497384904859169777320797133937725094986669701841027904483071358w-33 0w0))) @@ -320,27 +322,27 @@ "Test for cos with arg reduction" (:tag :cos :double-double) ;; Test for argument reduction with n mod 4 = 0 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (* 7/4 kernel:dd-pi)) 7.07106781186547524400844362104849691328261037289050238659653433w-1 0w0)) ;; Test for argument reduction with n mod 4 = 1 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (* 9/4 kernel:dd-pi)) 7.07106781186547524400844362104858161816423215627023442400880643w-1 3.487w-32)) ;; Test for argument reduction with n mod 4 = 2 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (* 11/4 kernel:dd-pi)) -7.071067811865475244008443621048998682901731241858306822215522497w-1 1.482w-31)) ;; Test for argument reduction with n mod 4 = 3 - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (* 13/4 kernel:dd-pi)) -7.071067811865475244008443621048777109664479707052746581685893187w-1 7.845w-32)) ;; Test for argument reduction, big value - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (cos (scale-float 1w0 120)) -9.258790228548378673038617641074149467308332099286564602360493726w-1 0w0))) @@ -354,11 +356,11 @@ (define-test dd-tan.no-reduction "Test tan for small args without reduction" (:tag :tan :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan .5w0) 5.463024898437905132551794657802853832975517201797912461640913859w-1 0w0)) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan -0.5w0) -5.463024898437905132551794657802853832975517201797912461640913859w-1 0w0))) @@ -366,7 +368,7 @@ (define-test dd-tan.pi/2 "Test for arg near pi/2" (:tag :tan :double-double) - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan (/ kernel:dd-pi 2)) -6.67830961000672557834948096545679895621313886078988606234681001w32 0w0))) @@ -375,17 +377,17 @@ "Test for tan with arg reduction" (:tag :tan :double-double) ;; Test for argument reduction with n even - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan (* 7/4 kernel:dd-pi)) -1.000000000000000000000000000000001844257310064121018312678894979w0 3.422w-49)) ;; Test for argument reduction with n odd - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan (* 9/4 kernel:dd-pi)) 1.000000000000000000000000000000025802415787810837455445433037983w0 0w0)) ;; Test for argument reduction, big value - (assert-eq t (rel-or-abs-error + (assert-eq t (close-to (tan (scale-float 1w0 120)) -4.080663888418042385451434945255951177650840227682488471558860153w-1 1.888w-33))) @@ -753,7 +755,8 @@ ;; Thus, atanh(-2) is continuous with Quadrant II, NOT continuous with ;; Quadrant III! ;; -;; What do we do? +;; The formula, however, is clear. We will use the formula and ignore +;; the text in the CLHS. (defun atanh-def (z) (r*z 1/2 (- (log (1+z z)) @@ -761,19 +764,19 @@ (define-test branch-cut.atanh (:tag :atanh :branch-cuts) - ;; Test for x < -1, which is continuous with Quadrant III. Use the - ;; the value at #c(-2d0 -1d-20) as the reference. + ;; Test for x < -1, which is continuous with Quadrant II. Use the + ;; the value at #c(-2d0 +1d-20) as the reference. (multiple-value-bind (tr ti) - (get-signs (atanh-def #c(-2d0 -1d-20))) + (get-signs (atanh-def #c(-2d0 1d-20))) (assert-true (check-signs #'atanh -2d0 tr ti)) (assert-true (check-signs #'atanh -2w0 tr ti)) - (assert-true (check-signs #'atanh #c(-2d0 -0d0) tr ti)) - (assert-true (check-signs #'atanh #c(-2w0 -0w0) tr ti))) + (assert-true (check-signs #'atanh #c(-2d0 +0d0) tr ti)) + (assert-true (check-signs #'atanh #c(-2w0 +0w0) tr ti))) ;; Test the other side of the branch cut for x < -1. (multiple-value-bind (tr ti) - (get-signs (atanh-def #c(-2d0 +1d-20))) - (assert-true (check-signs #'atanh #c(-2d0 0d0) tr ti)) - (assert-true (check-signs #'atanh #c(-2w0 0w0) tr ti))) + (get-signs (atanh-def #c(-2d0 -1d-20))) + (assert-true (check-signs #'atanh #c(-2d0 -0d0) tr ti)) + (assert-true (check-signs #'atanh #c(-2w0 -0w0) tr ti))) ;; Test for x > 1, which is continuous with Quadrant I, using the ;; value at #c(+2d0 1d-10) as the reference ----------------------------------------------------------------------- Summary of changes: src/code/irrat-dd.lisp | 110 +++++++++++++++++++++++------------------------- src/code/irrat.lisp | 109 +++++++++++++++++++++++------------------------ tests/trig.lisp | 77 +++++++++++++++++---------------- 3 files changed, 146 insertions(+), 150 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-03-a-11-g81f3fa2
by rtoy＠alpha-cl-net.common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 81f3fa22008571b8a1c214e20086ab175ce26573 (commit) from c647866d61b29968c39d1722ad61d02061acfe7a (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 81f3fa22008571b8a1c214e20086ab175ce26573 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Apr 13 20:16:32 2013 -0700 Update from logs. diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index 06f5173..74e024e 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -58,6 +58,7 @@ New in this release: caused by the release string not having a patch version. * FILE-POSITION no longer returns incorrect values. See ticket #79. + * Fix error in (format t "~ve" 21 5d-324). (See ticket #80). * Trac Tickets: ----------------------------------------------------------------------- Summary of changes: src/general-info/release-20e.txt | 1 + 1 file changed, 1 insertion(+) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. begin-x87-removal-19-g87aed56
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 87aed560fb118c488a3ea2824ed3fbddf9930cd2 (commit) via 28455f5114df02062ea6deddb8fb47a9de8c063f (commit) from 7fe70d3a8856058f4bb4b10602d7eadf18444791 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 87aed560fb118c488a3ea2824ed3fbddf9930cd2 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Apr 27 18:18:15 2014 -0700 Remove more sse2 stuff. * Exit if the chip doesn't support sse2. * Treat any mode setting as being the same as sse2 and return the sse2 core name. diff --git a/src/lisp/x86-arch.c b/src/lisp/x86-arch.c index c694cea..841e2cc 100644 --- a/src/lisp/x86-arch.c +++ b/src/lisp/x86-arch.c @@ -108,17 +108,16 @@ arch_init(fpu_mode_t mode) have_sse2 = arch_support_sse2() && os_support_sse2(); + if (!have_sse2) { + fprintf(stderr, "CMUCL requires a SSE2 support; exiting\n"); + abort(); + } + switch (mode) { case AUTO: - if (have_sse2) { - return "lisp-sse2.core"; - } else { - return "lisp-x87.core"; - } - break; case X87: - return "lisp-x87.core"; - break; + fprintf(stderr, "fpu mode AUTO or X87 is not longer supported.\n"); + /* Fall through and return the sse2 core */ case SSE2: return "lisp-sse2.core"; break; commit 28455f5114df02062ea6deddb8fb47a9de8c063f Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sun Apr 27 18:16:45 2014 -0700 Rmove more x87 fpu mode stuff. * Darwin-os.c: * Linux-os.c: * FEATURE_SSE2 is always true so remove the #ifdef's * Don't merge the x87 fpu mode bits with the sse2 ones; we only want sse2. * restore_fpu doesn't need to restore the x87 fpu mode bits. diff --git a/src/lisp/Darwin-os.c b/src/lisp/Darwin-os.c index 693cbf6..5e8ddf9 100644 --- a/src/lisp/Darwin-os.c +++ b/src/lisp/Darwin-os.c @@ -22,6 +22,8 @@ #include <errno.h> #include <dlfcn.h> #include <string.h> +#include <assert.h> + #include "os.h" #include "arch.h" #include "globals.h" @@ -332,7 +334,6 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int index) return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_stmm6; case 7: return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_stmm7; -#ifdef FEATURE_SSE2 case 8: return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_xmm0; case 9: @@ -348,43 +349,21 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int index) case 14: return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_xmm6; case 15: - return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_stmm7; -#endif + return (unsigned char *) &scp->uc_mcontext->__fs.__fpu_stmm7; + default: + return NULL; } - return NULL; } unsigned int os_sigcontext_fpu_modes(ucontext_t *scp) { unsigned int modes; - unsigned int mxcsr; - unsigned short cw, sw; - - /* - * Get the status word and the control word. - */ - memcpy(&cw, &scp->uc_mcontext->__fs.__fpu_fcw, sizeof(cw)); - memcpy(&sw, &scp->uc_mcontext->__fs.__fpu_fsw, sizeof(sw)); - /* - * Put the cw in the upper bits and the status word in the lower 6 - * bits, ignoring everything except the exception masks and the - * exception flags. - */ - modes = ((cw & 0x3f) << 7) | (sw & 0x3f); + assert(fpu_mode == SSE2); - DPRINTF(0, (stderr, "FPU modes = %08x (sw = %4x, cw = %4x)\n", - modes, (unsigned int) sw, (unsigned int) cw)); - - if (fpu_mode == SSE2) { - mxcsr = scp->uc_mcontext->__fs.__fpu_mxcsr; - DPRINTF(0, (stderr, "SSE2 modes = %08x\n", mxcsr)); - - modes |= mxcsr; - } - - DPRINTF(0, (stderr, "modes pre mask = %08x\n", modes)); + modes = scp->uc_mcontext->__fs.__fpu_mxcsr; + DPRINTF(0, (stderr, "SSE2 modes = %08x\n", modes)); /* Convert exception mask to exception enable */ modes ^= (0x3f << 7); @@ -395,16 +374,11 @@ os_sigcontext_fpu_modes(ucontext_t *scp) void restore_fpu(ucontext_t *scp) { - unsigned short cw; unsigned int mxcsr; - memcpy(&cw, &scp->uc_mcontext->__fs.__fpu_fcw, sizeof(cw)); - DPRINTF(0, (stderr, "restore_fpu: FPU cw = 0x%x\n", cw)); - __asm__ __volatile__ ("fclex"); - __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)); - mxcsr = scp->uc_mcontext->__fs.__fpu_mxcsr; DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr)); + __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr)); } #endif diff --git a/src/lisp/Linux-os.c b/src/lisp/Linux-os.c index 7f7a4d7..2da60fb 100644 --- a/src/lisp/Linux-os.c +++ b/src/lisp/Linux-os.c @@ -217,16 +217,13 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int offset) if (fpregs) { if (offset < 8) { reg = (unsigned char *) &fpregs->_st[offset]; - } -#ifdef FEATURE_SSE2 - else { + } else if (offset < 16) { struct _fpstate *fpstate; fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; if (fpstate->magic != 0xffff) { reg = (unsigned char *) &fpstate->_xmm[offset - 8]; } } -#endif } return reg; } @@ -234,39 +231,27 @@ os_sigcontext_fpu_reg(ucontext_t *scp, int offset) unsigned int os_sigcontext_fpu_modes(ucontext_t *scp) { - unsigned int modes; - unsigned short cw, sw; - - if (scp->uc_mcontext.fpregs == NULL) { - cw = 0; - sw = 0x3f; - } else { - cw = scp->uc_mcontext.fpregs->cw & 0xffff; - sw = scp->uc_mcontext.fpregs->sw & 0xffff; - } + unsigned int modes = 0; - modes = ((cw & 0x3f) << 7) | (sw & 0x3f); - -#ifdef FEATURE_SSE2 /* - * Add in the SSE2 part, if we're running the sse2 core. + * Get the SSE2 modes. FIXME: What should we do if the magic + * value indicates that the mxcsr value is not in the context? */ - if (fpu_mode == SSE2) { - struct _fpstate *fpstate; - unsigned long mxcsr; - - fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; - if (fpstate->magic == 0xffff) { - mxcsr = 0; - } else { - mxcsr = fpstate->mxcsr; - DPRINTF(0, (stderr, "SSE2 modes = %08lx\n", mxcsr)); - } + struct _fpstate *fpstate; + unsigned long mxcsr; - modes |= mxcsr; + fpstate = (struct _fpstate*) scp->uc_mcontext.fpregs; + if (fpstate->magic == 0xffff) { + mxcsr = 0; + } else { + mxcsr = fpstate->mxcsr; + DPRINTF(0, (stderr, "SSE2 modes = %08lx\n", mxcsr)); } -#endif + modes |= mxcsr; + + + /* Convert exception mask to exception enable */ modes ^= (0x3f << 7); return modes; } @@ -543,25 +528,19 @@ void restore_fpu(ucontext_t *context) { if (context->uc_mcontext.fpregs) { - short cw = context->uc_mcontext.fpregs->cw; - DPRINTF(0, (stderr, "restore_fpu: cw = %08x\n", cw)); - __asm__ __volatile__ ("fldcw %0" : : "m" (*&cw)); -#ifdef FEATURE_SSE2 - if (fpu_mode == SSE2) { - struct _fpstate *fpstate; - unsigned int mxcsr; + struct _fpstate *fpstate; + unsigned int mxcsr; - fpstate = (struct _fpstate*) context->uc_mcontext.fpregs; - if (fpstate->magic != 0xffff) { - mxcsr = fpstate->mxcsr; - DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr)); - __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr)); - } + fpstate = (struct _fpstate*) context->uc_mcontext.fpregs; + if (fpstate->magic != 0xffff) { + mxcsr = fpstate->mxcsr; + DPRINTF(0, (stderr, "restore_fpu: mxcsr (raw) = %04x\n", mxcsr)); + __asm__ __volatile__ ("ldmxcsr %0" :: "m" (*&mxcsr)); } -#endif } } + #ifdef i386 boolean os_support_sse2() ----------------------------------------------------------------------- Summary of changes: src/lisp/Darwin-os.c | 44 +++++++------------------------- src/lisp/Linux-os.c | 69 ++++++++++++++++++-------------------------------- src/lisp/x86-arch.c | 15 +++++------ 3 files changed, 40 insertions(+), 88 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-11-4-gf3c9558
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via f3c9558971d5b0b6aa2b34feb22f44396c90ae33 (commit) from 8674b2d2b73bf7d7402d323f8179d1312b0843f6 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit f3c9558971d5b0b6aa2b34feb22f44396c90ae33 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Nov 21 22:08:30 2013 -0800 Fix compiler warning about using %lx with an int. diff --git a/src/lisp/gencgc.c b/src/lisp/gencgc.c index f06b23b..a9c3e96 100644 --- a/src/lisp/gencgc.c +++ b/src/lisp/gencgc.c @@ -1194,7 +1194,7 @@ gc_alloc_new_region(int nbytes, int unboxed, struct alloc_region *alloc_region) for (p = (int *) alloc_region->start_addr; p < (int *) alloc_region->end_addr; p++) if (*p != 0) - fprintf(stderr, "** new region not zero @ %lx: %lx\n", + fprintf(stderr, "** new region not zero @ %lx: %x\n", (unsigned long) p, *p); } ----------------------------------------------------------------------- Summary of changes: src/lisp/gencgc.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-48-g99afcf7
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 99afcf7a7ef0b0451cfcb477f8ad241aad930086 (commit) from 76183742d841486c85cfa1a26f811373c40208f2 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 99afcf7a7ef0b0451cfcb477f8ad241aad930086 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 00:18:34 2014 -0700 Compile the new fdlibm routines. diff --git a/src/lisp/Config.x86_linux b/src/lisp/Config.x86_linux index 7b8caf9..9c4cbc1 100644 --- a/src/lisp/Config.x86_linux +++ b/src/lisp/Config.x86_linux @@ -16,7 +16,7 @@ OS_LINK_FLAGS += -Wl,-z,noexecstack EXEC_FINAL_OBJ = exec-final.o -OS_SRC += k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c +OS_SRC += k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c s_log1p.c s_expm1.c e_pow.c k_sin.o : k_sin.c $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< @@ -34,3 +34,12 @@ s_tan.o : s_tan.c sincos.o : sincos.c $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< + +s_log1p.o : s_log1p.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +s_exmp1.o : s_expm1.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< + +e_pow.o : e_pow.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< + ----------------------------------------------------------------------- Summary of changes: src/lisp/Config.x86_linux | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. begin-x87-removal-20-g5abd66f
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 5abd66f6073fabd08af8e0155f74cd338a28d280 (commit) from 87aed560fb118c488a3ea2824ed3fbddf9930cd2 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 5abd66f6073fabd08af8e0155f74cd338a28d280 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Apr 28 21:33:38 2014 -0700 Don't merge the x87 FP modes with the SSE2 modes when getting and setting the floating-point mode bits. diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index d97d04e..7f27ffd 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -64,62 +64,17 @@ (defun (setf floating-point-modes) (new) (setf (floating-point-modes) new)) ) -#+(and x86 (not sse2)) -(progn - (defun floating-point-modes () - (let ((x87-modes (vm::x87-floating-point-modes))) - ;; Massage the bits from x87-floating-point-modes into the order - ;; that the rest of the system wants them to be. (Must match - ;; format in the SSE2 mxcsr register.) - (logior (ash (logand #x3f x87-modes) 7) ; control - (logand #x3f (ash x87-modes -16))))) - (defun (setf floating-point-modes) (new) - (let* ((rc (ldb float-rounding-mode new)) - (x87-modes - (logior (ash (logand #x3f new) 16) - (ash rc 10) - (logand #x3f (ash new -7)) - ;; Set precision control to be 53-bit, always. - ;; (The compiler takes care of handling - ;; single-float precision, and we don't support - ;; long-floats.) - (ash 2 8)))) - (setf (x87-floating-point-modes) x87-modes))) - ) - #+sse2 (progn (defun floating-point-modes () - ;; Combine the modes from the FPU and SSE2 units. Since the sse - ;; mode contains all of the common information we want, we massage - ;; the x87-modes to match, and then OR the x87 and sse2 modes - ;; together. Note: We ignore the rounding control bits from the - ;; FPU and only use the SSE2 rounding control bits. - (let* ((x87-modes (vm::x87-floating-point-modes)) - (sse-modes (vm::sse2-floating-point-modes)) - (final-mode (logior sse-modes - (ash (logand #x3f x87-modes) 7) ; control - (logand #x3f (ash x87-modes -16))))) - - final-mode)) + ;; Get just the SSE2 mode bits. + (vm::sse2-floating-point-modes)) (defun (setf floating-point-modes) (new-mode) (declare (type (unsigned-byte 24) new-mode)) - ;; Set the floating point modes for both X87 and SSE2. This - ;; include the rounding control bits. - (let* ((rc (ldb float-rounding-mode new-mode)) - (x87-modes - (logior (ash (logand #x3f new-mode) 16) - (ash rc 10) - (logand #x3f (ash new-mode -7)) - ;; Set precision control to be 64-bit, always. We - ;; don't use the x87 registers with sse2, so this - ;; is ok and would be the correct setting if we - ;; ever support long-floats. - (ash 3 8)))) - (setf (vm::sse2-floating-point-modes) new-mode) - (setf (vm::x87-floating-point-modes) x87-modes)) + ;; Set the floating point modes for SSE2. + (setf (vm::sse2-floating-point-modes) new-mode) new-mode) -) + ) ;;; SET-FLOATING-POINT-MODES -- Public ;;; ----------------------------------------------------------------------- Summary of changes: src/code/float-trap.lisp | 55 +++++----------------------------------------- 1 file changed, 5 insertions(+), 50 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2013-05-10-g9f62dcd
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 9f62dcdfab39ef03cf01969b6ea88b962073d09f (commit) from b3b0725a647a3c59440cd6ffa8baa33f616c4479 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 9f62dcdfab39ef03cf01969b6ea88b962073d09f Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu May 23 19:36:45 2013 -0700 Update to ASDF 3.0.1. diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp index d3c63b2..88949ea 100644 --- a/src/contrib/asdf/asdf.lisp +++ b/src/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.32: Another System Definition Facility. +;;; This is ASDF 3.0.1: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -71,10 +71,10 @@ (existing-version-number (and existing-version (read-from-string existing-major-minor))) (away (format nil "~A-~A" :asdf existing-version))) (when (and existing-version (< existing-version-number - (or #+abcl 2.25 #+cmu 2.018 2.27))) + (or #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27))) (rename-package :asdf away) (when *load-verbose* - (format t "; Renamed old ~A package away to ~A~%" :asdf away)))))) + (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))) ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. @@ -1014,12 +1014,15 @@ or when loading the package is optional." #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export ;; magic helper to define debugging functions: - #:asdf-debug #:load-asdf-debug-utility #:*asdf-debug-utility* + #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* #:undefine-function #:undefine-functions #:defun* #:defgeneric* #:with-upgradability ;; (un)defining functions #:if-let ;; basic flow control - #:while-collecting #:appendf #:length=n-p #:remove-plist-keys #:remove-plist-key ;; lists and plists + #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists + #:remove-plist-keys #:remove-plist-key ;; plists #:emptyp ;; sequences - #:strcat #:first-char #:last-char #:split-string ;; strings + #:+non-base-chars-exist-p+ ;; characters + #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings + #:first-char #:last-char #:split-string #:string-prefix-p #:string-enclosed-p #:string-suffix-p #:find-class* ;; CLOS #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps @@ -1092,22 +1095,22 @@ or when loading the package is optional." ;;; Magic debugging help. See contrib/debug.lisp (with-upgradability () - (defvar *asdf-debug-utility* + (defvar *uiop-debug-utility* '(or (ignore-errors - (symbol-call :asdf :system-relative-pathname :asdf "contrib/debug.lisp")) - (merge-pathnames "cl/asdf/contrib/debug.lisp" (user-homedir-pathname))) + (symbol-call :asdf :system-relative-pathname :uiop "contrib/debug.lisp")) + (symbol-call :uiop/pathname :subpathname (user-homedir-pathname) "cl/asdf/uiop/contrib/debug.lisp")) "form that evaluates to the pathname to your favorite debugging utilities") - (defmacro asdf-debug (&rest keys) + (defmacro uiop-debug (&rest keys) `(eval-when (:compile-toplevel :load-toplevel :execute) - (load-asdf-debug-utility ,@keys))) + (load-uiop-debug-utility ,@keys))) - (defun load-asdf-debug-utility (&key package utility-file) + (defun load-uiop-debug-utility (&key package utility-file) (let* ((*package* (if package (find-package package) *package*)) (keyword (read-from-string (format nil ":DBG-~:@(~A~)" (package-name *package*))))) (unless (member keyword *features*) - (let* ((utility-file (or utility-file *asdf-debug-utility*)) + (let* ((utility-file (or utility-file *uiop-debug-utility*)) (file (ignore-errors (probe-file (eval utility-file))))) (if file (load file) (error "Failed to locate debug utility file: ~S" utility-file))))))) @@ -1156,7 +1159,11 @@ Returns two values: $A B C$ and $1 2 3$." :for i :downfrom n :do (cond ((zerop i) (return (null l))) - ((not (consp l)) (return nil)))))) + ((not (consp l)) (return nil))))) + + (defun ensure-list (x) + (if (listp x) x (list x)))) + ;;; remove a key from a plist, i.e. for keyword argument cleanup (with-upgradability () @@ -1180,10 +1187,42 @@ Returns two values: $A B C$ and $1 2 3$." (or (null x) (and (vectorp x) (zerop (length x)))))) +;;; Characters +(with-upgradability () + (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) + (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) + + ;;; Strings (with-upgradability () + (defun base-string-p (string) + (declare (ignorable string)) + (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string)))) + + (defun strings-common-element-type (strings) + (declare (ignorable strings)) + #-non-base-chars-exist-p 'character + #+non-base-chars-exist-p + (if (loop :for s :in strings :always (or (null s) (typep s 'base-char) (base-string-p s))) + 'base-char 'character)) + + (defun reduce/strcat (strings &key key start end) + "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE. +NIL is interpreted as an empty string. A character is interpreted as a string of length one." + (when (or start end) (setf strings (subseq strings start end))) + (when key (setf strings (mapcar key strings))) + (loop :with output = (make-string (loop :for s :in strings :sum (if (characterp s) 1 (length s))) + :element-type (strings-common-element-type strings)) + :with pos = 0 + :for input :in strings + :do (etypecase input + (null) + (character (setf (char output pos) input) (incf pos)) + (string (replace output input :start1 pos) (incf pos (length input)))) + :finally (return output))) + (defun strcat (&rest strings) - (apply 'concatenate 'string strings)) + (reduce/strcat strings)) (defun first-char (s) (and (stringp s) (plusp (length s)) (char s 0))) @@ -1204,12 +1243,11 @@ starting the separation from the end, e.g. when called with arguments (loop :for start = (if (and max (>= words (1- max))) (done) - (position-if #'separatorp string :end end :from-end t)) :do - (when (null start) - (done)) - (push (subseq string (1+ start) end) list) - (incf words) - (setf end start)))))) + (position-if #'separatorp string :end end :from-end t)) + :do (when (null start) (done)) + (push (subseq string (1+ start) end) list) + (incf words) + (setf end start)))))) (defun string-prefix-p (prefix string) "Does STRING begin with PREFIX?" @@ -1419,7 +1457,8 @@ a simple vector of length 2, arguments to find-symbol* with result as above, or a string describing the format-control of a simple-condition." (etypecase x (symbol (typep condition x)) - ((simple-vector 2) (typep condition (find-symbol* (svref x 0) (svref x 1) nil))) + ((simple-vector 2) + (ignore-errors (typep condition (find-symbol* (svref x 0) (svref x 1) nil)))) (function (funcall x condition)) (string (and (typep condition 'simple-condition) ;; On SBCL, it's always set and the check triggers a warning @@ -2427,8 +2466,14 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." (t (translate-pathname path absolute-source destination)))) - (defvar *output-translation-function* 'identity)) ; Hook for output translations + (defvar *output-translation-function* 'identity + "Hook for output translations. +This function needs to be idempotent, so that actions can work +whether their inputs were translated or not, +which they will be if we are composing operations. e.g. if some +create-lisp-op creates a lisp file from some higher-level input, +you need to still be able to use compile-op on that lisp file.")) ;;;; ------------------------------------------------------------------------- ;;;; Portability layer around Common Lisp filesystem access @@ -2441,7 +2486,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." ;; Native namestrings #:native-namestring #:parse-native-namestring ;; Probing the filesystem - #:truename* #:safe-file-write-date #:probe-file* + #:truename* #:safe-file-write-date #:probe-file* #:directory-exists-p #:file-exists-p #:directory* #:filter-logical-directory-results #:directory-files #:subdirectories #:collect-sub*directories ;; Resolving symlinks somewhat @@ -2456,7 +2501,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." ;; Simple filesystem operations #:ensure-all-directories-exist #:rename-file-overwriting-target - #:delete-file-if-exists)) + #:delete-file-if-exists #:delete-empty-directory #:delete-directory-tree)) (in-package :uiop/filesystem) ;;; Native namestrings, as seen by the operating system calls rather than Lisp @@ -2564,10 +2609,18 @@ or the original (parsed) pathname if it is false (the default)." (probe resolve))))) (file-error () nil))))))) + (defun directory-exists-p (x) + (let ((p (probe-file* x :truename t))) + (and (directory-pathname-p p) p))) + + (defun file-exists-p (x) + (let ((p (probe-file* x :truename t))) + (and (file-pathname-p p) p))) + (defun directory* (pathname-spec &rest keys &key &allow-other-keys) (apply 'directory pathname-spec (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) - #+clozure '(:follow-links nil) + #+(or clozure digitool) '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) #+(or cmu scl) '(:follow-links nil :truenamep nil) #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) @@ -2602,7 +2655,11 @@ or the original (parsed) pathname if it is false (the default)." (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) (error "Invalid file pattern ~S for logical directory ~S" pattern directory)) (setf pattern (make-pathname-logical pattern (pathname-host dir)))) - (let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir))))) + (let* ((pat (merge-pathnames* pattern dir)) + (entries (append (ignore-errors (directory* pat)) + #+clisp + (when (equal :wild (pathname-type pattern)) + (ignore-errors (directory* (make-pathname :type nil :defaults pat))))))) (filter-logical-directory-results directory entries #'(lambda (f) @@ -2649,10 +2706,10 @@ or the original (parsed) pathname if it is false (the default)." :directory (append prefix (make-pathname-component-logical (last dir))))))))))) (defun collect-sub*directories (directory collectp recursep collector) - (when (funcall collectp directory) - (funcall collector directory)) + (when (call-function collectp directory) + (call-function collector directory)) (dolist (subdir (subdirectories directory)) - (when (funcall recursep subdir) + (when (call-function recursep subdir) (collect-sub*directories subdir collectp recursep collector))))) ;;; Resolving symlinks somewhat @@ -2790,7 +2847,8 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (check ensure-physical (physical-pathname-p p) "Could not translate to a physical pathname") (check want-relative (relative-pathname-p p) "Expected a relative pathname") (check want-absolute (absolute-pathname-p p) "Expected an absolute pathname") - (transform ensure-absolute (not (absolute-pathname-p p)) (merge-pathnames* p defaults)) + (transform ensure-absolute (not (absolute-pathname-p p)) + (ensure-absolute-pathname p defaults (list #'report-error :ensure-absolute "~@?"))) (check ensure-absolute (absolute-pathname-p p) "Could not make into an absolute pathname even after merging with ~S" defaults) (check ensure-subpath (absolute-pathname-p defaults) @@ -2850,8 +2908,10 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (loop :for namestring :in (split-string string :separator (string (inter-directory-separator))) :collect (apply 'parse-native-namestring namestring constraints))) - (defun getenv-pathname (x &rest constraints &key on-error &allow-other-keys) + (defun getenv-pathname (x &rest constraints &key ensure-directory want-directory on-error &allow-other-keys) + ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory (apply 'parse-native-namestring (getenvp x) + :ensure-directory (or ensure-directory want-directory) :on-error (or on-error `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) constraints)) @@ -2907,8 +2967,85 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." #+clozure :if-exists #+clozure :rename-and-delete)) (defun delete-file-if-exists (x) - (when x (handler-case (delete-file x) (file-error () nil))))) - + (when x (handler-case (delete-file x) (file-error () nil)))) + + (defun delete-empty-directory (directory-pathname) + "Delete an empty directory" + #+(or abcl digitool gcl) (delete-file directory-pathname) + #+allegro (excl:delete-directory directory-pathname) + #+clisp (ext:delete-directory directory-pathname) + #+clozure (ccl::delete-empty-directory directory-pathname) + #+(or cmu scl) (multiple-value-bind (ok errno) + (unix:unix-rmdir (native-namestring directory-pathname)) + (unless ok + #+cmu (error "Error number ~A when trying to delete directory ~A" + errno directory-pathname) + #+scl (error "~@<Error deleting ~S: ~A~@:>" + directory-pathname (unix:get-unix-error-msg errno)))) + #+cormanlisp (win32:delete-directory directory-pathname) + #+ecl (si:rmdir directory-pathname) + #+lispworks (lw:delete-directory directory-pathname) + #+mkcl (mkcl:rmdir directory-pathname) + #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) + `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later + `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) + #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl) + (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera xcl + + (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) + "Delete a directory including all its recursive contents, aka rm -rf. + +To reduce the risk of infortunate mistakes, DIRECTORY-PATHNAME must be +a physical non-wildcard directory pathname (not namestring). + +If the directory does not exist, the IF-DOES-NOT-EXIST argument specifies what happens: +if it is :ERROR (the default), an error is signaled, whereas if it is :IGNORE, nothing is done. + +Furthermore, before any deletion is attempted, the DIRECTORY-PATHNAME must pass +the validation function designated (as per ENSURE-FUNCTION) by the VALIDATE keyword argument +which in practice is thus compulsory, and validates by returning a non-NIL result. +If you're suicidal or extremely confident, just use :VALIDATE T." + (check-type if-does-not-exist (member :error :ignore)) + (cond + ((not (and (pathnamep directory-pathname) (directory-pathname-p directory-pathname) + (physical-pathname-p directory-pathname) (not (wild-pathname-p directory-pathname)))) + (error "~S was asked to delete ~S but it is not a physical non-wildcard directory pathname" + 'delete-filesystem-tree directory-pathname)) + ((not validatep) + (error "~S was asked to delete ~S but was not provided a validation predicate" + 'delete-filesystem-tree directory-pathname)) + ((not (call-function validate directory-pathname)) + (error "~S was asked to delete ~S but it is not valid ~@[according to ~S~]" + 'delete-filesystem-tree directory-pathname validate)) + ((not (directory-exists-p directory-pathname)) + (ecase if-does-not-exist + (:error + (error "~S was asked to delete ~S but the directory does not exist" + 'delete-filesystem-tree directory-pathname)) + (:ignore nil))) + #-(or allegro cmu clozure sbcl scl) + ((os-unix-p) ;; On Unix, don't recursively walk the directory and delete everything in Lisp, + ;; except on implementations where we can prevent DIRECTORY from following symlinks; + ;; instead spawn a standard external program to do the dirty work. + (symbol-call :uiop :run-program `("rm" "-rf" ,(native-namestring directory-pathname)))) + (t + ;; On supported implementation, call supported system functions + #+allegro (symbol-call :excl.osi :delete-directory-and-files + directory-pathname :if-does-not-exist if-does-not-exist) + #+clozure (ccl:delete-directory directory-pathname) + #+genera (error "~S not implemented on ~S" 'delete-directory-tree (implementation-type)) + #+sbcl #.(if-let (dd (find-symbol* :delete-directory :sb-ext nil)) + `(,dd directory-pathname :recursive t) ;; requires SBCL 1.0.44 or later + '(error "~S requires SBCL 1.0.44 or later" 'delete-directory-tree)) + ;; Outside Unix or on CMUCL and SCL that can avoid following symlinks, + ;; do things the hard way. + #-(or allegro clozure genera sbcl) + (let ((sub*directories + (while-collecting (c) + (collect-sub*directories directory-pathname t t #'c)))) + (dolist (d (nreverse sub*directories)) + (map () 'delete-file (directory-files d)) + (delete-empty-directory d))))))) ;;;; --------------------------------------------------------------------------- ;;;; Utilities related to streams @@ -2924,9 +3061,9 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." #:*default-encoding* #:*utf-8-external-format* #:with-safe-io-syntax #:call-with-safe-io-syntax #:safe-read-from-string #:with-output #:output-string #:with-input - #:with-input-file #:call-with-input-file + #:with-input-file #:call-with-input-file #:with-output-file #:call-with-output-file #:finish-outputs #:format! #:safe-format! - #:copy-stream-to-stream #:concatenate-files + #:copy-stream-to-stream #:concatenate-files #:copy-file #:slurp-stream-string #:slurp-stream-lines #:slurp-stream-line #:slurp-stream-forms #:slurp-stream-form #:read-file-string #:read-file-lines #:read-file-forms #:read-file-form #:safe-read-file-form @@ -3098,10 +3235,33 @@ Other keys are accepted but discarded." :if-does-not-exist if-does-not-exist) (funcall thunk s))) - (defmacro with-input-file ((var pathname &rest keys &key element-type external-format) &body body) - (declare (ignore element-type external-format)) - `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys))) + (defmacro with-input-file ((var pathname &rest keys + &key element-type external-format if-does-not-exist) + &body body) + (declare (ignore element-type external-format if-does-not-exist)) + `(call-with-input-file ,pathname #'(lambda (,var) ,@body) ,@keys)) + + (defun call-with-output-file (pathname thunk + &key + (element-type *default-stream-element-type*) + (external-format *utf-8-external-format*) + (if-exists :error) + (if-does-not-exist :create)) + "Open FILE for input with given recognizes options, call THUNK with the resulting stream. +Other keys are accepted but discarded." + #+gcl2.6 (declare (ignore external-format)) + (with-open-file (s pathname :direction :output + :element-type element-type + #-gcl2.6 :external-format #-gcl2.6 external-format + :if-exists if-exists + :if-does-not-exist if-does-not-exist) + (funcall thunk s))) + (defmacro with-output-file ((var pathname &rest keys + &key element-type external-format if-exists if-does-not-exist) + &body body) + (declare (ignore element-type external-format if-exists if-does-not-exist)) + `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys))) ;;; Ensure output buffers are flushed (with-upgradability () @@ -3158,6 +3318,10 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." :direction :input :if-does-not-exist :error) (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) + (defun copy-file (input output) + ;; Not available on LW personal edition or LW 6.0 on Mac: (lispworks:copy-file i f) + (concatenate-files (list input) output)) + (defun slurp-stream-string (input &key (element-type 'character)) "Read the contents of the INPUT stream as a string" (with-open-stream (input input) @@ -3308,7 +3472,7 @@ If a string, repeatedly read and evaluate from it, returning the last values." #+gcl2.6 (declare (ignorable external-format)) (check-type direction (member :output :io)) (loop - :with prefix = (or prefix (format nil "~Atmp" (native-namestring (temporary-directory)))) + :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory)) :for counter :from (random (ash 1 32)) :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do ;; TODO: on Unix, do something about umask @@ -3410,6 +3574,9 @@ For the latter case, we ought pick random suffix and atomically open it." (defvar *image-restore-hook* nil "Functions to call (in reverse order) when the image is restored") + (defvar *image-restored-p* nil + "Has the image been restored? A boolean, or :in-progress while restoring, :in-regress while dumping") + (defvar *image-prelude* nil "a form to evaluate, or string containing forms to read and evaluate when the image is restarted, but before the entry point is called.") @@ -3602,10 +3769,17 @@ if we are not called from a directly executable image." ((:lisp-interaction *lisp-interaction*) *lisp-interaction*) ((:restore-hook *image-restore-hook*) *image-restore-hook*) ((:prelude *image-prelude*) *image-prelude*) - ((:entry-point *image-entry-point*) *image-entry-point*)) + ((:entry-point *image-entry-point*) *image-entry-point*) + (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) + (when *image-restored-p* + (if if-already-restored + (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t)) + (return-from restore-image))) (with-fatal-condition-handler () + (setf *image-restored-p* :in-progress) (call-image-restore-hook) (standard-eval-thunk *image-prelude*) + (setf *image-restored-p* t) (let ((results (multiple-value-list (if *image-entry-point* (call-function *image-entry-point*) @@ -3618,14 +3792,16 @@ if we are not called from a directly executable image." ;;; Dumping an image (with-upgradability () - #-(or ecl mkcl) (defun dump-image (filename &key output-name executable ((:postlude *image-postlude*) *image-postlude*) - ((:dump-hook *image-dump-hook*) *image-dump-hook*)) + ((:dump-hook *image-dump-hook*) *image-dump-hook*) + #+clozure prepend-symbols #+clozure (purify t)) (declare (ignorable filename output-name executable)) (setf *image-dumped-p* (if executable :executable t)) + (setf *image-restored-p* :in-regress) (standard-eval-thunk *image-postlude*) (call-image-dump-hook) + (setf *image-restored-p* nil) #-(or clisp clozure cmu lispworks sbcl scl) (when executable (error "Dumping an executable is not supported on this implementation! Aborting.")) @@ -3644,8 +3820,16 @@ if we are not called from a directly executable image." ;; :parse-options nil ;--- requires a non-standard patch to clisp. :norc t :script nil :init-function #'restore-image))) #+clozure - (ccl:save-application filename :prepend-kernel t - :toplevel-function (when executable #'restore-image)) + (flet ((dump (prepend-kernel) + (ccl:save-application filename :prepend-kernel prepend-kernel :purify purify + :toplevel-function (when executable #'restore-image)))) + ;;(setf ccl::*application* (make-instance 'ccl::lisp-development-system)) + (if prepend-symbols + (with-temporary-file (:prefix "ccl-symbols-" :direction :output :pathname path) + (require 'elf) + (funcall (fdefinition 'ccl::write-elf-symbols-to-file) path) + (dump path)) + (dump t))) #+(or cmu scl) (progn (ext:gc :full t) @@ -3669,33 +3853,36 @@ if we are not called from a directly executable image." :executable t ;--- always include the runtime that goes with the core (when executable (list :toplevel #'restore-image :save-runtime-options t)))) ;--- only save runtime-options for standalone executables #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) - (die 98 "Can't dump ~S: asdf doesn't support image dumping with ~A.~%" - filename (nth-value 1 (implementation-type)))) + (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%" + 'dump-image filename (nth-value 1 (implementation-type)))) - - #+ecl (defun create-image (destination object-files - &key kind output-name prologue-code epilogue-code - (prelude () preludep) (entry-point () entry-point-p) build-args) + &key kind output-name prologue-code epilogue-code + (prelude () preludep) (postlude () postludep) + (entry-point () entry-point-p) build-args) + (declare (ignorable destination object-files kind output-name prologue-code epilogue-code + prelude preludep postlude postludep entry-point entry-point-p build-args)) ;; Is it meaningful to run these in the current environment? ;; only if we also track the object files that constitute the "current" image, ;; and otherwise simulate dump-image, including quitting at the end. - ;; (standard-eval-thunk *image-postlude*) (call-image-dump-hook) - (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program)) - (apply 'c::builder - kind (pathname destination) - :lisp-files object-files - :init-name (c::compute-init-name (or output-name destination) :kind kind) - :prologue-code prologue-code - :epilogue-code - `(progn - ,epilogue-code - ,@(when (eq kind :program) - `((setf *image-dumped-p* :executable) - (restore-image ;; default behavior would be (si::top-level) - ,@(when preludep `(:prelude ',prelude)) - ,@(when entry-point-p `(:entry-point ',entry-point)))))) - build-args))) + #-ecl (error "~S not implemented for your implementation (yet)" 'create-image) + #+ecl + (progn + (check-type kind (member :binary :dll :lib :static-library :program :object :fasl :program)) + (apply 'c::builder + kind (pathname destination) + :lisp-files object-files + :init-name (c::compute-init-name (or output-name destination) :kind kind) + :prologue-code prologue-code + :epilogue-code + `(progn + ,epilogue-code + ,@(when (eq kind :program) + `((setf *image-dumped-p* :executable) + (restore-image ;; default behavior would be (si::top-level) + ,@(when preludep `(:prelude ',prelude)) + ,@(when entry-point-p `(:entry-point ',entry-point)))))) + build-args)))) ;;; Some universal image restore hooks @@ -3842,7 +4029,7 @@ by /bin/sh in POSIX" ;;;; Slurping a stream, typically the output of another program (with-upgradability () (defgeneric slurp-input-stream (processor input-stream &key &allow-other-keys)) - + #-(or gcl2.6 genera) (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys) (funcall function input-stream)) @@ -3881,6 +4068,27 @@ by /bin/sh in POSIX" (declare (ignorable x)) (slurp-stream-form stream :at at)) + (defmethod slurp-input-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) + (declare (ignorable x)) + (apply 'slurp-input-stream *standard-output* stream keys)) + + (defmethod slurp-input-stream ((pathname pathname) input + &key + (element-type *default-stream-element-type*) + (external-format *utf-8-external-format*) + (if-exists :rename-and-delete) + (if-does-not-exist :create) + buffer-size + linewise) + (with-output-file (output pathname + :element-type element-type + :external-format external-format + :if-exists if-exists + :if-does-not-exist if-does-not-exist) + (copy-stream-to-stream + input output + :element-type element-type :buffer-size buffer-size :linewise linewise))) + (defmethod slurp-input-stream (x stream &key linewise prefix (element-type 'character) buffer-size &allow-other-keys) @@ -3918,16 +4126,24 @@ by /bin/sh in POSIX" &allow-other-keys) "Run program specified by COMMAND, either a list of strings specifying a program and list of arguments, -or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows); -have its output processed by the OUTPUT processor function -as per SLURP-INPUT-STREAM, -or merely output to the inherited standard output if it's NIL. +or a string specifying a shell command (/bin/sh on Unix, CMD.EXE on Windows). + Always call a shell (rather than directly execute the command) if FORCE-SHELL is specified. -Issue an error if the process wasn't successful unless IGNORE-ERROR-STATUS -is specified. -Return the exit status code of the process that was called. + +Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0), +unless IGNORE-ERROR-STATUS is specified. + +If OUTPUT is either NIL or :INTERACTIVE, then +return the exit status code of the process that was called. +if it was NIL, the output is discarded; +if it was :INTERACTIVE, the output and the input are inherited from the current process. + +Otherwise, the output will be processed by SLURP-INPUT-STREAM, +using OUTPUT as the first argument, and return whatever it returns, +e.g. using :OUTPUT :STRING will have it return the entire output stream as a string. Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor." + ;; TODO: specially recognize :output pathname ? (declare (ignorable ignore-error-status element-type external-format)) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) (error "RUN-PROGRAM not implemented for this Lisp") @@ -3969,7 +4185,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process #+os-unix (coerce (cons (first command) command) 'vector) #+os-windows command :input interactive :output (or (and pipe :stream) interactive) :wait wait - #+os-windows :show-window #+os-windows (and pipe :hide)) + #+os-windows :show-window #+os-windows (and (or (null output) pipe) :hide)) #+clisp (flet ((run (f &rest args) (apply f `(,@args :input ,(when interactive :terminal) :wait ,wait :output @@ -3995,9 +4211,9 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process ;; note: :external-format requires a recent SBCL #+sbcl '(:search t :external-format external-format))))) (process - #+(or allegro lispworks) (if pipe (third process*) (first process*)) + #+allegro (if pipe (third process*) (first process*)) #+ecl (third process*) - #-(or allegro lispworks ecl) (first process*)) + #-(or allegro ecl) (first process*)) (stream (when pipe #+(or allegro lispworks ecl) (first process*) @@ -4020,7 +4236,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process #+clozure (nth-value 1 (ccl:external-process-status process)) #+(or cmu scl) (ext:process-exit-code process) #+ecl (nth-value 1 (ext:external-process-status process)) - #+lispworks (if pipe (system:pid-exit-status process :wait t) process) + #+lispworks (if pipe (system:pipe-exit-status process :wait t) process) #+sbcl (sb-ext:process-exit-code process)) (check-result (exit-code process) #+clisp @@ -4059,7 +4275,9 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process (declare (ignorable interactive)) #+(or abcl xcl) (ext:run-shell-command command) #+allegro - (excl:run-shell-command command :input interactive :output interactive :wait t) + (excl:run-shell-command + command :input interactive :output interactive :wait t + #+os-windows :show-window #+os-windows (unless (or interactive (eq output t)) :hide)) #+(or clisp clozure cmu (and lispworks os-unix) sbcl scl) (process-result (run-program command :pipe nil :interactive interactive) nil) #+ecl (ext:system command) @@ -4067,7 +4285,7 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process #+gcl (lisp:system command) #+(and lispworks os-windows) (system:call-system-showing-output - command :show-cmd interactive :prefix "" :output-stream nil) + command :show-cmd (or interactive (eq output t)) :prefix "" :output-stream nil) #+mcl (ccl::with-cstrs ((%command command)) (_system %command)) #+mkcl (nth-value 2 (mkcl:run-program #+windows command #+windows () @@ -4109,13 +4327,15 @@ Use ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT process #:compile-condition #:compile-file-error #:compile-warned-error #:compile-failed-error #:compile-warned-warning #:compile-failed-warning #:check-lisp-compile-results #:check-lisp-compile-warnings - #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* + #:*uninteresting-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* + ;; Types + #+sbcl #:sb-grovel-unknown-constant-condition ;; Functions & Macros #:get-optimization-settings #:proclaim-optimization-settings #:call-with-muffled-compiler-conditions #:with-muffled-compiler-conditions #:call-with-muffled-loader-conditions #:with-muffled-loader-conditions #:reify-simple-sexp #:unreify-simple-sexp - #:reify-deferred-warnings #:reify-undefined-warning #:unreify-deferred-warnings + #:reify-deferred-warnings #:unreify-deferred-warnings #:reset-deferred-warnings #:save-deferred-warnings #:check-deferred-warnings #:with-saved-deferred-warnings #:warnings-file-p #:warnings-file-type #:*warnings-file-type* #:enable-deferred-warnings-check #:disable-deferred-warnings-check @@ -4146,15 +4366,16 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (defvar *previous-optimization-settings* nil) (defun get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" + #-(or clisp clozure cmu ecl sbcl scl) + (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type)) + #+clozure (ccl:declaration-information 'optimize nil) + #+(or clisp cmu ecl sbcl scl) (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) - #-(or clisp clozure cmu ecl sbcl scl) - (warn "xcvb-driver::get-optimization-settings does not support your implementation. Please help me fix that.") #.`(loop :for x :in settings - ,@(or #+clozure '(:for v :in '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*)) - #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*)) + ,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*)) #+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity))) :for y = (or #+clisp (gethash x system::*optimize*) - #+(or clozure ecl) (symbol-value v) + #+(or ecl) (symbol-value v) #+(or cmu scl) (funcall f c::*default-cookie*) #+sbcl (cdr (assoc x sb-c::*policy*))) :when y :collect (list x y)))) @@ -4179,7 +4400,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (deftype sb-grovel-unknown-constant-condition () '(and style-warning (satisfies sb-grovel-unknown-constant-condition-p)))) - (defvar *uninteresting-compiler-conditions* + (defvar *usual-uninteresting-conditions* (append ;;#+clozure '(ccl:compiler-warning) #+cmu '("Deleting unreachable code.") @@ -4188,38 +4409,42 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when #+sbcl '(sb-c::simple-compiler-note "&OPTIONAL and &KEY found in the same lambda list: ~S" - sb-int:package-at-variance - sb-kernel:uninteresting-redefinition - sb-kernel:undefined-alien-style-warning - ;; sb-ext:implicit-generic-function-warning ; Controversial. Let's allow it by default. #+sb-eval sb-kernel:lexical-environment-too-complex + sb-kernel:undefined-alien-style-warning sb-grovel-unknown-constant-condition ; defined above. + sb-ext:implicit-generic-function-warning ;; Controversial. + sb-int:package-at-variance + sb-kernel:uninteresting-redefinition ;; BEWARE: the below four are controversial to include here. sb-kernel:redefinition-with-defun sb-kernel:redefinition-with-defgeneric sb-kernel:redefinition-with-defmethod sb-kernel::redefinition-with-defmacro) ; not exported by old SBCLs '("No generic function ~S present when encountering macroexpansion of defmethod. Assuming it will be an instance of standard-generic-function.")) ;; from closer2mop - "Conditions that may be skipped while compiling") + "A suggested value to which to set or bind *uninteresting-conditions*.") + (defvar *uninteresting-conditions* '() + "Conditions that may be skipped while compiling or loading Lisp code.") + (defvar *uninteresting-compiler-conditions* '() + "Additional conditions that may be skipped while compiling Lisp code.") (defvar *uninteresting-loader-conditions* (append '("Overwriting already existing readtable ~S." ;; from named-readtables #(#:finalizers-off-warning :asdf-finalizers)) ;; from asdf-finalizers #+clisp '(clos::simple-gf-replacing-method-warning)) - "Additional conditions that may be skipped while loading")) + "Additional conditions that may be skipped while loading Lisp code.")) ;;;; ----- Filtering conditions while building ----- (with-upgradability () (defun call-with-muffled-compiler-conditions (thunk) (call-with-muffled-conditions - thunk *uninteresting-compiler-conditions*)) + thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*))) (defmacro with-muffled-compiler-conditions ((&optional) &body body) "Run BODY where uninteresting compiler conditions are muffled" `(call-with-muffled-compiler-conditions #'(lambda () ,@body))) (defun call-with-muffled-loader-conditions (thunk) (call-with-muffled-conditions - thunk (append *uninteresting-compiler-conditions* *uninteresting-loader-conditions*))) + thunk (append *uninteresting-conditions* *uninteresting-loader-conditions*))) (defmacro with-muffled-loader-conditions ((&optional) &body body) "Run BODY where uninteresting compiler and additional loader conditions are muffled" `(call-with-muffled-loader-conditions #'(lambda () ,@body)))) @@ -4322,10 +4547,18 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when name)) (defun reify-function-name (function-name) (let ((name (or (first function-name) ;; defun: extract the name - (first (second function-name))))) ;; defmethod: keep gf name, drop method specializers + (let ((sec (second function-name))) + (or (and (atom sec) sec) ; scoped method: drop scope + (first sec)))))) ; method: keep gf name, drop method specializers (list name))) (defun unreify-function-name (function-name) function-name) + (defun nullify-non-literals (sexp) + (typecase sexp + ((or number character simple-string symbol pathname) sexp) + (cons (cons (nullify-non-literals (car sexp)) + (nullify-non-literals (cdr sexp)))) + (t nil))) (defun reify-deferred-warning (deferred-warning) (with-accessors ((warning-type ccl::compiler-warning-warning-type) (args ccl::compiler-warning-args) @@ -4333,11 +4566,10 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (function-name ccl:compiler-warning-function-name)) deferred-warning (list :warning-type warning-type :function-name (reify-function-name function-name) :source-note (reify-source-note source-note) - :args (destructuring-bind (fun formals env) args - (declare (ignorable env)) - (list (unsymbolify-function-name fun) - (mapcar (constantly nil) formals) - nil))))) + :args (destructuring-bind (fun &rest more) + args + (cons (unsymbolify-function-name fun) + (nullify-non-literals more)))))) (defun unreify-deferred-warning (reified-deferred-warning) (destructuring-bind (&key warning-type function-name source-note args) reified-deferred-warning @@ -4346,8 +4578,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when :function-name (unreify-function-name function-name) :source-note (unreify-source-note source-note) :warning-type warning-type - :args (destructuring-bind (fun . formals) args - (cons (symbolify-function-name fun) formals)))))) + :args (destructuring-bind (fun . more) args + (cons (symbolify-function-name fun) more)))))) #+(or cmu scl) (defun reify-undefined-warning (warning) ;; Extracting undefined-warnings from the compilation-unit @@ -4753,11 +4985,12 @@ it will filter them appropriately." ;;; Links FASLs together (with-upgradability () (defun combine-fasls (inputs output) - #-(or allegro clisp clozure cmu lispworks sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (error "~A does not support ~S~%inputs ~S~%output ~S" (implementation-type) 'combine-fasls inputs output) - #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) + #+abcl (funcall 'sys::concatenate-fasls inputs output) ; requires ABCL 1.2.0 #+(or allegro clisp cmu sbcl scl xcl) (concatenate-files inputs output) + #+clozure (ccl:fasl-concatenate output inputs :if-exists :supersede) #+lispworks (let (fasls) (unwind-protect @@ -4766,9 +4999,8 @@ it will filter them appropriately." :for n :from 1 :for f = (add-pathname-suffix output (format nil "-FASL~D" n)) - :do #-lispworks-personal-edition (lispworks:copy-file i f) - #+lispworks-personal-edition (concatenate-files (list i) f) - (push f fasls)) + :do (copy-file i f) + (push f fasls)) (ignore-errors (lispworks:delete-system :fasls-to-concatenate)) (eval `(scm:defsystem :fasls-to-concatenate (:default-pathname ,(pathname-directory-pathname output)) @@ -4786,7 +5018,7 @@ it will filter them appropriately." (:nicknames :asdf/configuration) (:recycle :uiop/configuration :asdf/configuration :asdf) (:use :uiop/common-lisp :uiop/utility - :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image) + :uiop/os :uiop/pathname :uiop/filesystem :uiop/stream :uiop/image :uiop/lisp-build) (:export #:get-folder-path #:user-configuration-directories #:system-configuration-directories @@ -4794,7 +5026,7 @@ it will filter them appropriately." #:in-user-configuration-directory #:in-system-configuration-directory #:validate-configuration-form #:validate-configuration-file #:validate-configuration-directory #:configuration-inheritance-directive-p - #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* + #:report-invalid-form #:invalid-configuration #:*ignored-configuration-form* #:*user-cache* #:*clear-configuration-hook* #:clear-configuration #:register-clear-configuration-hook #:resolve-location #:location-designator-p #:location-function-p #:*here-directory* #:resolve-relative-location #:resolve-absolute-location #:upgrade-configuration)) @@ -5012,7 +5244,8 @@ directive.") (if wilden (wilden p) p)))) ((eql :home) (user-homedir-pathname)) ((eql :here) (resolve-absolute-location - *here-directory* :ensure-directory t :wilden nil)) + (or *here-directory* (pathname-directory-pathname (load-pathname))) + :ensure-directory t :wilden nil)) ((eql :user-cache) (resolve-absolute-location *user-cache* :ensure-directory t :wilden nil))) :wilden (and wilden (not (pathnamep x))) @@ -5188,7 +5421,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.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 - (asdf-version "2.32") + (asdf-version "3.0.1") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -5205,7 +5438,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO #:find-system #:system-source-file #:system-relative-pathname ;; system #:find-component ;; find-component #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action - #:component-depends-on #:component-self-dependencies #:operation-done-p + #:component-depends-on #:operation-done-p #:component-depends-on #:traverse ;; plan #:operate ;; operate #:parse-component-form ;; defsystem @@ -5219,15 +5452,17 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO (uninterned-symbols '(#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector #:do-dep #:do-one-dep + #:component-self-dependencies #:resolve-relative-location-component #:resolve-absolute-location-component #:output-files-for-system-and-operation))) ; obsolete ASDF-BINARY-LOCATION function (declare (ignorable redefined-functions uninterned-symbols)) - (loop :for name :in (append #-(or ecl) redefined-functions) + (loop :for name :in (append redefined-functions) :for sym = (find-symbol* name :asdf nil) :do (when sym - (fmakunbound sym))) + ;; On CLISP we seem to be unable to fmakunbound and define a function in the same fasl. Sigh. + #-clisp (fmakunbound sym))) (loop :with asdf = (find-package :asdf) - :for name :in (append #+(or ecl) redefined-functions uninterned-symbols) ;XXX + :for name :in uninterned-symbols :for sym = (find-symbol* name :asdf nil) :for base-pkg = (and sym (symbol-package sym)) :do (when sym @@ -5289,7 +5524,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO #:static-file #:doc-file #:html-file #:file-type #:source-file-type #:source-file-explicit-type ;; backward-compatibility - #:component-in-order-to #:component-sibling-dependencies + #:component-in-order-to #:component-sideway-dependencies #:component-if-feature #:around-compile-hook #:component-description #:component-long-description #:component-version #:version-satisfies @@ -5308,7 +5543,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO #:components-by-name #:components #:children #:children-by-name #:default-component-class #:author #:maintainer #:licence #:source-file #:defsystem-depends-on - #:sibling-dependencies #:if-feature #:in-order-to #:inline-methods + #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods #:relative-pathname #:absolute-pathname #:operation-times #:around-compile #:%encoding #:properties #:component-properties #:parent)) (in-package :asdf/component) @@ -5352,7 +5587,7 @@ another pathname in a degenerate way.")) (version :accessor component-version :initarg :version :initform nil) (description :accessor component-description :initarg :description :initform nil) (long-description :accessor component-long-description :initarg :long-description :initform nil) - (sibling-dependencies :accessor component-sibling-dependencies :initform nil) + (sideway-dependencies :accessor component-sideway-dependencies :initform nil) (if-feature :accessor component-if-feature :initform nil :initarg :if-feature) ;; In the ASDF object model, dependencies exist between *actions*, ;; where an action is a pair of an operation and a component. @@ -5547,7 +5782,7 @@ another pathname in a degenerate way.")) (version-satisfies (component-version c) version)) (defmethod version-satisfies ((cver string) version) - (version-compatible-p cver version))) + (version<= version cver))) ;;; all sub-components (of a given type) @@ -6288,7 +6523,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) (:export #:operation - #:operation-original-initargs ;; backward-compatibility only. DO NOT USE. + #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE. #:build-op ;; THE generic operation #:*operations* #:make-operation #:find-operation #:feature)) (in-package :asdf/operation) @@ -6354,8 +6589,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (:export #:action #:define-convenience-action-methods #:explain #:action-description - #:downward-operation #:upward-operation #:sibling-operation - #:component-depends-on #:component-self-dependencies + #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation + #:component-depends-on #:input-files #:output-files #:output-file #:operation-done-p #:action-status #:action-stamp #:action-done-p #:component-operation-time #:mark-operation-done #:compute-action-stamp @@ -6433,7 +6668,7 @@ You can put together sentences using this phrase.")) ;;;; Dependencies (with-upgradability () - (defgeneric component-depends-on (operation component) ;; ASDF4: rename to component-dependencies + (defgeneric* (component-depends-on) (operation component) ;; ASDF4: rename to component-dependencies (:documentation "Returns a list of dependencies needed by the component to perform the operation. A dependency has one of the following forms: @@ -6451,19 +6686,15 @@ You can put together sentences using this phrase.")) Methods specialized on subclasses of existing component types should usually append the results of CALL-NEXT-METHOD to the list.")) - (defgeneric component-self-dependencies (operation component)) (define-convenience-action-methods component-depends-on (operation component)) - (define-convenience-action-methods component-self-dependencies (operation component)) + + (defmethod component-depends-on :around ((o operation) (c component)) + (do-asdf-cache `(component-depends-on ,o ,c) + (call-next-method))) (defmethod component-depends-on ((o operation) (c component)) - (cdr (assoc (type-of o) (component-in-order-to c)))) ; User-specified in-order dependencies + (cdr (assoc (type-of o) (component-in-order-to c))))) ; User-specified in-order dependencies - (defmethod component-self-dependencies ((o operation) (c component)) - ;; NB: result in the same format as component-depends-on - (loop* :for (o-spec . c-spec) :in (component-depends-on o c) - :unless (eq o-spec 'feature) ;; avoid the FEATURE "feature" - :when (find c c-spec :key #'(lambda (dep) (resolve-dependency-spec c dep))) - :collect (list o-spec c)))) ;;;; upward-operation, downward-operation ;; These together handle actions that propagate along the component hierarchy. @@ -6473,7 +6704,7 @@ You can put together sentences using this phrase.")) (with-upgradability () (defclass downward-operation (operation) ((downward-operation - :initform nil :initarg :downward-operation :reader downward-operation))) + :initform nil :initarg :downward-operation :reader downward-operation :allocation :class))) (defmethod component-depends-on ((o downward-operation) (c parent-component)) `((,(or (downward-operation o) o) ,@(component-children c)) ,@(call-next-method))) ;; Upward operations like prepare-op propagate up the component hierarchy: @@ -6481,7 +6712,7 @@ You can put together sentences using this phrase.")) ;; By default, an operation propagates itself, but it may propagate another one instead. (defclass upward-operation (operation) ((upward-operation - :initform nil :initarg :downward-operation :reader upward-operation))) + :initform nil :initarg :downward-operation :reader upward-operation :allocation :class))) ;; For backward-compatibility reasons, a system inherits from module and is a child-component ;; so we must guard against this case. ASDF4: remove that. (defmethod component-depends-on ((o upward-operation) (c child-component)) @@ -6490,13 +6721,22 @@ You can put together sentences using this phrase.")) ;; Sibling operations propagate to siblings in the component hierarchy: ;; operation on a child depends-on operation on its parent. ;; By default, an operation propagates itself, but it may propagate another one instead. - (defclass sibling-operation (operation) - ((sibling-operation - :initform nil :initarg :sibling-operation :reader sibling-operation))) - (defmethod component-depends-on ((o sibling-operation) (c component)) - `((,(or (sibling-operation o) o) - ,@(loop :for dep :in (component-sibling-dependencies c) + (defclass sideway-operation (operation) + ((sideway-operation + :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class))) + (defmethod component-depends-on ((o sideway-operation) (c component)) + `((,(or (sideway-operation o) o) + ,@(loop :for dep :in (component-sideway-dependencies c) :collect (resolve-dependency-spec c dep))) + ,@(call-next-method))) + ;; Selfward operations propagate to themselves a sub-operation: + ;; they depend on some other operation being acted on the same component. + (defclass selfward-operation (operation) + ((selfward-operation + :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class))) + (defmethod component-depends-on ((o selfward-operation) (c component)) + `(,@(loop :for op :in (ensure-list (selfward-operation o)) + :collect `(,op ,c)) ,@(call-next-method)))) @@ -6546,17 +6786,16 @@ You can put together sentences using this phrase.")) (do-asdf-cache `(input-files ,operation ,component) (call-next-method))) - (defmethod input-files ((o operation) (c parent-component)) + (defmethod input-files ((o operation) (c component)) (declare (ignorable o c)) nil) - (defmethod input-files ((o operation) (c component)) - (or (loop* :for (dep-o) :in (component-self-dependencies o c) - :append (or (output-files dep-o c) (input-files dep-o c))) - ;; no non-trivial previous operations needed? - ;; I guess we work with the original source file, then - (if-let ((pathname (component-pathname c))) - (and (file-pathname-p pathname) (list pathname)))))) + (defmethod input-files ((o selfward-operation) (c component)) + `(,@(or (loop :for dep-o :in (ensure-list (selfward-operation o)) + :append (or (output-files dep-o c) (input-files dep-o c))) + (if-let ((pathname (component-pathname c))) + (and (file-pathname-p pathname) (list pathname)))) + ,@(call-next-method)))) ;;;; Done performing @@ -6663,7 +6902,8 @@ in some previous image, or T if it needs to be done.") #: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 #:call-with-around-compile-hook - #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source #:flags)) + #:perform-lisp-compilation #:perform-lisp-load-fasl #:perform-lisp-load-source + #:lisp-compilation-output-files #:flags)) (in-package :asdf/lisp-action) @@ -6687,17 +6927,23 @@ in some previous image, or T if it needs to be done.") ;;; Our default operations: loading into the current lisp image (with-upgradability () - (defclass load-op (basic-load-op downward-operation sibling-operation) ()) - (defclass prepare-op (upward-operation sibling-operation) - ((sibling-operation :initform 'load-op :allocation :class))) - (defclass compile-op (basic-compile-op downward-operation) - ((downward-operation :initform 'load-op :allocation :class))) + (defclass prepare-op (upward-operation sideway-operation) + ((sideway-operation :initform 'load-op))) + (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation) + ;; NB: even though compile-op depends-on on prepare-op it is not needed-in-image-p, + ;; so we need to directly depend on prepare-op for its side-effects in the current image. + ((selfward-operation :initform '(prepare-op compile-op)))) + (defclass compile-op (basic-compile-op downward-operation selfward-operation) + ((selfward-operation :initform 'prepare-op) + (downward-operation :initform 'load-op))) - (defclass load-source-op (basic-load-op downward-operation) ()) - (defclass prepare-source-op (upward-operation sibling-operation) - ((sibling-operation :initform 'load-source-op :allocation :class))) + (defclass prepare-source-op (upward-operation sideway-operation) + ((sideway-operation :initform 'load-source-op))) + (defclass load-source-op (basic-load-op downward-operation selfward-operation) + ((selfward-operation :initform 'prepare-source-op))) - (defclass test-op (operation) ())) + (defclass test-op (selfward-operation) + ((selfward-operation :initform 'load-op)))) ;;;; prepare-op, compile-op and load-op @@ -6773,8 +7019,7 @@ in some previous image, or T if it needs to be done.") (format s ":success~%")))))) (defmethod perform ((o compile-op) (c cl-source-file)) (perform-lisp-compilation o c)) - (defmethod output-files ((o compile-op) (c cl-source-file)) - (declare (ignorable o)) + (defun lisp-compilation-output-files (o c) (let* ((i (first (input-files o c))) (f (compile-file-pathname i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))) @@ -6788,9 +7033,8 @@ in some previous image, or T if it needs to be done.") ,(compile-file-pathname i :fasl-p nil) ;; object file ,@(when (and *warnings-file-type* (not (builtin-system-p (component-system c)))) `(,(make-pathname :type *warnings-file-type* :defaults f)))))) - (defmethod component-depends-on ((o compile-op) (c component)) - (declare (ignorable o)) - `((prepare-op ,c) ,@(call-next-method))) + (defmethod output-files ((o compile-op) (c cl-source-file)) + (lisp-compilation-output-files o c)) (defmethod perform ((o compile-op) (c static-file)) (declare (ignorable o c)) nil) @@ -6840,13 +7084,7 @@ in some previous image, or T if it needs to be done.") (perform-lisp-load-fasl o c)) (defmethod perform ((o load-op) (c static-file)) (declare (ignorable o c)) - nil) - (defmethod component-depends-on ((o load-op) (c component)) - (declare (ignorable o)) - ;; NB: even though compile-op depends-on on prepare-op, - ;; it is not needed-in-image-p, whereas prepare-op is, - ;; so better not omit prepare-op and think it will happen. - `((prepare-op ,c) (compile-op ,c) ,@(call-next-method)))) + nil)) ;;;; prepare-source-op, load-source-op @@ -6874,9 +7112,6 @@ in some previous image, or T if it needs to be done.") (defmethod action-description ((o load-source-op) (c parent-component)) (declare (ignorable o)) (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c)) - (defmethod component-depends-on ((o load-source-op) (c component)) - (declare (ignorable o)) - `((prepare-source-op ,c) ,@(call-next-method))) (defun perform-lisp-load-source (o c) (call-with-around-compile-hook c #'(lambda () @@ -6902,11 +7137,7 @@ in some previous image, or T if it needs to be done.") (defmethod operation-done-p ((o test-op) (c system)) "Testing a system is _never_ done." (declare (ignorable o c)) - nil) - (defmethod component-depends-on ((o test-op) (c system)) - (declare (ignorable o)) - `((load-op ,c) ,@(call-next-method)))) - + nil)) ;;;; ------------------------------------------------------------------------- ;;;; Plan @@ -7151,9 +7382,9 @@ the action of OPERATION on COMPONENT in the PLAN")) (and all-present up-to-date-p (operation-done-p o c) (not (action-forced-p plan o c)))) (values done-stamp ;; return the hard-earned timestamp (or just-done - (or out-op ;; a file-creating op is done when all files are up to date - ;; a image-effecting a placeholder op is done when it was actually run, - (and op-time (eql op-time done-stamp))))) ;; with the matching stamp + out-op ;; a file-creating op is done when all files are up to date + ;; a image-effecting a placeholder op is done when it was actually run, + (and op-time (eql op-time done-stamp)))) ;; with the matching stamp ;; done-stamp invalid: return a timestamp in an indefinite future, action not done yet (values t nil))))) @@ -7280,7 +7511,7 @@ processed in order by OPERATE.")) (defgeneric perform-plan (plan &key)) (defgeneric plan-operates-on-p (plan component)) - (defparameter *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) (let ((plan (apply 'make-instance @@ -7296,9 +7527,10 @@ processed in order by OPERATE.")) (with-compilation-unit () ;; backward-compatibility. (call-next-method)))) ;; Going forward, see deferred-warning support in lisp-build. - (defmethod perform-plan ((steps list) &key) - (loop* :for (op . component) :in steps :do - (perform-with-restarts op component))) + (defmethod perform-plan ((steps list) &key force &allow-other-keys) + (loop* :for (o . c) :in steps + :when (or force (not (nth-value 1 (compute-action-stamp nil o c)))) + :do (perform-with-restarts o c))) (defmethod plan-operates-on-p ((plan list) (component-path list)) (find component-path (mapcar 'cdr plan) @@ -7347,7 +7579,8 @@ processed in order by OPERATE.")) (defmethod required-components (system &rest keys &key (goal-operation 'load-op) &allow-other-keys) (remove-duplicates - (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system keys)) + (mapcar 'cdr (apply 'traverse-sub-actions goal-operation system + (remove-plist-key :goal-operation keys))) :from-end t))) ;;;; ------------------------------------------------------------------------- @@ -7440,7 +7673,7 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: (defmethod operate ((operation operation) (component component) &rest keys &key &allow-other-keys) (let ((plan (apply 'traverse operation component keys))) - (perform-plan plan) + (apply 'perform-plan plan keys) (values operation plan))) (defun oos (operation component &rest args &key &allow-other-keys) @@ -7563,1685 +7796,1705 @@ for how to load or compile stuff") (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)) -;;;; --------------------------------------------------------------------------- -;;;; asdf-output-translations - -(asdf/package:define-package :asdf/output-translations - (:recycle :asdf/output-translations :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) - (:export - #:*output-translations* #:*output-translations-parameter* - #:invalid-output-translation - #:output-translations #:output-translations-initialized-p - #:initialize-output-translations #:clear-output-translations - #:disable-output-translations #:ensure-output-translations - #:apply-output-translations - #:validate-output-translations-directive #:validate-output-translations-form - #:validate-output-translations-file #:validate-output-translations-directory - #:parse-output-translations-string #:wrapping-output-translations - #:user-output-translations-pathname #:system-output-translations-pathname - #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname - #:environment-output-translations #:process-output-translations - #:compute-output-translations - #+abcl #:translate-jar-pathname - )) -(in-package :asdf/output-translations) +;;;; ------------------------------------------------------------------------- +;;; Internal hacks for backward-compatibility -(when-upgrading () (undefine-function '(setf output-translations))) +(asdf/package:define-package :asdf/backward-internals + (:recycle :asdf/backward-internals :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/system :asdf/component :asdf/operation + :asdf/find-system :asdf/action :asdf/lisp-action) + (:export ;; for internal use + #:load-sysdef #:make-temporary-package + #:%refresh-component-inline-methods + #:%resolve-if-component-dep-fails + #:make-sub-operation + #:load-sysdef #:make-temporary-package)) +(in-package :asdf/backward-internals) +;;;; Backward compatibility with "inline methods" (with-upgradability () - (define-condition invalid-output-translation (invalid-configuration warning) - ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) - - (defvar *output-translations* () - "Either NIL (for uninitialized), or a list of one element, -said element itself being a sorted list of mappings. -Each mapping is a pair of a source pathname and destination pathname, -and the order is by decreasing length of namestring of the source pathname.") + (defparameter +asdf-methods+ + '(perform-with-restarts perform explain output-files operation-done-p)) - (defun output-translations () - (car *output-translations*)) + (defun %remove-component-inline-methods (component) + (dolist (name +asdf-methods+) + (map () + ;; this is inefficient as most of the stored + ;; methods will not be for this particular gf + ;; But this is hardly performance-critical + #'(lambda (m) + (remove-method (symbol-function name) m)) + (component-inline-methods component))) + (component-inline-methods component) nil) - (defun set-output-translations (new-value) - (setf *output-translations* - (list - (stable-sort (copy-list new-value) #'> - :key #'(lambda (x) - (etypecase (car x) - ((eql t) -1) - (pathname - (let ((directory (pathname-directory (car x)))) - (if (listp directory) (length directory) 0)))))))) - new-value) - (defsetf output-translations set-output-translations) ; works with gcl 2.6 + (defun %define-component-inline-methods (ret rest) + (loop* :for (key value) :on rest :by #'cddr + :for name = (and (keywordp key) (find key +asdf-methods+ :test 'string=)) + :when name :do + (destructuring-bind (op &rest body) value + (loop :for arg = (pop body) + :while (atom arg) + :collect arg :into qualifiers + :finally + (destructuring-bind (o c) arg + (pushnew + (eval `(defmethod ,name ,@qualifiers ((,o ,op) (,c (eql ,ret))) ,@body)) + (component-inline-methods ret))))))) - (defun output-translations-initialized-p () - (and *output-translations* t)) + (defun %refresh-component-inline-methods (component rest) + ;; clear methods, then add the new ones + (%remove-component-inline-methods component) + (%define-component-inline-methods component rest))) - (defun clear-output-translations () - "Undoes any initialization of the output translations." - (setf *output-translations* '()) - (values)) - (register-clear-configuration-hook 'clear-output-translations) +;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute +;; and the companion asdf:feature pseudo-dependency. +;; This won't recurse into dependencies to accumulate feature conditions. +;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL +;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles. +(with-upgradability () + (defun %resolve-if-component-dep-fails (if-component-dep-fails component) + (asdf-message "The system definition for ~S uses deprecated ~ + ASDF option :IF-COMPONENT-DEP-DAILS. ~ + Starting with ASDF 3, please use :IF-FEATURE instead" + (coerce-name (component-system component))) + ;; This only supports the pattern of use of the "feature" seen in the wild + (check-type component parent-component) + (check-type if-component-dep-fails (member :fail :ignore :try-next)) + (unless (eq if-component-dep-fails :fail) + (loop :with o = (make-operation 'compile-op) + :for c :in (component-children component) :do + (loop* :for (feature? feature) :in (component-depends-on o c) + :when (eq feature? 'feature) :do + (setf (component-if-feature c) feature)))))) - (defun validate-output-translations-directive (directive) - (or (member directive '(:enable-user-cache :disable-cache nil)) - (and (consp directive) - (or (and (length=n-p directive 2) - (or (and (eq (first directive) :include) - (typep (second directive) '(or string pathname null))) - (and (location-designator-p (first directive)) - (or (location-designator-p (second directive)) - (location-function-p (second directive)))))) - (and (length=n-p directive 1) - (location-designator-p (first directive))))))) +(when-upgrading (:when (fboundp 'make-sub-operation)) + (defun make-sub-operation (c o dep-c dep-o) + (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) - (defun validate-output-translations-form (form &key location) - (validate-configuration-form - form - :output-translations - 'validate-output-translations-directive - :location location :invalid-form-reporter 'invalid-output-translation)) - (defun validate-output-translations-file (file) - (validate-configuration-file - file 'validate-output-translations-form :description "output translations")) +;;;; load-sysdef +(with-upgradability () + (defun load-sysdef (name pathname) + (load-asd pathname :name name)) - (defun validate-output-translations-directory (directory) - (validate-configuration-directory - directory :output-translations 'validate-output-translations-directive - :invalid-form-reporter 'invalid-output-translation)) + (defun make-temporary-package () + ;; For loading a .asd file, we dont't make a temporary package anymore, + ;; but use ASDF-USER. I'd like to have this function do this, + ;; but since whoever uses it is likely to delete-package the result afterwards, + ;; this would be a bad idea, so preserve the old behavior. + (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf)))) - (defun parse-output-translations-string (string &key location) - (cond - ((or (null string) (equal string "")) - '(:output-translations :inherit-configuration)) - ((not (stringp string)) - (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string)) - ((eql (char string 0) #\") - (parse-output-translations-string (read-from-string string) :location location)) - ((eql (char string 0) #\() - (validate-output-translations-form (read-from-string string) :location location)) - (t - (loop - :with inherit = nil - :with directives = () - :with start = 0 - :with end = (length string) - :with source = nil - :with separator = (inter-directory-separator) - :for i = (or (position separator string :start start) end) :do - (let ((s (subseq string start i))) - (cond - (source - (push (list source (if (equal "" s) nil s)) directives) - (setf source nil)) - ((equal "" s) - (when inherit - (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") - string)) - (setf inherit t) - (push :inherit-configuration directives)) - (t - (setf source s))) - (setf start (1+ i)) - (when (> start end) - (when source - (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>") - string)) - (unless inherit - (push :ignore-inherited-configuration directives)) - (return `(:output-translations ,@(nreverse directives))))))))) - (defparameter *default-output-translations* - '(environment-output-translations - user-output-translations-pathname - user-output-translations-directory-pathname - system-output-translations-pathname - system-output-translations-directory-pathname)) +;;;; ------------------------------------------------------------------------- +;;;; Defsystem - (defun wrapping-output-translations () - `(:output-translations - ;; Some implementations have precompiled ASDF systems, - ;; so we must disable translations for implementation paths. - #+(or #|clozure|# ecl mkcl sbcl) - ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) - (when h `(((,h ,*wild-path*) ())))) - #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) - ;; All-import, here is where we want user stuff to be: - :inherit-configuration - ;; These are for convenience, and can be overridden by the user: - #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) - #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - ;; We enable the user cache by default, and here is the place we do: - :enable-user-cache)) - - (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf")) - (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/")) +(asdf/package:define-package :asdf/defsystem + (:recycle :asdf/defsystem :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/cache + :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate + :asdf/backward-internals) + (:export + #:defsystem #:register-system-definition + #:class-for-type #:*default-component-class* + #:determine-system-directory #:parse-component-form + #:duplicate-names #:non-toplevel-system #:non-system-system + #:sysdef-error-component #:check-component-input)) +(in-package :asdf/defsystem) - (defun user-output-translations-pathname (&key (direction :input)) - (in-user-configuration-directory *output-translations-file* :direction direction)) - (defun system-output-translations-pathname (&key (direction :input)) - (in-system-configuration-directory *output-translations-file* :direction direction)) - (defun user-output-translations-directory-pathname (&key (direction :input)) - (in-user-configuration-directory *output-translations-directory* :direction direction)) - (defun system-output-translations-directory-pathname (&key (direction :input)) - (in-system-configuration-directory *output-translations-directory* :direction direction)) - (defun environment-output-translations () - (getenv "ASDF_OUTPUT_TRANSLATIONS")) +;;; Pathname +(with-upgradability () + (defun determine-system-directory (pathname) + ;; The defsystem macro calls this function to determine + ;; the pathname of a system as follows: + ;; 1. if the pathname argument is an pathname object (NOT a namestring), + ;; that is already an absolute pathname, return it. + ;; 2. otherwise, the directory containing the LOAD-PATHNAME + ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and + ;; if it is indeed available and an absolute pathname, then + ;; the PATHNAME argument is normalized to a relative pathname + ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) + ;; and merged into that DIRECTORY as per SUBPATHNAME. + ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded, + ;; and may be from within the EVAL-WHEN of a file compilation. + ;; If no absolute pathname was found, we return NIL. + (check-type pathname (or null string pathname)) + (pathname-directory-pathname + (resolve-symlinks* + (ensure-absolute-pathname + (parse-unix-namestring pathname :type :directory) + #'(lambda () (ensure-absolute-pathname + (load-pathname) 'get-pathname-defaults nil)) + nil))))) - (defgeneric process-output-translations (spec &key inherit collect)) - (defun inherit-output-translations (inherit &key collect) - (when inherit - (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) +;;; Component class +(with-upgradability () + (defvar *default-component-class* 'cl-source-file) - (defun* (process-output-translations-directive) (directive &key inherit collect) - (if (atom directive) - (ecase directive - ((:enable-user-cache) - (process-output-translations-directive '(t :user-cache) :collect collect)) - ((:disable-cache) - (process-output-translations-directive '(t t) :collect collect)) - ((:inherit-configuration) - (inherit-output-translations inherit :collect collect)) - ((:ignore-inherited-configuration :ignore-invalid-entries nil) - nil)) - (let ((src (first directive)) - (dst (second directive))) - (if (eq src :include) - (when dst - (process-output-translations (pathname dst) :inherit nil :collect collect)) - (when src - (let ((trusrc (or (eql src t) - (let ((loc (resolve-location src :ensure-directory t :wilden t))) - (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc))))) - (cond - ((location-function-p dst) - (funcall collect - (list trusrc - (if (symbolp (second dst)) - (fdefinition (second dst)) - (eval (second dst)))))) - ((eq dst t) - (funcall collect (list trusrc t))) - (t - (let* ((trudst (if dst - (resolve-location dst :ensure-directory t :wilden t) - trusrc))) - (funcall collect (list trudst t)) - (funcall collect (list trusrc trudst))))))))))) + (defun class-for-type (parent type) + (or (loop :for symbol :in (list + type + (find-symbol* type *package* nil) + (find-symbol* type :asdf/interface nil) + (and (stringp type) (safe-read-from-string type :package :asdf/interface))) + :for class = (and symbol (symbolp symbol) (find-class* symbol nil)) + :when (and class + (#-cormanlisp subtypep #+cormanlisp cl::subclassp + class (find-class* 'component))) + :return class) + (and (eq type :file) + (find-class* + (or (loop :for p = parent :then (component-parent p) :while p + :thereis (module-default-component-class p)) + *default-component-class*) nil)) + (sysdef-error "don't recognize component type ~A" type)))) - (defmethod process-output-translations ((x symbol) &key - (inherit *default-output-translations*) - collect) - (process-output-translations (funcall x) :inherit inherit :collect collect)) - (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect) - (cond - ((directory-pathname-p pathname) - (process-output-translations (validate-output-translations-directory pathname) - :inherit inherit :collect collect)) - ((probe-file* pathname :truename *resolve-symlinks*) - (process-output-translations (validate-output-translations-file pathname) - :inherit inherit :collect collect)) - (t - (inherit-output-translations inherit :collect collect)))) - (defmethod process-output-translations ((string string) &key inherit collect) - (process-output-translations (parse-output-translations-string string) - :inherit inherit :collect collect)) - (defmethod process-output-translations ((x null) &key inherit collect) - (declare (ignorable x)) - (inherit-output-translations inherit :collect collect)) - (defmethod process-output-translations ((form cons) &key inherit collect) - (dolist (directive (cdr (validate-output-translations-form form))) - (process-output-translations-directive directive :inherit inherit :collect collect))) - (defun compute-output-translations (&optional parameter) - "read the configuration, return it" - (remove-duplicates - (while-collecting (c) - (inherit-output-translations - `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) - :test 'equal :from-end t)) +;;; Check inputs +(with-upgradability () + (define-condition duplicate-names (system-definition-error) + ((name :initarg :name :reader duplicate-names-name)) + (:report (lambda (c s) + (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>") + (duplicate-names-name c))))) - (defvar *output-translations-parameter* nil) + (define-condition non-system-system (system-definition-error) + ((name :initarg :name :reader non-system-system-name) + (class-name :initarg :class-name :reader non-system-system-class-name)) + (:report (lambda (c s) + (format s (compatfmt "~@<Error while defining system ~S: class ~S isn't a subclass of ~S~@:>") + (non-system-system-name c) (non-system-system-class-name c) 'system)))) - (defun initialize-output-translations (&optional (parameter *output-translations-parameter*)) - "read the configuration, initialize the internal configuration variable, -return the configuration" - (setf *output-translations-parameter* parameter - (output-translations) (compute-output-translations parameter))) + (define-condition non-toplevel-system (system-definition-error) + ((parent :initarg :parent :reader non-toplevel-system-parent) + (name :initarg :name :reader non-toplevel-system-name)) + (:report (lambda (c s) + (format s (compatfmt "~@<Error while defining system: component ~S claims to have a system ~S as a child~@:>") + (non-toplevel-system-parent c) (non-toplevel-system-name c))))) - (defun disable-output-translations () - "Initialize output translations in a way that maps every file to itself, -effectively disabling the output translation facility." - (initialize-output-translations - '(:output-translations :disable-cache :ignore-inherited-configuration))) + (defun sysdef-error-component (msg type name value) + (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) + type name value)) - ;; checks an initial variable to see whether the state is initialized - ;; or cleared. In the former case, return current configuration; in - ;; the latter, initialize. ASDF will call this function at the start - ;; of (asdf:find-system). - (defun ensure-output-translations () - (if (output-translations-initialized-p) - (output-translations) - (initialize-output-translations))) + (defun check-component-input (type name weakly-depends-on + depends-on components) + "A partial test of the values of a component." + (unless (listp depends-on) + (sysdef-error-component ":depends-on must be a list." + type name depends-on)) + (unless (listp weakly-depends-on) + (sysdef-error-component ":weakly-depends-on must be a list." + type name weakly-depends-on)) + (unless (listp components) + (sysdef-error-component ":components must be NIL or a list of components." + type name components))) - (defun* (apply-output-translations) (path) - (etypecase path - (logical-pathname - path) - ((or pathname string) - (ensure-output-translations) - (loop* :with p = (resolve-symlinks* path) - :for (source destination) :in (car *output-translations*) - :for root = (when (or (eq source t) - (and (pathnamep source) - (not (absolute-pathname-p source)))) - (pathname-root p)) - :for absolute-source = (cond - ((eq source t) (wilden root)) - (root (merge-pathnames* source root)) - (t source)) - :when (or (eq source t) (pathname-match-p p absolute-source)) - :return (translate-pathname* p absolute-source destination root source) - :finally (return p))))) + (defun* (normalize-version) (form &key pathname component parent) + (labels ((invalid (&optional (continuation "using NIL instead")) + (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>") + form component parent pathname continuation)) + (invalid-parse (control &rest args) + (unless (builtin-system-p (find-component parent component)) + (apply 'warn control args) + (invalid)))) + (if-let (v (typecase form + ((or string null) form) + (real + (invalid "Substituting a string") + (format nil "~D" form)) ;; 1.0 becomes "1.0" + (cons + (case (first form) + ((:read-file-form) + (destructuring-bind (subpath &key (at 0)) (rest form) + (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user))) + ((:read-file-line) + (destructuring-bind (subpath &key (at 0)) (rest form) + (read-file-lines (subpathname pathname subpath) :at at))) + (otherwise + (invalid)))) + (t + (invalid)))) + (if-let (pv (parse-version v #'invalid-parse)) + (unparse-version pv) + (invalid)))))) - ;; Hook into asdf/driver's output-translation mechanism - #-cormanlisp - (setf *output-translation-function* 'apply-output-translations) - - #+abcl - (defun translate-jar-pathname (source wildcard) - (declare (ignore wildcard)) - (flet ((normalize-device (pathname) - (if (find :windows *features*) - pathname - (make-pathname :defaults pathname :device :unspecific)))) - (let* ((jar - (pathname (first (pathname-device source)))) - (target-root-directory-namestring - (format nil "/___jar___file___root___/~@[~A/~]" - (and (find :windows *features*) - (pathname-device jar)))) - (relative-source - (relativize-pathname-directory source)) - (relative-jar - (relativize-pathname-directory (ensure-directory-pathname jar))) - (target-root-directory - (normalize-device - (pathname-directory-pathname - (parse-namestring target-root-directory-namestring)))) - (target-root - (merge-pathnames* relative-jar target-root-directory)) - (target - (merge-pathnames* relative-source target-root))) - (normalize-device (apply-output-translations target)))))) - -;;;; ----------------------------------------------------------------- -;;;; Source Registry Configuration, by Francois-Rene Rideau -;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 - -(asdf/package:define-package :asdf/source-registry - (:recycle :asdf/source-registry :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system) - (:export - #:*source-registry-parameter* #:*default-source-registries* - #:invalid-source-registry - #:source-registry-initialized-p - #:initialize-source-registry #:clear-source-registry #:*source-registry* - #:ensure-source-registry #:*source-registry-parameter* - #:*default-source-registry-exclusions* #:*source-registry-exclusions* - #:*wild-asd* #:directory-asd-files #:register-asd-directory - #:collect-asds-in-directory #:collect-sub*directories-asd-files - #:validate-source-registry-directive #:validate-source-registry-form - #:validate-source-registry-file #:validate-source-registry-directory - #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry - #:user-source-registry #:system-source-registry - #:user-source-registry-directory #:system-source-registry-directory - #:environment-source-registry #:process-source-registry - #:compute-source-registry #:flatten-source-registry - #:sysdef-source-registry-search)) -(in-package :asdf/source-registry) +;;; Main parsing function (with-upgradability () - (define-condition invalid-source-registry (invalid-configuration warning) - ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) - - ;; Using ack 1.2 exclusions - (defvar *default-source-registry-exclusions* - '(".bzr" ".cdv" - ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards - ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" - "_sgbak" "autom4te.cache" "cover_db" "_build" - "debian")) ;; debian often builds stuff under the debian directory... BAD. - - (defvar *source-registry-exclusions* *default-source-registry-exclusions*) - - (defvar *source-registry* nil - "Either NIL (for uninitialized), or an equal hash-table, mapping -system names to pathnames of .asd files") - - (defun source-registry-initialized-p () - (typep *source-registry* 'hash-table)) - - (defun clear-source-registry () - "Undoes any initialization of the source registry." - (setf *source-registry* nil) - (values)) - (register-clear-configuration-hook 'clear-source-registry) - - (defparameter *wild-asd* - (make-pathname* :directory nil :name *wild* :type "asd" :version :newest)) - - (defun directory-asd-files (directory) - (directory-files directory *wild-asd*)) - - (defun collect-asds-in-directory (directory collect) - (map () collect (directory-asd-files directory))) - - (defun collect-sub*directories-asd-files - (directory &key (exclude *default-source-registry-exclusions*) collect) - (collect-sub*directories - directory - (constantly t) - #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal))) - #'(lambda (dir) (collect-asds-in-directory dir collect)))) - - (defun validate-source-registry-directive (directive) - (or (member directive '(:default-registry)) - (and (consp directive) - (let ((rest (rest directive))) - (case (first directive) - ((:include :directory :tree) - (and (length=n-p rest 1) - (location-designator-p (first rest)))) - ((:exclude :also-exclude) - (every #'stringp rest)) - ((:default-registry) - (null rest))))))) - - (defun validate-source-registry-form (form &key location) - (validate-configuration-form - form :source-registry 'validate-source-registry-directive - :location location :invalid-form-reporter 'invalid-source-registry)) - - (defun validate-source-registry-file (file) - (validate-configuration-file - file 'validate-source-registry-form :description "a source registry")) - - (defun validate-source-registry-directory (directory) - (validate-configuration-directory - directory :source-registry 'validate-source-registry-directive - :invalid-form-reporter 'invalid-source-registry)) - - (defun parse-source-registry-string (string &key location) - (cond - ((or (null string) (equal string "")) - '(:source-registry :inherit-configuration)) - ((not (stringp string)) - (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string)) - ((find (char string 0) "\"(") - (validate-source-registry-form (read-from-string string) :location location)) - (t - (loop - :with inherit = nil - :with directives = () - :with start = 0 - :with end = (length string) - :with separator = (inter-directory-separator) - :for pos = (position separator string :start start) :do - (let ((s (subseq string start (or pos end)))) - (flet ((check (dir) - (unless (absolute-pathname-p dir) - (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string)) - dir)) - (cond - ((equal "" s) ; empty element: inherit - (when inherit - (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") - string)) - (setf inherit t) - (push ':inherit-configuration directives)) - ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? - (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) - (t - (push `(:directory ,(check s)) directives)))) - (cond - (pos - (setf start (1+ pos))) - (t - (unless inherit - (push '(:ignore-inherited-configuration) directives)) - (return `(:source-registry ,@(nreverse directives)))))))))) - - (defun register-asd-directory (directory &key recurse exclude collect) - (if (not recurse) - (collect-asds-in-directory directory collect) - (collect-sub*directories-asd-files - directory :exclude exclude :collect collect))) - - (defparameter *default-source-registries* - '(environment-source-registry - user-source-registry - user-source-registry-directory - system-source-registry - system-source-registry-directory - default-source-registry)) - - (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf")) - (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/")) - - (defun wrapping-source-registry () - `(:source-registry - #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) - #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) - :inherit-configuration - #+cmu (:tree #p"modules:") - #+scl (:tree #p"file://modules/"))) - (defun default-source-registry () - `(:source-registry - #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/")) - ,@(loop :for dir :in - `(,@(when (os-unix-p) - `(,(or (getenv-absolute-directory "XDG_DATA_HOME") - (subpathname (user-homedir-pathname) ".local/share/")) - ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") - '("/usr/local/share" "/usr/share")))) - ,@(when (os-windows-p) - (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata)))) - :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) - :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) - :inherit-configuration)) - (defun user-source-registry (&key (direction :input)) - (in-user-configuration-directory *source-registry-file* :direction direction)) - (defun system-source-registry (&key (direction :input)) - (in-system-configuration-directory *source-registry-file* :direction direction)) - (defun user-source-registry-directory (&key (direction :input)) - (in-user-configuration-directory *source-registry-directory* :direction direction)) - (defun system-source-registry-directory (&key (direction :input)) - (in-system-configuration-directory *source-registry-directory* :direction direction)) - (defun environment-source-registry () - (getenv "CL_SOURCE_REGISTRY")) + (defun* (parse-component-form) (parent options &key previous-serial-component) + (destructuring-bind + (type name &rest rest &key + (builtin-system-p () bspp) + ;; the following list of keywords is reproduced below in the + ;; remove-plist-keys form. important to keep them in sync + components pathname perform explain output-files operation-done-p + weakly-depends-on depends-on serial + do-first if-component-dep-fails version + ;; list ends + &allow-other-keys) options + (declare (ignorable perform explain output-files operation-done-p builtin-system-p)) + (check-component-input type name weakly-depends-on depends-on components) + (when (and parent + (find-component parent name) + (not ;; ignore the same object when rereading the defsystem + (typep (find-component parent name) + (class-for-type parent type)))) + (error 'duplicate-names :name name)) + (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3")) + (let* ((name (coerce-name name)) + (args `(:name ,name + :pathname ,pathname + ,@(when parent `(:parent ,parent)) + ,@(remove-plist-keys + '(:components :pathname :if-component-dep-fails :version + :perform :explain :output-files :operation-done-p + :weakly-depends-on :depends-on :serial) + rest))) + (component (find-component parent name)) + (class (class-for-type parent type))) + (when (and parent (subtypep class 'system)) + (error 'non-toplevel-system :parent parent :name name)) + (if component ; preserve identity + (apply 'reinitialize-instance component args) + (setf component (apply 'make-instance class args))) + (component-pathname component) ; eagerly compute the absolute pathname + (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous + (when (and (typep component 'system) (not bspp)) + (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile))) + (setf version (normalize-version version :component name :parent parent :pathname sysfile))) + ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8. + ;; A better fix is required. + (setf (slot-value component 'version) version) + (when (typep component 'parent-component) + (setf (component-children component) + (loop + :with previous-component = nil + :for c-form :in components + :for c = (parse-component-form component c-form + :previous-serial-component previous-component) + :for name = (component-name c) + :collect c + :when serial :do (setf previous-component name))) + (compute-children-by-name component)) + (when previous-serial-component + (push previous-serial-component depends-on)) + (when weakly-depends-on + ;; ASDF4: deprecate this feature and remove it. + (appendf depends-on + (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) + ;; Used by POIU. ASDF4: rename to component-depends-on? + (setf (component-sideway-dependencies component) depends-on) + (%refresh-component-inline-methods component rest) + (when if-component-dep-fails + (%resolve-if-component-dep-fails if-component-dep-fails component)) + component))) - (defgeneric* (process-source-registry) (spec &key inherit register)) + (defun register-system-definition + (name &rest options &key pathname (class 'system) (source-file () sfp) + defsystem-depends-on &allow-other-keys) + ;; The system must be registered before we parse the body, + ;; otherwise we recur when trying to find an existing system + ;; of the same name to reuse options (e.g. pathname) from. + ;; To avoid infinite recursion in cases where you defsystem a system + ;; that is registered to a different location to find-system, + ;; we also need to remember it in a special variable *systems-being-defined*. + (with-system-definitions () + (let* ((name (coerce-name name)) + (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) + (registered (system-registered-p name)) + (registered! (if registered + (rplaca registered (get-file-stamp source-file)) + (register-system + (make-instance 'system :name name :source-file source-file)))) + (system (reset-system (cdr registered!) + :name name :source-file source-file)) + (component-options (remove-plist-key :class options)) + (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect + (resolve-dependency-spec nil spec)))) + (setf (gethash name *systems-being-defined*) system) + (apply 'load-systems defsystem-dependencies) + ;; We change-class AFTER we loaded the defsystem-depends-on + ;; since the class might be defined as part of those. + (let ((class (class-for-type nil class))) + (unless (subtypep class 'system) + (error 'non-system-system :name name :class-name (class-name class))) + (unless (eq (type-of system) class) + (change-class system class))) + (parse-component-form + nil (list* + :module name + :pathname (determine-system-directory pathname) + component-options))))) - (defun* (inherit-source-registry) (inherit &key register) - (when inherit - (process-source-registry (first inherit) :register register :inherit (rest inherit)))) + (defmacro defsystem (name &body options) + `(apply 'register-system-definition ',name ',options))) +;;;; ------------------------------------------------------------------------- +;;;; ASDF-Bundle - (defun* (process-source-registry-directive) (directive &key inherit register) - (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) - (ecase kw - ((:include) - (destructuring-bind (pathname) rest - (process-source-registry (resolve-location pathname) :inherit nil :register register))) - ((:directory) - (destructuring-bind (pathname) rest - (when pathname - (funcall register (resolve-location pathname :ensure-directory t))))) - ((:tree) - (destructuring-bind (pathname) rest - (when pathname - (funcall register (resolve-location pathname :ensure-directory t) - :recurse t :exclude *source-registry-exclusions*)))) - ((:exclude) - (setf *source-registry-exclusions* rest)) - ((:also-exclude) - (appendf *source-registry-exclusions* rest)) - ((:default-registry) - (inherit-source-registry '(default-source-registry) :register register)) - ((:inherit-configuration) - (inherit-source-registry inherit :register register)) - ((:ignore-inherited-configuration) - nil))) - nil) +(asdf/package:define-package :asdf/bundle + (:recycle :asdf/bundle :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation + :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) + (:export + #:bundle-op #:bundle-op-build-args #:bundle-type + #:bundle-system #:bundle-pathname-type #:bundlable-file-p #:direct-dependency-files + #:monolithic-op #:monolithic-bundle-op #:operation-monolithic-p + #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op + #:lib-op #:monolithic-lib-op + #:dll-op #:monolithic-dll-op + #:binary-op #:monolithic-binary-op + #:program-op #:compiled-file #:precompiled-system #:prebuilt-system + #:user-system-p #:user-system #:trivial-system-p + #+ecl #:make-build + #:register-pre-built-system + #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library)) +(in-package :asdf/bundle) - (defmethod process-source-registry ((x symbol) &key inherit register) - (process-source-registry (funcall x) :inherit inherit :register register)) - (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register) - (cond - ((directory-pathname-p pathname) - (let ((*here-directory* (resolve-symlinks* pathname))) - (process-source-registry (validate-source-registry-directory pathname) - :inherit inherit :register register))) - ((probe-file* pathname :truename *resolve-symlinks*) - (let ((*here-directory* (pathname-directory-pathname pathname))) - (process-source-registry (validate-source-registry-file pathname) - :inherit inherit :register register))) - (t - (inherit-source-registry inherit :register register)))) - (defmethod process-source-registry ((string string) &key inherit register) - (process-source-registry (parse-source-registry-string string) - :inherit inherit :register register)) - (defmethod process-source-registry ((x null) &key inherit register) - (declare (ignorable x)) - (inherit-source-registry inherit :register register)) - (defmethod process-source-registry ((form cons) &key inherit register) - (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) - (dolist (directive (cdr (validate-source-registry-form form))) - (process-source-registry-directive directive :inherit inherit :register register)))) +(with-upgradability () + (defclass bundle-op (operation) + ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) + (name-suffix :initarg :name-suffix :initform nil) + (bundle-type :initform :no-output-file :reader bundle-type) + #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files) + #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) + #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) - (defun flatten-source-registry (&optional parameter) - (remove-duplicates - (while-collecting (collect) - (with-pathname-defaults () ;; be location-independent - (inherit-source-registry - `(wrapping-source-registry - ,parameter - ,@*default-source-registries*) - :register #'(lambda (directory &key recurse exclude) - (collect (list directory :recurse recurse :exclude exclude)))))) - :test 'equal :from-end t)) + (defclass bundle-compile-op (bundle-op basic-compile-op) + () + (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files")) - ;; Will read the configuration and initialize all internal variables. - (defun compute-source-registry (&optional parameter (registry *source-registry*)) - (dolist (entry (flatten-source-registry parameter)) - (destructuring-bind (directory &key recurse exclude) entry - (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates - (register-asd-directory - directory :recurse recurse :exclude exclude :collect - #'(lambda (asd) - (let* ((name (pathname-name asd)) - (name (if (typep asd 'logical-pathname) - ;; logical pathnames are upper-case, - ;; at least in the CLHS and on SBCL, - ;; yet (coerce-name :foo) is lower-case. - ;; won't work well with (load-system "Foo") - ;; instead of (load-system 'foo) - (string-downcase name) - name))) - (cond - ((gethash name registry) ; already shadowed by something else - nil) - ((gethash name h) ; conflict at current level - (when *verbose-out* - (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~ - found several entries for ~A - picking ~S over ~S~:>") - directory recurse name (gethash name h) asd))) - (t - (setf (gethash name registry) asd) - (setf (gethash name h) asd)))))) - h))) - (values)) + ;; create a single fasl for the entire library + (defclass basic-fasl-op (bundle-compile-op) + ((bundle-type :initform :fasl))) + (defclass prepare-fasl-op (sideway-operation) + ((sideway-operation :initform 'load-fasl-op))) + (defclass fasl-op (basic-fasl-op selfward-operation) + ((selfward-operation :initform '(prepare-fasl-op #+ecl lib-op)))) + (defclass load-fasl-op (basic-load-op selfward-operation) + ((selfward-operation :initform '(prepare-op fasl-op)))) + + ;; NB: since the monolithic-op's can't be sideway-operation's, + ;; if we wanted lib-op, dll-op, binary-op to be sideway-operation's, + ;; we'd have to have the monolithic-op not inherit from the main op, + ;; but instead inherit from a basic-FOO-op as with basic-fasl-op above. + + (defclass lib-op (bundle-compile-op) + ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) + (:documentation #+(or ecl mkcl) "compile the system and produce linkable (.a) library for it." + #-(or ecl mkcl) "just compile the system")) + + (defclass dll-op (bundle-op basic-compile-op) + ((bundle-type :initform :dll)) + (:documentation "Link together all the dynamic library used by this system into a single one.")) + + (defclass binary-op (basic-compile-op selfward-operation) + ((selfward-operation :initform '(fasl-op lib-op))) + (:documentation "produce fasl and asd files for the system")) - (defvar *source-registry-parameter* nil) + (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies - (defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) - ;; Record the parameter used to configure the registry - (setf *source-registry-parameter* parameter) - ;; Clear the previous registry database: - (setf *source-registry* (make-hash-table :test 'equal)) - ;; Do it! - (compute-source-registry parameter)) + (defclass monolithic-bundle-op (monolithic-op bundle-op) + ((prologue-code :accessor monolithic-op-prologue-code) + (epilogue-code :accessor monolithic-op-epilogue-code))) - ;; Checks an initial variable to see whether the state is initialized - ;; or cleared. In the former case, return current configuration; in - ;; the latter, initialize. ASDF will call this function at the start - ;; of (asdf:find-system) to make sure the source registry is initialized. - ;; However, it will do so *without* a parameter, at which point it - ;; will be too late to provide a parameter to this function, though - ;; you may override the configuration explicitly by calling - ;; initialize-source-registry directly with your parameter. - (defun ensure-source-registry (&optional parameter) - (unless (source-registry-initialized-p) - (initialize-source-registry parameter)) - (values)) + (defclass monolithic-bundle-compile-op (monolithic-bundle-op bundle-compile-op) + () + (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files over all systems")) - (defun sysdef-source-registry-search (system) - (ensure-source-registry) - (values (gethash (primary-system-name system) *source-registry*)))) + (defclass monolithic-binary-op (monolithic-op binary-op) + ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op))) + (:documentation "produce fasl and asd files for combined system and dependencies.")) + (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) () + (:documentation "Create a single fasl for the system and its dependencies.")) -;;;; ------------------------------------------------------------------------- -;;; Internal hacks for backward-compatibility + (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op) + ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file)) + (:documentation #+(or ecl mkcl) "Create a single linkable library for the system and its dependencies." + #-(or ecl mkcl) "Compile a system and its dependencies.")) -(asdf/package:define-package :asdf/backward-internals - (:recycle :asdf/backward-internals :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/system :asdf/component :asdf/operation - :asdf/find-system :asdf/action :asdf/lisp-action) - (:export ;; for internal use - #:load-sysdef #:make-temporary-package - #:%refresh-component-inline-methods - #:%resolve-if-component-dep-fails - #:make-sub-operation - #:load-sysdef #:make-temporary-package)) -(in-package :asdf/backward-internals) + (defclass monolithic-dll-op (monolithic-bundle-op basic-compile-op sideway-operation selfward-operation) + ((bundle-type :initform :dll) + (selfward-operation :initform 'dll-op) + (sideway-operation :initform 'dll-op))) -;;;; Backward compatibility with "inline methods" -(with-upgradability () - (defparameter +asdf-methods+ - '(perform-with-restarts perform explain output-files operation-done-p)) + (defclass program-op #+(or mkcl ecl) (monolithic-bundle-compile-op) + #-(or mkcl ecl) (monolithic-bundle-op selfward-operation) + ((bundle-type :initform :program) + #-(or mkcl ecl) (selfward-operation :initform #-(or mkcl ecl) 'load-op)) + (:documentation "create an executable file from the system and its dependencies")) - (defun %remove-component-inline-methods (component) - (dolist (name +asdf-methods+) - (map () - ;; this is inefficient as most of the stored - ;; methods will not be for this particular gf - ;; But this is hardly performance-critical - #'(lambda (m) - (remove-method (symbol-function name) m)) - (component-inline-methods component))) - (component-inline-methods component) nil) + (defun bundle-pathname-type (bundle-type) + (etypecase bundle-type + ((eql :no-output-file) nil) ;; should we error out instead? + ((or null string) bundle-type) + ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") + #+ecl + ((member :binary :dll :lib :static-library :program :object :program) + (compile-file-type :type bundle-type)) + ((eql :binary) "image") + ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll"))) + ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib"))) + ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) - (defun %define-component-inline-methods (ret rest) - (dolist (name +asdf-methods+) - (let ((keyword (intern (symbol-name name) :keyword))) - (loop :for data = rest :then (cddr data) - :for key = (first data) - :for value = (second data) - :while data - :when (eq key keyword) :do - (destructuring-bind (op qual? &rest rest) value - (multiple-value-bind (qual args-and-body) - (if (symbolp qual?) - (values (list qual?) rest) - (values nil (cons qual? rest))) - (destructuring-bind ((o c) &body body) args-and-body - (pushnew - (eval `(defmethod ,name ,@qual ((,o ,op) (,c (eql ,ret))) - ,@body)) - (component-inline-methods ret))))))))) + (defun bundle-output-files (o c) + (when (input-files o c) + (let ((bundle-type (bundle-type o))) + (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type. + (let ((name (or (component-build-pathname c) + (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) + (type (bundle-pathname-type bundle-type))) + (values (list (subpathname (component-pathname c) name :type type)) + (eq (type-of o) (component-build-operation c)))))))) - (defun %refresh-component-inline-methods (component rest) - ;; clear methods, then add the new ones - (%remove-component-inline-methods component) - (%define-component-inline-methods component rest))) + (defmethod output-files ((o bundle-op) (c system)) + (bundle-output-files o c)) -;;;; PARTIAL SUPPORT for the :if-component-dep-fails component attribute -;; and the companion asdf:feature pseudo-dependency. -;; This won't recurse into dependencies to accumulate feature conditions. -;; Therefore it will accept the SB-ROTATE-BYTE of an old SBCL -;; (older than 1.1.2.20-fe6da9f) but won't suffice to load an old nibbles. + #-(or ecl mkcl) + (defmethod perform ((o program-op) (c system)) + (let ((output-file (output-file o c))) + (setf *image-entry-point* (ensure-function (component-entry-point c))) + (dump-image output-file :executable t))) + + (defclass compiled-file (file-component) + ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) + + (defclass precompiled-system (system) + ((build-pathname :initarg :fasl))) + + (defclass prebuilt-system (system) + ((build-pathname :initarg :static-library :initarg :lib + :accessor prebuilt-system-static-library)))) + + +;;; +;;; BUNDLE-OP +;;; +;;; This operation takes all components from one or more systems and +;;; creates a single output file, which may be +;;; a FASL, a statically linked library, a shared library, etc. +;;; The different targets are defined by specialization. +;;; (with-upgradability () - (defun %resolve-if-component-dep-fails (if-component-dep-fails component) - (asdf-message "The system definition for ~S uses deprecated ~ - ASDF option :IF-COMPONENT-DEP-DAILS. ~ - Starting with ASDF 3, please use :IF-FEATURE instead" - (coerce-name (component-system component))) - ;; This only supports the pattern of use of the "feature" seen in the wild - (check-type component parent-component) - (check-type if-component-dep-fails (member :fail :ignore :try-next)) - (unless (eq if-component-dep-fails :fail) - (loop :with o = (make-operation 'compile-op) - :for c :in (component-children component) :do - (loop* :for (feature? feature) :in (component-depends-on o c) - :when (eq feature? 'feature) :do - (setf (component-if-feature c) feature)))))) + (defun operation-monolithic-p (op) + (typep op 'monolithic-op)) -(when-upgrading (:when (fboundp 'make-sub-operation)) - (defun make-sub-operation (c o dep-c dep-o) - (declare (ignore c o dep-c dep-o)) (asdf-upgrade-error))) + (defmethod initialize-instance :after ((instance bundle-op) &rest initargs + &key (name-suffix nil name-suffix-p) + &allow-other-keys) + (declare (ignorable initargs name-suffix)) + (unless name-suffix-p + (setf (slot-value instance 'name-suffix) + (unless (typep instance 'program-op) + (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames + (when (typep instance 'monolithic-bundle-op) + (destructuring-bind (&rest original-initargs + &key lisp-files prologue-code epilogue-code + &allow-other-keys) + (operation-original-initargs instance) + (setf (operation-original-initargs instance) + (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs) + (monolithic-op-prologue-code instance) prologue-code + (monolithic-op-epilogue-code instance) epilogue-code) + #-ecl (assert (null (or lisp-files epilogue-code prologue-code))) + #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) + (setf (bundle-op-build-args instance) + (remove-plist-keys '(:type :monolithic :name-suffix) + (operation-original-initargs instance)))) + + (defmethod bundle-op-build-args :around ((o lib-op)) + (declare (ignorable o)) + (let ((args (call-next-method))) + (remf args :ld-flags) + args)) + + (defun bundlable-file-p (pathname) + (let ((type (pathname-type pathname))) + (declare (ignorable type)) + (or #+ecl (or (equalp type (compile-file-type :type :object)) + (equalp type (compile-file-type :type :static-library))) + #+mkcl (equalp type (compile-file-type :fasl-p nil)) + #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) + (defgeneric* (trivial-system-p) (component)) -;;;; load-sysdef + (defun user-system-p (s) + (and (typep s 'system) + (not (builtin-system-p s)) + (not (trivial-system-p s))))) + +(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) + (deftype user-system () '(and system (satisfies user-system-p)))) + +;;; +;;; First we handle monolithic bundles. +;;; These are standalone systems which contain everything, +;;; including other ASDF systems required by the current one. +;;; A PROGRAM is always monolithic. +;;; +;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL +;;; (with-upgradability () - (defun load-sysdef (name pathname) - (load-asd pathname :name name)) + (defmethod component-depends-on ((o bundle-compile-op) (c system)) + `(,(if (operation-monolithic-p o) + `(#-(or ecl mkcl) fasl-op #+(or ecl mkcl) lib-op + ,@(required-components c :other-systems t :component-type 'system + :goal-operation (find-operation o 'load-op) + :keep-operation 'compile-op)) + `(compile-op + ,@(required-components c :other-systems nil :component-type '(not system) + :goal-operation (find-operation o 'load-op) + :keep-operation 'compile-op))) + ,@(call-next-method))) - (defun make-temporary-package () - ;; For loading a .asd file, we dont't make a temporary package anymore, - ;; but use ASDF-USER. I'd like to have this function do this, - ;; but since whoever uses it is likely to delete-package the result afterwards, - ;; this would be a bad idea, so preserve the old behavior. - (make-package (fresh-package-name :prefix :asdf :index 0) :use '(:cl :asdf)))) + (defmethod component-depends-on :around ((o bundle-op) (c component)) + (declare (ignorable o c)) + (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c))) + `((,op ,c)) + (call-next-method))) + + (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) + ;; This file selects output files from direct dependencies; + ;; your component-depends-on method better gathered the correct dependencies in the correct order. + (while-collecting (collect) + (map-direct-dependencies + o c #'(lambda (sub-o sub-c) + (loop :for f :in (funcall key sub-o sub-c) + :when (funcall test f) :do (collect f)))))) + (defmethod input-files ((o bundle-compile-op) (c system)) + (unless (eq (bundle-type o) :no-output-file) + (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))) -;;;; ------------------------------------------------------------------------- -;;;; Defsystem + (defun select-bundle-operation (type &optional monolithic) + (ecase type + ((:binary) + (if monolithic 'monolithic-binary-op 'binary-op)) + ((:dll :shared-library) + (if monolithic 'monolithic-dll-op 'dll-op)) + ((:lib :static-library) + (if monolithic 'monolithic-lib-op 'lib-op)) + ((:fasl) + (if monolithic 'monolithic-fasl-op 'fasl-op)) + ((:program) + 'program-op))) -(asdf/package:define-package :asdf/defsystem - (:recycle :asdf/defsystem :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system :asdf/cache - :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate - :asdf/backward-internals) - (:export - #:defsystem #:register-system-definition - #:class-for-type #:*default-component-class* - #:determine-system-directory #:parse-component-form - #:duplicate-names #:sysdef-error-component #:check-component-input)) -(in-package :asdf/defsystem) + (defun make-build (system &rest args &key (monolithic nil) (type :fasl) + (move-here nil move-here-p) + &allow-other-keys) + (let* ((operation-name (select-bundle-operation type monolithic)) + (move-here-path (if (and move-here + (typep move-here '(or pathname string))) + (pathname move-here) + (system-relative-pathname system "asdf-output/"))) + (operation (apply #'operate operation-name + system + (remove-plist-keys '(:monolithic :type :move-here) args))) + (system (find-system system)) + (files (and system (output-files operation system)))) + (if (or move-here (and (null move-here-p) + (member operation-name '(:program :binary)))) + (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) + :for f :in files + :for new-f = (make-pathname :name (pathname-name f) + :type (pathname-type f) + :defaults dest-path) + :do (rename-file-overwriting-target f new-f) + :collect new-f) + files)))) + +;;; +;;; LOAD-FASL-OP +;;; +;;; This is like ASDF's LOAD-OP, but using monolithic fasl files. +;;; +(with-upgradability () + (defmethod component-depends-on ((o load-fasl-op) (c system)) + (declare (ignorable o)) + `((,o ,@(loop :for dep :in (component-sideway-dependencies c) + :collect (resolve-dependency-spec c dep))) + (,(if (user-system-p c) 'fasl-op 'load-op) ,c) + ,@(call-next-method))) + + (defmethod input-files ((o load-fasl-op) (c system)) + (when (user-system-p c) + (output-files (find-operation o 'fasl-op) c))) -;;; Pathname -(with-upgradability () - (defun determine-system-directory (pathname) - ;; The defsystem macro calls this function to determine - ;; the pathname of a system as follows: - ;; 1. if the pathname argument is an pathname object (NOT a namestring), - ;; that is already an absolute pathname, return it. - ;; 2. otherwise, the directory containing the LOAD-PATHNAME - ;; is considered (as deduced from e.g. *LOAD-PATHNAME*), and - ;; if it is indeed available and an absolute pathname, then - ;; the PATHNAME argument is normalized to a relative pathname - ;; as per PARSE-UNIX-NAMESTRING (with ENSURE-DIRECTORY T) - ;; and merged into that DIRECTORY as per SUBPATHNAME. - ;; Note: avoid *COMPILE-FILE-PATHNAME* because .asd is loaded, - ;; and may be from within the EVAL-WHEN of a file compilation. - ;; If no absolute pathname was found, we return NIL. - (check-type pathname (or null string pathname)) - (pathname-directory-pathname - (resolve-symlinks* - (ensure-absolute-pathname - (parse-unix-namestring pathname :type :directory) - #'(lambda () (ensure-absolute-pathname - (load-pathname) 'get-pathname-defaults nil)) - nil))))) + (defmethod perform ((o load-fasl-op) c) + (declare (ignorable o c)) + nil) + (defmethod perform ((o load-fasl-op) (c system)) + (when (input-files o c) + (perform-lisp-load-fasl o c))) -;;; Component class -(with-upgradability () - (defvar *default-component-class* 'cl-source-file) + (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) + (mark-operation-done (find-operation o 'load-op) c))) - (defun class-for-type (parent type) - (or (loop :for symbol :in (list - type - (find-symbol* type *package* nil) - (find-symbol* type :asdf/interface nil) - (and (stringp type) (safe-read-from-string type :package :asdf/interface))) - :for class = (and symbol (symbolp symbol) (find-class* symbol nil)) - :when (and class - (#-cormanlisp subtypep #+cormanlisp cl::subclassp - class (find-class* 'component))) - :return class) - (and (eq type :file) - (find-class* - (or (loop :for p = parent :then (component-parent p) :while p - :thereis (module-default-component-class p)) - *default-component-class*) nil)) - (sysdef-error "don't recognize component type ~A" type)))) +;;; +;;; PRECOMPILED FILES +;;; +;;; This component can be used to distribute ASDF systems in precompiled form. +;;; Only useful when the dependencies have also been precompiled. +;;; +(with-upgradability () + (defmethod trivial-system-p ((s system)) + (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) + (defmethod output-files (o (c compiled-file)) + (declare (ignorable o c)) + nil) + (defmethod input-files (o (c compiled-file)) + (declare (ignorable o)) + (component-pathname c)) + (defmethod perform ((o load-op) (c compiled-file)) + (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)) + (perform (find-operation o 'load-op) c)) + (defmethod perform ((o operation) (c compiled-file)) + (declare (ignorable o c)) + nil)) -;;; Check inputs +;;; +;;; Pre-built systems +;;; (with-upgradability () - (define-condition duplicate-names (system-definition-error) - ((name :initarg :name :reader duplicate-names-name)) - (:report (lambda (c s) - (format s (compatfmt "~@<Error while defining system: multiple components are given same name ~S~@:>") - (duplicate-names-name c))))) + (defmethod trivial-system-p ((s prebuilt-system)) + (declare (ignorable s)) + t) - (defun sysdef-error-component (msg type name value) - (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) - type name value)) + (defmethod perform ((o lib-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) - (defun check-component-input (type name weakly-depends-on - depends-on components) - "A partial test of the values of a component." - (unless (listp depends-on) - (sysdef-error-component ":depends-on must be a list." - type name depends-on)) - (unless (listp weakly-depends-on) - (sysdef-error-component ":weakly-depends-on must be a list." - type name weakly-depends-on)) - (unless (listp components) - (sysdef-error-component ":components must be NIL or a list of components." - type name components))) + (defmethod component-depends-on ((o lib-op) (c prebuilt-system)) + (declare (ignorable o c)) + nil) - (defun* (normalize-version) (form &key pathname component parent) - (labels ((invalid (&optional (continuation "using NIL instead")) - (warn (compatfmt "~@<Invalid :version specifier ~S~@[ for component ~S~]~@[ in ~S~]~@[ from file ~S~]~@[, ~A~]~@:>") - form component parent pathname continuation)) - (invalid-parse (control &rest args) - (unless (builtin-system-p (find-component parent component)) - (apply 'warn control args) - (invalid)))) - (if-let (v (typecase form - ((or string null) form) - (real - (invalid "Substituting a string") - (format nil "~D" form)) ;; 1.0 becomes "1.0" - (cons - (case (first form) - ((:read-file-form) - (destructuring-bind (subpath &key (at 0)) (rest form) - (safe-read-file-form (subpathname pathname subpath) :at at :package :asdf-user))) - ((:read-file-line) - (destructuring-bind (subpath &key (at 0)) (rest form) - (read-file-lines (subpathname pathname subpath) :at at))) - (otherwise - (invalid)))) - (t - (invalid)))) - (if-let (pv (parse-version v #'invalid-parse)) - (unparse-version pv) - (invalid)))))) + (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system)) + (declare (ignorable o)) + nil)) -;;; Main parsing function +;;; +;;; PREBUILT SYSTEM CREATOR +;;; (with-upgradability () - (defun* (parse-component-form) (parent options &key previous-serial-component) - (destructuring-bind - (type name &rest rest &key - (builtin-system-p () bspp) - ;; the following list of keywords is reproduced below in the - ;; remove-plist-keys form. important to keep them in sync - components pathname perform explain output-files operation-done-p - weakly-depends-on depends-on serial - do-first if-component-dep-fails version - ;; list ends - &allow-other-keys) options - (declare (ignorable perform explain output-files operation-done-p builtin-system-p)) - (check-component-input type name weakly-depends-on depends-on components) - (when (and parent - (find-component parent name) - (not ;; ignore the same object when rereading the defsystem - (typep (find-component parent name) - (class-for-type parent type)))) - (error 'duplicate-names :name name)) - (when do-first (error "DO-FIRST is not supported anymore as of ASDF 3")) - (let* ((args `(:name ,(coerce-name name) - :pathname ,pathname - ,@(when parent `(:parent ,parent)) - ,@(remove-plist-keys - '(:components :pathname :if-component-dep-fails :version - :perform :explain :output-files :operation-done-p - :weakly-depends-on :depends-on :serial) - rest))) - (component (find-component parent name))) - (when weakly-depends-on - ;; ASDF4: deprecate this feature and remove it. - (appendf depends-on - (remove-if (complement #'(lambda (x) (find-system x nil))) weakly-depends-on))) - (when previous-serial-component - (push previous-serial-component depends-on)) - (if component ; preserve identity - (apply 'reinitialize-instance component args) - (setf component (apply 'make-instance (class-for-type parent type) args))) - (component-pathname component) ; eagerly compute the absolute pathname - (let ((sysfile (system-source-file (component-system component)))) ;; requires the previous - (when (and (typep component 'system) (not bspp)) - (setf (builtin-system-p component) (lisp-implementation-pathname-p sysfile))) - (setf version (normalize-version version :component name :parent parent :pathname sysfile))) - ;; Don't use the accessor: kluge to avoid upgrade issue on CCL 1.8. - ;; A better fix is required. - (setf (slot-value component 'version) version) - (when (typep component 'parent-component) - (setf (component-children component) - (loop - :with previous-component = nil - :for c-form :in components - :for c = (parse-component-form component c-form - :previous-serial-component previous-component) - :for name = (component-name c) - :collect c - :when serial :do (setf previous-component name))) - (compute-children-by-name component)) - ;; Used by POIU. ASDF4: rename to component-depends-on? - (setf (component-sibling-dependencies component) depends-on) - (%refresh-component-inline-methods component rest) - (when if-component-dep-fails - (%resolve-if-component-dep-fails if-component-dep-fails component)) - component))) - - (defun register-system-definition - (name &rest options &key pathname (class 'system) (source-file () sfp) - defsystem-depends-on &allow-other-keys) - ;; The system must be registered before we parse the body, - ;; otherwise we recur when trying to find an existing system - ;; of the same name to reuse options (e.g. pathname) from. - ;; To avoid infinite recursion in cases where you defsystem a system - ;; that is registered to a different location to find-system, - ;; we also need to remember it in a special variable *systems-being-defined*. - (with-system-definitions () - (let* ((name (coerce-name name)) - (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) - (registered (system-registered-p name)) - (registered! (if registered - (rplaca registered (get-file-stamp source-file)) - (register-system - (make-instance 'system :name name :source-file source-file)))) - (system (reset-system (cdr registered!) - :name name :source-file source-file)) - (component-options (remove-plist-key :class options)) - (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect - (resolve-dependency-spec nil spec)))) - (setf (gethash name *systems-being-defined*) system) - (apply 'load-systems defsystem-dependencies) - ;; We change-class AFTER we loaded the defsystem-depends-on - ;; since the class might be defined as part of those. - (let ((class (class-for-type nil class))) - (unless (eq (type-of system) class) - (change-class system class))) - (parse-component-form - nil (list* - :module name - :pathname (determine-system-directory pathname) - component-options))))) + (defmethod output-files ((o binary-op) (s system)) + (list (make-pathname :name (component-name s) :type "asd" + :defaults (component-pathname s)))) - (defmacro defsystem (name &body options) - `(apply 'register-system-definition ',name ',options))) -;;;; ------------------------------------------------------------------------- -;;;; ASDF-Bundle + (defmethod perform ((o binary-op) (s system)) + (let* ((inputs (input-files o s)) + (fasl (first inputs)) + (library (second inputs)) + (asd (first (output-files o s))) + (name (if (and fasl asd) (pathname-name asd) (return-from perform))) + (dependencies + (if (operation-monolithic-p o) + (remove-if-not 'builtin-system-p + (required-components s :component-type 'system + :keep-operation 'load-op)) + (while-collecting (x) ;; resolve the sideway-dependencies of s + (map-direct-dependencies + 'load-op s + #'(lambda (o c) + (when (and (typep o 'load-op) (typep c 'system)) + (x c))))))) + (depends-on (mapcar 'coerce-name dependencies))) + (when (pathname-equal asd (system-source-file s)) + (cerror "overwrite the asd file" + "~/asdf-action:format-action/ is going to overwrite the system definition file ~S which is probably not what you want; you probably need to tweak your output translations." + (cons o s) asd)) + (with-open-file (s asd :direction :output :if-exists :supersede + :if-does-not-exist :create) + (format s ";;; Prebuilt~:[~; monolithic~] ASDF definition for system ~A~%" + (operation-monolithic-p o) name) + (format s ";;; Built for ~A ~A on a ~A/~A ~A~%" + (lisp-implementation-type) + (lisp-implementation-version) + (software-type) + (machine-type) + (software-version)) + (let ((*package* (find-package :asdf-user))) + (pprint `(defsystem ,name + :class prebuilt-system + :depends-on ,depends-on + :components ((:compiled-file ,(pathname-name fasl))) + ,@(when library `(:lib ,(file-namestring library)))) + s) + (terpri s))))) -(asdf/package:define-package :asdf/bundle - (:recycle :asdf/bundle :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation - :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) - (:export - #:bundle-op #:bundle-op-build-args #:bundle-type #:bundle-system #:bundle-pathname-type - #:fasl-op #:load-fasl-op #:lib-op #:dll-op #:binary-op - #:monolithic-op #:monolithic-bundle-op #:bundlable-file-p #:direct-dependency-files - #:monolithic-binary-op #:monolithic-fasl-op #:monolithic-lib-op #:monolithic-dll-op - #:program-op - #:compiled-file #:precompiled-system #:prebuilt-system - #:operation-monolithic-p - #:user-system-p #:user-system #:trivial-system-p - #+ecl #:make-build - #:register-pre-built-system - #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library)) -(in-package :asdf/bundle) + #-(or ecl mkcl) + (defmethod perform ((o bundle-compile-op) (c system)) + (let* ((input-files (input-files o c)) + (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) + (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) + (output-files (output-files o c)) + (output-file (first output-files))) + (assert (eq (not input-files) (not output-files))) + (when input-files + (when non-fasl-files + (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S" + (implementation-type) non-fasl-files)) + (when (and (typep o 'monolithic-bundle-op) + (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o))) + (error "prologue-code and epilogue-code are not supported on ~A" + (implementation-type))) + (with-staging-pathname (output-file) + (combine-fasls fasl-files output-file))))) -(with-upgradability () - (defclass bundle-op (operation) - ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) - (name-suffix :initarg :name-suffix :initform nil) - (bundle-type :initform :no-output-file :reader bundle-type) - #+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files) - #+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p) - #+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p))) + (defmethod input-files ((o load-op) (s precompiled-system)) + (declare (ignorable o)) + (bundle-output-files (find-operation o 'fasl-op) s)) - (defclass fasl-op (bundle-op) - ;; create a single fasl for the entire library - ((bundle-type :initform :fasl))) + (defmethod perform ((o load-op) (s precompiled-system)) + (perform-lisp-load-fasl o s)) - (defclass load-fasl-op (basic-load-op) - ;; load a single fasl for the entire library - ()) + (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) + (declare (ignorable o)) + `((load-op ,s) ,@(call-next-method)))) - (defclass lib-op (bundle-op) - ;; On ECL: compile the system and produce linkable .a library for it. - ;; On others: just compile the system. - ((bundle-type :initform #+(or ecl mkcl) :lib #-(or ecl mkcl) :no-output-file))) + #| ;; Example use: +(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) +(asdf:load-system :precompiled-asdf-utils) +|# - (defclass dll-op (bundle-op) - ;; Link together all the dynamic library used by this system into a single one. - ((bundle-type :initform :dll))) +#+(or ecl mkcl) +(with-upgradability () + (defun uiop-library-file () + (or (and (find-system :uiop nil) + (system-source-directory :uiop) + (progn + (operate 'lib-op :uiop) + (output-file 'lib-op :uiop))) + (resolve-symlinks* (c::compile-file-pathname "sys:asdf" :type :lib)))) + (defmethod input-files :around ((o program-op) (c system)) + (let ((files (call-next-method)) + (plan (traverse-sub-actions o c :plan-class 'sequential-plan))) + (unless (or (and (find-system :uiop nil) + (system-source-directory :uiop) + (plan-operates-on-p plan '("uiop"))) + (and (system-source-directory :asdf) + (plan-operates-on-p plan '("asdf")))) + (pushnew (uiop-library-file) files :test 'pathname-equal)) + files)) - (defclass binary-op (bundle-op) - ;; On ECL: produce lib and fasl for the system. - ;; On "normal" Lisps: produce just the fasl. - ()) + (defun register-pre-built-system (name) + (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))) - (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies +#+ecl +(with-upgradability () + (defmethod perform ((o bundle-compile-op) (c system)) + (let* ((object-files (input-files o c)) + (output (output-files o c)) + (bundle (first output)) + (kind (bundle-type o))) + (when output + (create-image + bundle (append object-files (bundle-op-lisp-files o)) + :kind kind + :entry-point (component-entry-point c) + :prologue-code + (when (typep o 'monolithic-bundle-op) + (monolithic-op-prologue-code o)) + :epilogue-code + (when (typep o 'monolithic-bundle-op) + (monolithic-op-epilogue-code o)) + :build-args (bundle-op-build-args o)))))) - (defclass monolithic-bundle-op (monolithic-op bundle-op) - ((prologue-code :accessor monolithic-op-prologue-code) - (epilogue-code :accessor monolithic-op-epilogue-code))) +#+mkcl +(with-upgradability () + (defmethod perform ((o lib-op) (s system)) + (apply #'compiler::build-static-library (output-file o c) + :lisp-object-files (input-files o s) (bundle-op-build-args o))) - (defclass monolithic-binary-op (binary-op monolithic-bundle-op) - ;; On ECL: produce lib and fasl for combined system and dependencies. - ;; On "normal" Lisps: produce an image file from system and dependencies. - ()) + (defmethod perform ((o basic-fasl-op) (s system)) + (apply #'compiler::build-bundle (output-file o c) ;; second??? + :lisp-object-files (input-files o s) (bundle-op-build-args o))) - (defclass monolithic-fasl-op (monolithic-bundle-op fasl-op) - ;; Create a single fasl for the system and its dependencies. - ()) + (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) + (declare (ignore force verbose version)) + (apply #'operate 'binary-op system args))) +;;;; ------------------------------------------------------------------------- +;;;; Concatenate-source + +(asdf/package:define-package :asdf/concatenate-source + (:recycle :asdf/concatenate-source :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + :asdf/component :asdf/operation + :asdf/system :asdf/find-system :asdf/defsystem + :asdf/action :asdf/lisp-action :asdf/bundle) + (:export + #:concatenate-source-op + #:load-concatenated-source-op + #:compile-concatenated-source-op + #:load-compiled-concatenated-source-op + #:monolithic-concatenate-source-op + #:monolithic-load-concatenated-source-op + #:monolithic-compile-concatenated-source-op + #:monolithic-load-compiled-concatenated-source-op)) +(in-package :asdf/concatenate-source) - (defclass monolithic-lib-op (monolithic-bundle-op lib-op) - ;; ECL: Create a single linkable library for the system and its dependencies. - ((bundle-type :initform :lib))) +;;; +;;; Concatenate sources +;;; +(with-upgradability () + (defclass basic-concatenate-source-op (bundle-op) + ((bundle-type :initform "lisp"))) + (defclass basic-load-concatenated-source-op (basic-load-op selfward-operation) ()) + (defclass basic-compile-concatenated-source-op (basic-compile-op selfward-operation) ()) + (defclass basic-load-compiled-concatenated-source-op (basic-load-op selfward-operation) ()) + + (defclass concatenate-source-op (basic-concatenate-source-op) ()) + (defclass load-concatenated-source-op (basic-load-concatenated-source-op) + ((selfward-operation :initform '(prepare-op concatenate-source-op)))) + (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op) + ((selfward-operation :initform '(prepare-op concatenate-source-op)))) + (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform '(prepare-op compile-concatenated-source-op)))) + + (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op) ()) + (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op) + ((selfward-operation :initform 'monolithic-concatenate-source-op))) + (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op) + ((selfward-operation :initform 'monolithic-concatenate-source-op))) + (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform 'monolithic-compile-concatenated-source-op))) + + (defmethod input-files ((operation basic-concatenate-source-op) (s system)) + (loop :with encoding = (or (component-encoding s) *default-encoding*) + :with other-encodings = '() + :with around-compile = (around-compile-hook s) + :with other-around-compile = '() + :for c :in (required-components + s :goal-operation 'compile-op + :keep-operation 'compile-op + :other-systems (operation-monolithic-p operation)) + :append + (when (typep c 'cl-source-file) + (let ((e (component-encoding c))) + (unless (equal e encoding) + (pushnew e other-encodings :test 'equal))) + (let ((a (around-compile-hook c))) + (unless (equal a around-compile) + (pushnew a other-around-compile :test 'equal))) + (input-files (make-operation 'compile-op) c)) :into inputs + :finally + (when other-encodings + (warn "~S uses encoding ~A but has sources that use these encodings: ~A" + operation encoding other-encodings)) + (when other-around-compile + (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" + operation around-compile other-around-compile)) + (return inputs))) + (defmethod output-files ((o basic-compile-concatenated-source-op) (s system)) + (lisp-compilation-output-files o s)) - (defclass monolithic-dll-op (monolithic-bundle-op dll-op) - ((bundle-type :initform :dll))) + (defmethod perform ((o basic-concatenate-source-op) (s system)) + (let ((inputs (input-files o s)) + (output (output-file o s))) + (concatenate-files inputs output))) + (defmethod perform ((o basic-load-concatenated-source-op) (s system)) + (perform-lisp-load-source o s)) + (defmethod perform ((o basic-compile-concatenated-source-op) (s system)) + (perform-lisp-compilation o s)) + (defmethod perform ((o basic-load-compiled-concatenated-source-op) (s system)) + (perform-lisp-load-fasl o s))) - (defclass program-op (monolithic-bundle-op) - ;; All: create an executable file from the system and its dependencies - ((bundle-type :initform :program))) +;;;; --------------------------------------------------------------------------- +;;;; asdf-output-translations - (defun bundle-pathname-type (bundle-type) - (etypecase bundle-type - ((eql :no-output-file) nil) ;; should we error out instead? - ((or null string) bundle-type) - ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") - #+ecl - ((member :binary :dll :lib :static-library :program :object :program) - (compile-file-type :type bundle-type)) - ((eql :binary) "image") - ((eql :dll) (cond ((os-unix-p) "so") ((os-windows-p) "dll"))) - ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib"))) - ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) +(asdf/package:define-package :asdf/output-translations + (:recycle :asdf/output-translations :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:export + #:*output-translations* #:*output-translations-parameter* + #:invalid-output-translation + #:output-translations #:output-translations-initialized-p + #:initialize-output-translations #:clear-output-translations + #:disable-output-translations #:ensure-output-translations + #:apply-output-translations + #:validate-output-translations-directive #:validate-output-translations-form + #:validate-output-translations-file #:validate-output-translations-directory + #:parse-output-translations-string #:wrapping-output-translations + #:user-output-translations-pathname #:system-output-translations-pathname + #:user-output-translations-directory-pathname #:system-output-translations-directory-pathname + #:environment-output-translations #:process-output-translations + #:compute-output-translations + #+abcl #:translate-jar-pathname + )) +(in-package :asdf/output-translations) - (defun bundle-output-files (o c) - (let ((bundle-type (bundle-type o))) - (unless (eq bundle-type :no-output-file) ;; NIL already means something regarding type. - (let ((name (or (component-build-pathname c) - (format nil "~A~@[~A~]" (component-name c) (slot-value o 'name-suffix)))) - (type (bundle-pathname-type bundle-type))) - (values (list (subpathname (component-pathname c) name :type type)) - (eq (type-of o) (component-build-operation c))))))) +(when-upgrading () (undefine-function '(setf output-translations))) - (defmethod output-files ((o bundle-op) (c system)) - (bundle-output-files o c)) +(with-upgradability () + (define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) - #-(or ecl mkcl) - (progn - (defmethod perform ((o program-op) (c system)) - (let ((output-file (output-file o c))) - (setf *image-entry-point* (ensure-function (component-entry-point c))) - (dump-image output-file :executable t))) + (defvar *output-translations* () + "Either NIL (for uninitialized), or a list of one element, +said element itself being a sorted list of mappings. +Each mapping is a pair of a source pathname and destination pathname, +and the order is by decreasing length of namestring of the source pathname.") - (defmethod perform ((o monolithic-binary-op) (c system)) - (let ((output-file (output-file o c))) - (dump-image output-file)))) + (defun output-translations () + (car *output-translations*)) - (defclass compiled-file (file-component) - ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) + (defun set-output-translations (new-value) + (setf *output-translations* + (list + (stable-sort (copy-list new-value) #'> + :key #'(lambda (x) + (etypecase (car x) + ((eql t) -1) + (pathname + (let ((directory (pathname-directory (car x)))) + (if (listp directory) (length directory) 0)))))))) + new-value) + #-gcl2.6 + (defun* ((setf output-translations)) (new-value) (set-output-translations new-value)) + #+gcl2.6 + (defsetf output-translations set-output-translations) - (defclass precompiled-system (system) - ((build-pathname :initarg :fasl))) + (defun output-translations-initialized-p () + (and *output-translations* t)) - (defclass prebuilt-system (system) - ((build-pathname :initarg :static-library :initarg :lib - :accessor prebuilt-system-static-library)))) + (defun clear-output-translations () + "Undoes any initialization of the output translations." + (setf *output-translations* '()) + (values)) + (register-clear-configuration-hook 'clear-output-translations) + (defun validate-output-translations-directive (directive) + (or (member directive '(:enable-user-cache :disable-cache nil)) + (and (consp directive) + (or (and (length=n-p directive 2) + (or (and (eq (first directive) :include) + (typep (second directive) '(or string pathname null))) + (and (location-designator-p (first directive)) + (or (location-designator-p (second directive)) + (location-function-p (second directive)))))) + (and (length=n-p directive 1) + (location-designator-p (first directive))))))) -;;; -;;; BUNDLE-OP -;;; -;;; This operation takes all components from one or more systems and -;;; creates a single output file, which may be -;;; a FASL, a statically linked library, a shared library, etc. -;;; The different targets are defined by specialization. -;;; -(with-upgradability () - (defun operation-monolithic-p (op) - (typep op 'monolithic-op)) + (defun validate-output-translations-form (form &key location) + (validate-configuration-form + form + :output-translations + 'validate-output-translations-directive + :location location :invalid-form-reporter 'invalid-output-translation)) - (defmethod initialize-instance :after ((instance bundle-op) &rest initargs - &key (name-suffix nil name-suffix-p) - &allow-other-keys) - (declare (ignorable initargs name-suffix)) - (unless name-suffix-p - (setf (slot-value instance 'name-suffix) - (unless (typep instance 'program-op) - (if (operation-monolithic-p instance) "--all-systems" #-ecl "--system")))) ; . no good for Logical Pathnames - (when (typep instance 'monolithic-bundle-op) - (destructuring-bind (&rest original-initargs - &key lisp-files prologue-code epilogue-code - &allow-other-keys) - (operation-original-initargs instance) - (setf (operation-original-initargs instance) - (remove-plist-keys '(:lisp-files :epilogue-code :prologue-code) original-initargs) - (monolithic-op-prologue-code instance) prologue-code - (monolithic-op-epilogue-code instance) epilogue-code) - #-ecl (assert (null (or lisp-files epilogue-code prologue-code))) - #+ecl (setf (bundle-op-lisp-files instance) lisp-files))) - (setf (bundle-op-build-args instance) - (remove-plist-keys '(:type :monolithic :name-suffix) - (operation-original-initargs instance)))) + (defun validate-output-translations-file (file) + (validate-configuration-file + file 'validate-output-translations-form :description "output translations")) - (defmethod bundle-op-build-args :around ((o lib-op)) - (declare (ignorable o)) - (let ((args (call-next-method))) - (remf args :ld-flags) - args)) + (defun validate-output-translations-directory (directory) + (validate-configuration-directory + directory :output-translations 'validate-output-translations-directive + :invalid-form-reporter 'invalid-output-translation)) - (defun bundlable-file-p (pathname) - (let ((type (pathname-type pathname))) - (declare (ignorable type)) - (or #+ecl (or (equalp type (compile-file-type :type :object)) - (equalp type (compile-file-type :type :static-library))) - #+mkcl (equalp type (compile-file-type :fasl-p nil)) - #+(or allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) + (defun parse-output-translations-string (string &key location) + (cond + ((or (null string) (equal string "")) + '(:output-translations :inherit-configuration)) + ((not (stringp string)) + (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string)) + ((eql (char string 0) #\") + (parse-output-translations-string (read-from-string string) :location location)) + ((eql (char string 0) #\() + (validate-output-translations-form (read-from-string string) :location location)) + (t + (loop + :with inherit = nil + :with directives = () + :with start = 0 + :with end = (length string) + :with source = nil + :with separator = (inter-directory-separator) + :for i = (or (position separator string :start start) end) :do + (let ((s (subseq string start i))) + (cond + (source + (push (list source (if (equal "" s) nil s)) directives) + (setf source nil)) + ((equal "" s) + (when inherit + (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") + string)) + (setf inherit t) + (push :inherit-configuration directives)) + (t + (setf source s))) + (setf start (1+ i)) + (when (> start end) + (when source + (error (compatfmt "~@<Uneven number of components in source to destination mapping: ~3i~_~S~@:>") + string)) + (unless inherit + (push :ignore-inherited-configuration directives)) + (return `(:output-translations ,@(nreverse directives))))))))) - (defgeneric* (trivial-system-p) (component)) + (defparameter *default-output-translations* + '(environment-output-translations + user-output-translations-pathname + user-output-translations-directory-pathname + system-output-translations-pathname + system-output-translations-directory-pathname)) - (defun user-system-p (s) - (and (typep s 'system) - (not (builtin-system-p s)) - (not (trivial-system-p s))))) + (defun wrapping-output-translations () + `(:output-translations + ;; Some implementations have precompiled ASDF systems, + ;; so we must disable translations for implementation paths. + #+(or #|clozure|# ecl mkcl sbcl) + ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) + (when h `(((,h ,*wild-path*) ())))) + #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) + ;; All-import, here is where we want user stuff to be: + :inherit-configuration + ;; These are for convenience, and can be overridden by the user: + #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + ;; We enable the user cache by default, and here is the place we do: + :enable-user-cache)) -(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) - (deftype user-system () '(and system (satisfies user-system-p)))) + (defparameter *output-translations-file* (parse-unix-namestring "asdf-output-translations.conf")) + (defparameter *output-translations-directory* (parse-unix-namestring "asdf-output-translations.conf.d/")) -;;; -;;; First we handle monolithic bundles. -;;; These are standalone systems which contain everything, -;;; including other ASDF systems required by the current one. -;;; A PROGRAM is always monolithic. -;;; -;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL -;;; -(with-upgradability () - (defmethod component-depends-on ((o monolithic-lib-op) (c system)) - (declare (ignorable o)) - `((lib-op ,@(required-components c :other-systems t :component-type 'system - :goal-operation 'load-op - :keep-operation 'compile-op)))) + (defun user-output-translations-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-file* :direction direction)) + (defun system-output-translations-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-file* :direction direction)) + (defun user-output-translations-directory-pathname (&key (direction :input)) + (in-user-configuration-directory *output-translations-directory* :direction direction)) + (defun system-output-translations-directory-pathname (&key (direction :input)) + (in-system-configuration-directory *output-translations-directory* :direction direction)) + (defun environment-output-translations () + (getenv "ASDF_OUTPUT_TRANSLATIONS")) - (defmethod component-depends-on ((o monolithic-fasl-op) (c system)) - (declare (ignorable o)) - `((fasl-op ,@(required-components c :other-systems t :component-type 'system - :goal-operation 'load-fasl-op - :keep-operation 'fasl-op)))) + (defgeneric process-output-translations (spec &key inherit collect)) - (defmethod component-depends-on ((o program-op) (c system)) - (declare (ignorable o)) - #+(or ecl mkcl) (component-depends-on (make-operation 'monolithic-lib-op) c) - #-(or ecl mkcl) `((load-op ,c))) + (defun inherit-output-translations (inherit &key collect) + (when inherit + (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) - (defmethod component-depends-on ((o binary-op) (c system)) - (declare (ignorable o)) - `((fasl-op ,c) - (lib-op ,c))) + (defun* (process-output-translations-directive) (directive &key inherit collect) + (if (atom directive) + (ecase directive + ((:enable-user-cache) + (process-output-translations-directive '(t :user-cache) :collect collect)) + ((:disable-cache) + (process-output-translations-directive '(t t) :collect collect)) + ((:inherit-configuration) + (inherit-output-translations inherit :collect collect)) + ((:ignore-inherited-configuration :ignore-invalid-entries nil) + nil)) + (let ((src (first directive)) + (dst (second directive))) + (if (eq src :include) + (when dst + (process-output-translations (pathname dst) :inherit nil :collect collect)) + (when src + (let ((trusrc (or (eql src t) + (let ((loc (resolve-location src :ensure-directory t :wilden t))) + (if (absolute-pathname-p loc) (resolve-symlinks* loc) loc))))) + (cond + ((location-function-p dst) + (funcall collect + (list trusrc + (if (symbolp (second dst)) + (fdefinition (second dst)) + (eval (second dst)))))) + ((eq dst t) + (funcall collect (list trusrc t))) + (t + (let* ((trudst (if dst + (resolve-location dst :ensure-directory t :wilden t) + trusrc))) + (funcall collect (list trudst t)) + (funcall collect (list trusrc trudst))))))))))) - (defmethod component-depends-on ((o monolithic-binary-op) (c system)) - `((,(find-operation o 'monolithic-fasl-op) ,c) - (,(find-operation o 'monolithic-lib-op) ,c))) + (defmethod process-output-translations ((x symbol) &key + (inherit *default-output-translations*) + collect) + (process-output-translations (funcall x) :inherit inherit :collect collect)) + (defmethod process-output-translations ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit collect) + (cond + ((directory-pathname-p pathname) + (process-output-translations (validate-output-translations-directory pathname) + :inherit inherit :collect collect)) + ((probe-file* pathname :truename *resolve-symlinks*) + (process-output-translations (validate-output-translations-file pathname) + :inherit inherit :collect collect)) + (t + (inherit-output-translations inherit :collect collect)))) + (defmethod process-output-translations ((string string) &key inherit collect) + (process-output-translations (parse-output-translations-string string) + :inherit inherit :collect collect)) + (defmethod process-output-translations ((x null) &key inherit collect) + (declare (ignorable x)) + (inherit-output-translations inherit :collect collect)) + (defmethod process-output-translations ((form cons) &key inherit collect) + (dolist (directive (cdr (validate-output-translations-form form))) + (process-output-translations-directive directive :inherit inherit :collect collect))) - (defmethod component-depends-on ((o lib-op) (c system)) - (declare (ignorable o)) - `((compile-op ,@(required-components c :other-systems nil :component-type '(not system) - :goal-operation 'load-op - :keep-operation 'compile-op)))) + (defun compute-output-translations (&optional parameter) + "read the configuration, return it" + (remove-duplicates + (while-collecting (c) + (inherit-output-translations + `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c)) + :test 'equal :from-end t)) - (defmethod component-depends-on ((o fasl-op) (c system)) - (declare (ignorable o)) - #+ecl `((lib-op ,c)) - #-ecl - (component-depends-on (find-operation o 'lib-op) c)) + (defvar *output-translations-parameter* nil) - (defmethod component-depends-on ((o dll-op) c) - (component-depends-on (find-operation o 'lib-op) c)) + (defun initialize-output-translations (&optional (parameter *output-translations-parameter*)) + "read the configuration, initialize the internal configuration variable, +return the configuration" + (setf *output-translations-parameter* parameter + (output-translations) (compute-output-translations parameter))) - (defmethod component-depends-on ((o bundle-op) c) - (declare (ignorable o c)) - nil) + (defun disable-output-translations () + "Initialize output translations in a way that maps every file to itself, +effectively disabling the output translation facility." + (initialize-output-translations + '(:output-translations :disable-cache :ignore-inherited-configuration))) - (defmethod component-depends-on :around ((o bundle-op) (c component)) - (declare (ignorable o c)) - (if-let (op (and (eq (type-of o) 'bundle-op) (component-build-operation c))) - `((,op ,c)) - (call-next-method))) + ;; checks an initial variable to see whether the state is initialized + ;; or cleared. In the former case, return current configuration; in + ;; the latter, initialize. ASDF will call this function at the start + ;; of (asdf:find-system). + (defun ensure-output-translations () + (if (output-translations-initialized-p) + (output-translations) + (initialize-output-translations))) - (defun direct-dependency-files (o c &key (test 'identity) (key 'output-files) &allow-other-keys) - (while-collecting (collect) - (map-direct-dependencies - o c #'(lambda (sub-o sub-c) - (loop :for f :in (funcall key sub-o sub-c) - :when (funcall test f) :do (collect f)))))) + (defun* (apply-output-translations) (path) + (etypecase path + (logical-pathname + path) + ((or pathname string) + (ensure-output-translations) + (loop* :with p = (resolve-symlinks* path) + :for (source destination) :in (car *output-translations*) + :for root = (when (or (eq source t) + (and (pathnamep source) + (not (absolute-pathname-p source)))) + (pathname-root p)) + :for absolute-source = (cond + ((eq source t) (wilden root)) + (root (merge-pathnames* source root)) + (t source)) + :when (or (eq source t) (pathname-match-p p absolute-source)) + :return (translate-pathname* p absolute-source destination root source) + :finally (return p))))) + + ;; Hook into asdf/driver's output-translation mechanism + #-cormanlisp + (setf *output-translation-function* 'apply-output-translations) - (defmethod input-files ((o bundle-op) (c system)) - (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files)) + #+abcl + (defun translate-jar-pathname (source wildcard) + (declare (ignore wildcard)) + (flet ((normalize-device (pathname) + (if (find :windows *features*) + pathname + (make-pathname :defaults pathname :device :unspecific)))) + (let* ((jar + (pathname (first (pathname-device source)))) + (target-root-directory-namestring + (format nil "/___jar___file___root___/~@[~A/~]" + (and (find :windows *features*) + (pathname-device jar)))) + (relative-source + (relativize-pathname-directory source)) + (relative-jar + (relativize-pathname-directory (ensure-directory-pathname jar))) + (target-root-directory + (normalize-device + (pathname-directory-pathname + (parse-namestring target-root-directory-namestring)))) + (target-root + (merge-pathnames* relative-jar target-root-directory)) + (target + (merge-pathnames* relative-source target-root))) + (normalize-device (apply-output-translations target)))))) - (defun select-bundle-operation (type &optional monolithic) - (ecase type - ((:binary) - (if monolithic 'monolithic-binary-op 'binary-op)) - ((:dll :shared-library) - (if monolithic 'monolithic-dll-op 'dll-op)) - ((:lib :static-library) - (if monolithic 'monolithic-lib-op 'lib-op)) - ((:fasl) - (if monolithic 'monolithic-fasl-op 'fasl-op)) - ((:program) - 'program-op))) +;;;; ------------------------------------------------------------------------- +;;; Backward-compatible interfaces - (defun make-build (system &rest args &key (monolithic nil) (type :fasl) - (move-here nil move-here-p) - &allow-other-keys) - (let* ((operation-name (select-bundle-operation type monolithic)) - (move-here-path (if (and move-here - (typep move-here '(or pathname string))) - (pathname move-here) - (system-relative-pathname system "asdf-output/"))) - (operation (apply #'operate operation-name - system - (remove-plist-keys '(:monolithic :type :move-here) args))) - (system (find-system system)) - (files (and system (output-files operation system)))) - (if (or move-here (and (null move-here-p) - (member operation-name '(:program :binary)))) - (loop :with dest-path = (resolve-symlinks* (ensure-directories-exist move-here-path)) - :for f :in files - :for new-f = (make-pathname :name (pathname-name f) - :type (pathname-type f) - :defaults dest-path) - :do (rename-file-overwriting-target f new-f) - :collect new-f) - files)))) +(asdf/package:define-package :asdf/backward-interface + (:recycle :asdf/backward-interface :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade + :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action + :asdf/lisp-action :asdf/operate :asdf/output-translations) + (:export + #:*asdf-verbose* + #:operation-error #:compile-error #:compile-failed #:compile-warned + #:error-component #:error-operation + #:component-load-dependencies + #:enable-asdf-binary-locations-compatibility + #:operation-forced + #:operation-on-failure #:operation-on-warnings #:on-failure #:on-warnings + #:component-property + #:run-shell-command + #:system-definition-pathname)) +(in-package :asdf/backward-interface) -;;; -;;; LOAD-FASL-OP -;;; -;;; This is like ASDF's LOAD-OP, but using monolithic fasl files. -;;; (with-upgradability () - (defmethod component-depends-on ((o load-fasl-op) (c system)) - (declare (ignorable o)) - `((,o ,@(loop :for dep :in (component-sibling-dependencies c) - :collect (resolve-dependency-spec c dep))) - (,(if (user-system-p c) 'fasl-op 'load-op) ,c) - ,@(call-next-method))) - - (defmethod input-files ((o load-fasl-op) (c system)) - (when (user-system-p c) - (output-files (find-operation o 'fasl-op) c))) + (define-condition operation-error (error) ;; Bad, backward-compatible name + ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel + ((component :reader error-component :initarg :component) + (operation :reader error-operation :initarg :operation)) + (:report (lambda (c s) + (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") + (type-of c) (error-operation c) (error-component c))))) + (define-condition compile-error (operation-error) ()) + (define-condition compile-failed (compile-error) ()) + (define-condition compile-warned (compile-error) ()) - (defmethod perform ((o load-fasl-op) c) - (declare (ignorable o c)) - nil) + (defun component-load-dependencies (component) + ;; Old deprecated name for the same thing. Please update your software. + (component-sideway-dependencies component)) - (defmethod perform ((o load-fasl-op) (c system)) - (perform-lisp-load-fasl o c)) + (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader. + (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) - (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) - (mark-operation-done (find-operation o 'load-op) c))) + (defgeneric operation-on-warnings (operation)) + (defgeneric operation-on-failure (operation)) + #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation)) + #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation)) + (defmethod operation-on-warnings ((o operation)) + (declare (ignorable o)) *compile-file-warnings-behaviour*) + (defmethod operation-on-failure ((o operation)) + (declare (ignorable o)) *compile-file-failure-behaviour*) + (defmethod (setf operation-on-warnings) (x (o operation)) + (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x)) + (defmethod (setf operation-on-failure) (x (o operation)) + (declare (ignorable o)) (setf *compile-file-failure-behaviour* x)) -;;; -;;; PRECOMPILED FILES -;;; -;;; This component can be used to distribute ASDF systems in precompiled form. -;;; Only useful when the dependencies have also been precompiled. -;;; -(with-upgradability () - (defmethod trivial-system-p ((s system)) - (every #'(lambda (c) (typep c 'compiled-file)) (component-children s))) + (defun system-definition-pathname (x) + ;; As of 2.014.8, we mean to make this function obsolete, + ;; but that won't happen until all clients have been updated. + ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" + "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. +It used to expose ASDF internals with subtle differences with respect to +user expectations, that have been refactored away since. +We recommend you use ASDF:SYSTEM-SOURCE-FILE instead +for a mostly compatible replacement that we're supporting, +or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME +if that's whay you mean." ;;) + (system-source-file x))) - (defmethod output-files (o (c compiled-file)) - (declare (ignorable o c)) - nil) - (defmethod input-files (o (c compiled-file)) - (declare (ignorable o)) - (component-pathname c)) - (defmethod perform ((o load-op) (c compiled-file)) - (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)) - (perform (find-operation o 'load-op) c)) - (defmethod perform ((o operation) (c compiled-file)) - (declare (ignorable o c)) - nil)) -;;; -;;; Pre-built systems -;;; +;;;; ASDF-Binary-Locations compatibility +;; This remains supported for legacy user, but not recommended for new users. (with-upgradability () - (defmethod trivial-system-p ((s prebuilt-system)) - (declare (ignorable s)) - t) - - (defmethod perform ((o lib-op) (c prebuilt-system)) - (declare (ignorable o c)) - nil) - - (defmethod component-depends-on ((o lib-op) (c prebuilt-system)) - (declare (ignorable o c)) - nil) + (defun enable-asdf-binary-locations-compatibility + (&key + (centralize-lisp-binaries nil) + (default-toplevel-directory + (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? + (include-per-user-information nil) + (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) + (source-to-target-mappings nil) + (file-types `(,(compile-file-type) + "build-report" + #+ecl (compile-file-type :type :object) + #+mkcl (compile-file-type :fasl-p nil) + #+clisp "lib" #+sbcl "cfasl" + #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) + #+(or clisp ecl mkcl) + (when (null map-all-source-files) + (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) + (let* ((patterns (if map-all-source-files (list *wild-file*) + (loop :for type :in file-types + :collect (make-pathname :type type :defaults *wild-file*)))) + (destination-directory + (if centralize-lisp-binaries + `(,default-toplevel-directory + ,@(when include-per-user-information + (cdr (pathname-directory (user-homedir-pathname)))) + :implementation ,*wild-inferiors*) + `(:root ,*wild-inferiors* :implementation)))) + (initialize-output-translations + `(:output-translations + ,@source-to-target-mappings + #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) + #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) + ,@(loop :for pattern :in patterns + :collect `((:root ,*wild-inferiors* ,pattern) + (,@destination-directory ,pattern))) + (t t) + :ignore-inherited-configuration)))) - (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system)) - (declare (ignorable o)) - nil)) + (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) + (declare (ignorable operation-class system args)) + (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) + (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. +ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, +which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, +and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. +In case you insist on preserving your previous A-B-L configuration, but +do not know how to achieve the same effect with A-O-T, you may use function +ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; +call that function where you would otherwise have loaded and configured A-B-L.")))) -;;; -;;; PREBUILT SYSTEM CREATOR -;;; +;;; run-shell-command +;; WARNING! The function below is not just deprecated but also dysfunctional. +;; Please use asdf/run-program:run-program instead. (with-upgradability () - (defmethod output-files ((o binary-op) (s system)) - (list (make-pathname :name (component-name s) :type "asd" - :defaults (component-pathname s)))) + (defun run-shell-command (control-string &rest args) + "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and +synchronously execute the result using a Bourne-compatible shell, with +output to *VERBOSE-OUT*. Returns the shell's exit code. - (defmethod perform ((o binary-op) (s system)) - (let* ((dependencies (component-depends-on o s)) - (fasl (first (apply #'output-files (first dependencies)))) - (library (first (apply #'output-files (second dependencies)))) - (asd (first (output-files o s))) - (name (pathname-name asd)) - (name-keyword (intern (string name) (find-package :keyword)))) - (with-open-file (s asd :direction :output :if-exists :supersede - :if-does-not-exist :create) - (format s ";;; Prebuilt ASDF definition for system ~A" name) - (format s ";;; Built for ~A ~A on a ~A/~A ~A" - (lisp-implementation-type) - (lisp-implementation-version) - (software-type) - (machine-type) - (software-version)) - (let ((*package* (find-package :keyword))) - (pprint `(defsystem ,name-keyword - :class prebuilt-system - :components ((:compiled-file ,(pathname-name fasl))) - :lib ,(and library (file-namestring library))) - s))))) +PLEASE DO NOT USE. +Deprecated function, for backward-compatibility only. +Please use UIOP:RUN-PROGRAM instead." + (let ((command (apply 'format nil control-string args))) + (asdf-message "; $ ~A~%" command) + (run-program command :force-shell t :ignore-error-status t :output *verbose-out*)))) - #-(or ecl mkcl) - (defmethod perform ((o fasl-op) (c system)) - (let* ((input-files (input-files o c)) - (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) - (non-fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test #'equalp)) - (output-files (output-files o c)) - (output-file (first output-files))) - (unless input-files (format t "WTF no input-files for ~S on ~S !???" o c)) - (when input-files - (assert output-files) - (when non-fasl-files - (error "On ~A, asdf-bundle can only bundle FASL files, but these were also produced: ~S" - (implementation-type) non-fasl-files)) - (when (and (typep o 'monolithic-bundle-op) - (or (monolithic-op-prologue-code o) (monolithic-op-epilogue-code o))) - (error "prologue-code and epilogue-code are not supported on ~A" - (implementation-type))) - (with-staging-pathname (output-file) - (combine-fasls fasl-files output-file))))) +(with-upgradability () + (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. - (defmethod input-files ((o load-op) (s precompiled-system)) - (declare (ignorable o)) - (bundle-output-files (find-operation o 'fasl-op) s)) +;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED. +(with-upgradability () + (defgeneric component-property (component property)) + (defgeneric (setf component-property) (new-value component property)) - (defmethod perform ((o load-op) (s precompiled-system)) - (perform-lisp-load-fasl o s)) + (defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) - (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) - (declare (ignorable o)) - `((load-op ,s) ,@(call-next-method)))) + (defmethod (setf component-property) (new-value (c component) property) + (let ((a (assoc property (slot-value c 'properties) :test #'equal))) + (if a + (setf (cdr a) new-value) + (setf (slot-value c 'properties) + (acons property new-value (slot-value c 'properties))))) + new-value)) +;;;; ----------------------------------------------------------------- +;;;; Source Registry Configuration, by Francois-Rene Rideau +;;;; See the Manual and https://bugs.launchpad.net/asdf/+bug/485918 - #| ;; Example use: -(asdf:defsystem :precompiled-asdf-utils :class asdf::precompiled-system :fasl (asdf:apply-output-translations (asdf:system-relative-pathname :asdf-utils "asdf-utils.system.fasl"))) -(asdf:load-system :precompiled-asdf-utils) -|# +(asdf/package:define-package :asdf/source-registry + (:recycle :asdf/source-registry :asdf) + (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system) + (:export + #:*source-registry-parameter* #:*default-source-registries* + #:invalid-source-registry + #:source-registry-initialized-p + #:initialize-source-registry #:clear-source-registry #:*source-registry* + #:ensure-source-registry #:*source-registry-parameter* + #:*default-source-registry-exclusions* #:*source-registry-exclusions* + #:*wild-asd* #:directory-asd-files #:register-asd-directory + #:collect-asds-in-directory #:collect-sub*directories-asd-files + #:validate-source-registry-directive #:validate-source-registry-form + #:validate-source-registry-file #:validate-source-registry-directory + #:parse-source-registry-string #:wrapping-source-registry #:default-source-registry + #:user-source-registry #:system-source-registry + #:user-source-registry-directory #:system-source-registry-directory + #:environment-source-registry #:process-source-registry + #:compute-source-registry #:flatten-source-registry + #:sysdef-source-registry-search)) +(in-package :asdf/source-registry) -#+ecl (with-upgradability () - (defmethod perform ((o bundle-op) (c system)) - (let* ((object-files (input-files o c)) - (output (output-files o c)) - (bundle (first output)) - (kind (bundle-type o))) - (create-image - bundle (append object-files (bundle-op-lisp-files o)) - :kind kind - :entry-point (component-entry-point c) - :prologue-code - (when (typep o 'monolithic-bundle-op) - (monolithic-op-prologue-code o)) - :epilogue-code - (when (typep o 'monolithic-bundle-op) - (monolithic-op-epilogue-code o)) - :build-args (bundle-op-build-args o))))) + (define-condition invalid-source-registry (invalid-configuration warning) + ((format :initform (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) -#+mkcl -(with-upgradability () - (defmethod perform ((o lib-op) (s system)) - (apply #'compiler::build-static-library (first output) - :lisp-object-files (input-files o s) (bundle-op-build-args o))) + ;; Using ack 1.2 exclusions + (defvar *default-source-registry-exclusions* + '(".bzr" ".cdv" + ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards + ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" + "_sgbak" "autom4te.cache" "cover_db" "_build" + "debian")) ;; debian often builds stuff under the debian directory... BAD. - (defmethod perform ((o fasl-op) (s system)) - (apply #'compiler::build-bundle (second output) - :lisp-object-files (input-files o s) (bundle-op-build-args o))) + (defvar *source-registry-exclusions* *default-source-registry-exclusions*) - (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) - (declare (ignore force verbose version)) - (apply #'operate 'binary-op system args))) + (defvar *source-registry* nil + "Either NIL (for uninitialized), or an equal hash-table, mapping +system names to pathnames of .asd files") -#+(or ecl mkcl) -(with-upgradability () - (defun register-pre-built-system (name) - (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))) + (defun source-registry-initialized-p () + (typep *source-registry* 'hash-table)) -;;;; ------------------------------------------------------------------------- -;;;; Concatenate-source + (defun clear-source-registry () + "Undoes any initialization of the source registry." + (setf *source-registry* nil) + (values)) + (register-clear-configuration-hook 'clear-source-registry) -(asdf/package:define-package :asdf/concatenate-source - (:recycle :asdf/concatenate-source :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/operation - :asdf/system :asdf/find-system :asdf/defsystem - :asdf/action :asdf/lisp-action :asdf/bundle) - (:export - #:concatenate-source-op - #:load-concatenated-source-op - #:compile-concatenated-source-op - #:load-compiled-concatenated-source-op - #:monolithic-concatenate-source-op - #:monolithic-load-concatenated-source-op - #:monolithic-compile-concatenated-source-op - #:monolithic-load-compiled-concatenated-source-op)) -(in-package :asdf/concatenate-source) + (defparameter *wild-asd* + (make-pathname* :directory nil :name *wild* :type "asd" :version :newest)) -;;; -;;; Concatenate sources -;;; -(with-upgradability () - (defclass concatenate-source-op (bundle-op) - ((bundle-type :initform "lisp"))) - (defclass load-concatenated-source-op (basic-load-op operation) - ((bundle-type :initform :no-output-file))) - (defclass compile-concatenated-source-op (basic-compile-op bundle-op) - ((bundle-type :initform :fasl))) - (defclass load-compiled-concatenated-source-op (basic-load-op operation) - ((bundle-type :initform :no-output-file))) + (defun directory-asd-files (directory) + (directory-files directory *wild-asd*)) - (defclass monolithic-concatenate-source-op (concatenate-source-op monolithic-op) ()) - (defclass monolithic-load-concatenated-source-op (load-concatenated-source-op monolithic-op) ()) - (defclass monolithic-compile-concatenated-source-op (compile-concatenated-source-op monolithic-op) ()) - (defclass monolithic-load-compiled-concatenated-source-op (load-compiled-concatenated-source-op monolithic-op) ()) + (defun collect-asds-in-directory (directory collect) + (map () collect (directory-asd-files directory))) - (defmethod input-files ((operation concatenate-source-op) (s system)) - (loop :with encoding = (or (component-encoding s) *default-encoding*) - :with other-encodings = '() - :with around-compile = (around-compile-hook s) - :with other-around-compile = '() - :for c :in (required-components - s :goal-operation 'compile-op - :keep-operation 'compile-op - :other-systems (operation-monolithic-p operation)) - :append - (when (typep c 'cl-source-file) - (let ((e (component-encoding c))) - (unless (equal e encoding) - (pushnew e other-encodings :test 'equal))) - (let ((a (around-compile-hook c))) - (unless (equal a around-compile) - (pushnew a other-around-compile :test 'equal))) - (input-files (make-operation 'compile-op) c)) :into inputs - :finally - (when other-encodings - (warn "~S uses encoding ~A but has sources that use these encodings: ~A" - operation encoding other-encodings)) - (when other-around-compile - (warn "~S uses around-compile hook ~A but has sources that use these hooks: ~A" - operation around-compile other-around-compile)) - (return inputs))) + (defun collect-sub*directories-asd-files + (directory &key (exclude *default-source-registry-exclusions*) collect) + (collect-sub*directories + directory + (constantly t) + #'(lambda (x &aux (l (car (last (pathname-directory x))))) (not (member l exclude :test #'equal))) + #'(lambda (dir) (collect-asds-in-directory dir collect)))) - (defmethod input-files ((o load-concatenated-source-op) (s system)) - (direct-dependency-files o s)) - (defmethod input-files ((o compile-concatenated-source-op) (s system)) - (direct-dependency-files o s)) - (defmethod output-files ((o compile-concatenated-source-op) (s system)) - (let ((input (first (input-files o s)))) - (list (compile-file-pathname input)))) - (defmethod input-files ((o load-compiled-concatenated-source-op) (s system)) - (direct-dependency-files o s)) - - (defmethod perform ((o concatenate-source-op) (s system)) - (let ((inputs (input-files o s)) - (output (output-file o s))) - (concatenate-files inputs output))) - (defmethod perform ((o load-concatenated-source-op) (s system)) - (perform-lisp-load-source o s)) - (defmethod perform ((o compile-concatenated-source-op) (s system)) - (perform-lisp-compilation o s)) - (defmethod perform ((o load-compiled-concatenated-source-op) (s system)) - (perform-lisp-load-fasl o s)) + (defun validate-source-registry-directive (directive) + (or (member directive '(:default-registry)) + (and (consp directive) + (let ((rest (rest directive))) + (case (first directive) + ((:include :directory :tree) + (and (length=n-p rest 1) + (location-designator-p (first rest)))) + ((:exclude :also-exclude) + (every #'stringp rest)) + ((:default-registry) + (null rest))))))) - (defmethod component-depends-on ((o concatenate-source-op) (s system)) - (declare (ignorable o s)) nil) - (defmethod component-depends-on ((o load-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((prepare-op ,s) (concatenate-source-op ,s))) - (defmethod component-depends-on ((o compile-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((concatenate-source-op ,s))) - (defmethod component-depends-on ((o load-compiled-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((compile-concatenated-source-op ,s))) - - (defmethod component-depends-on ((o monolithic-concatenate-source-op) (s system)) - (declare (ignorable o s)) nil) - (defmethod component-depends-on ((o monolithic-load-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) - (defmethod component-depends-on ((o monolithic-compile-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-concatenate-source-op ,s))) - (defmethod component-depends-on ((o monolithic-load-compiled-concatenated-source-op) (s system)) - (declare (ignorable o s)) `((monolithic-compile-concatenated-source-op ,s)))) + (defun validate-source-registry-form (form &key location) + (validate-configuration-form + form :source-registry 'validate-source-registry-directive + :location location :invalid-form-reporter 'invalid-source-registry)) -;;;; ------------------------------------------------------------------------- -;;; Backward-compatible interfaces + (defun validate-source-registry-file (file) + (validate-configuration-file + file 'validate-source-registry-form :description "a source registry")) -(asdf/package:define-package :asdf/backward-interface - (:recycle :asdf/backward-interface :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action - :asdf/lisp-build :asdf/operate :asdf/output-translations) - (:export - #:*asdf-verbose* - #:operation-error #:compile-error #:compile-failed #:compile-warned - #:error-component #:error-operation - #:component-load-dependencies - #:enable-asdf-binary-locations-compatibility - #:operation-forced - #:operation-on-failure - #:operation-on-warnings - #:component-property - #:run-shell-command - #:system-definition-pathname)) -(in-package :asdf/backward-interface) + (defun validate-source-registry-directory (directory) + (validate-configuration-directory + directory :source-registry 'validate-source-registry-directive + :invalid-form-reporter 'invalid-source-registry)) -(with-upgradability () - (define-condition operation-error (error) ;; Bad, backward-compatible name - ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel - ((component :reader error-component :initarg :component) - (operation :reader error-operation :initarg :operation)) - (:report (lambda (c s) - (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>") - (type-of c) (error-operation c) (error-component c))))) - (define-condition compile-error (operation-error) ()) - (define-condition compile-failed (compile-error) ()) - (define-condition compile-warned (compile-error) ()) + (defun parse-source-registry-string (string &key location) + (cond + ((or (null string) (equal string "")) + '(:source-registry :inherit-configuration)) + ((not (stringp string)) + (error (compatfmt "~@<Environment string isn't: ~3i~_~S~@:>") string)) + ((find (char string 0) "\"(") + (validate-source-registry-form (read-from-string string) :location location)) + (t + (loop + :with inherit = nil + :with directives = () + :with start = 0 + :with end = (length string) + :with separator = (inter-directory-separator) + :for pos = (position separator string :start start) :do + (let ((s (subseq string start (or pos end)))) + (flet ((check (dir) + (unless (absolute-pathname-p dir) + (error (compatfmt "~@<source-registry string must specify absolute pathnames: ~3i~_~S~@:>") string)) + dir)) + (cond + ((equal "" s) ; empty element: inherit + (when inherit + (error (compatfmt "~@<Only one inherited configuration allowed: ~3i~_~S~@:>") + string)) + (setf inherit t) + (push ':inherit-configuration directives)) + ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? + (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) + (t + (push `(:directory ,(check s)) directives)))) + (cond + (pos + (setf start (1+ pos))) + (t + (unless inherit + (push '(:ignore-inherited-configuration) directives)) + (return `(:source-registry ,@(nreverse directives)))))))))) - (defun component-load-dependencies (component) - ;; Old deprecated name for the same thing. Please update your software. - (component-sibling-dependencies component)) + (defun register-asd-directory (directory &key recurse exclude collect) + (if (not recurse) + (collect-asds-in-directory directory collect) + (collect-sub*directories-asd-files + directory :exclude exclude :collect collect))) + + (defparameter *default-source-registries* + '(environment-source-registry + user-source-registry + user-source-registry-directory + system-source-registry + system-source-registry-directory + default-source-registry)) + + (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf")) + (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/")) - (defgeneric operation-forced (operation)) ;; Used by swank.asd for swank-loader. - (defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force)) + (defun wrapping-source-registry () + `(:source-registry + #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) + #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) + :inherit-configuration + #+cmu (:tree #p"modules:") + #+scl (:tree #p"file://modules/"))) + (defun default-source-registry () + `(:source-registry + #+sbcl (:directory ,(subpathname (user-homedir-pathname) ".sbcl/systems/")) + ,@(loop :for dir :in + `(,@(when (os-unix-p) + `(,(or (getenv-absolute-directory "XDG_DATA_HOME") + (subpathname (user-homedir-pathname) ".local/share/")) + ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") + '("/usr/local/share" "/usr/share")))) + ,@(when (os-windows-p) + (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata)))) + :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) + :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) + :inherit-configuration)) + (defun user-source-registry (&key (direction :input)) + (in-user-configuration-directory *source-registry-file* :direction direction)) + (defun system-source-registry (&key (direction :input)) + (in-system-configuration-directory *source-registry-file* :direction direction)) + (defun user-source-registry-directory (&key (direction :input)) + (in-user-configuration-directory *source-registry-directory* :direction direction)) + (defun system-source-registry-directory (&key (direction :input)) + (in-system-configuration-directory *source-registry-directory* :direction direction)) + (defun environment-source-registry () + (getenv "CL_SOURCE_REGISTRY")) - (defgeneric operation-on-warnings (operation)) - (defgeneric operation-on-failure (operation)) - #-gcl2.6 (defgeneric (setf operation-on-warnings) (x operation)) - #-gcl2.6 (defgeneric (setf operation-on-failure) (x operation)) - (defmethod operation-on-warnings ((o operation)) - (declare (ignorable o)) *compile-file-warnings-behaviour*) - (defmethod operation-on-failure ((o operation)) - (declare (ignorable o)) *compile-file-failure-behaviour*) - (defmethod (setf operation-on-warnings) (x (o operation)) - (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x)) - (defmethod (setf operation-on-failure) (x (o operation)) - (declare (ignorable o)) (setf *compile-file-failure-behaviour* x)) + (defgeneric* (process-source-registry) (spec &key inherit register)) - (defun system-definition-pathname (x) - ;; As of 2.014.8, we mean to make this function obsolete, - ;; but that won't happen until all clients have been updated. - ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead" - "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete. -It used to expose ASDF internals with subtle differences with respect to -user expectations, that have been refactored away since. -We recommend you use ASDF:SYSTEM-SOURCE-FILE instead -for a mostly compatible replacement that we're supporting, -or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME -if that's whay you mean." ;;) - (system-source-file x))) + (defun* (inherit-source-registry) (inherit &key register) + (when inherit + (process-source-registry (first inherit) :register register :inherit (rest inherit)))) + (defun* (process-source-registry-directive) (directive &key inherit register) + (destructuring-bind (kw &rest rest) (if (consp directive) directive (list directive)) + (ecase kw + ((:include) + (destructuring-bind (pathname) rest + (process-source-registry (resolve-location pathname) :inherit nil :register register))) + ((:directory) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (resolve-location pathname :ensure-directory t))))) + ((:tree) + (destructuring-bind (pathname) rest + (when pathname + (funcall register (resolve-location pathname :ensure-directory t) + :recurse t :exclude *source-registry-exclusions*)))) + ((:exclude) + (setf *source-registry-exclusions* rest)) + ((:also-exclude) + (appendf *source-registry-exclusions* rest)) + ((:default-registry) + (inherit-source-registry '(default-source-registry) :register register)) + ((:inherit-configuration) + (inherit-source-registry inherit :register register)) + ((:ignore-inherited-configuration) + nil))) + nil) -;;;; ASDF-Binary-Locations compatibility -;; This remains supported for legacy user, but not recommended for new users. -(with-upgradability () - (defun enable-asdf-binary-locations-compatibility - (&key - (centralize-lisp-binaries nil) - (default-toplevel-directory - (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? - (include-per-user-information nil) - (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) - (source-to-target-mappings nil) - (file-types `(,(compile-file-type) - "build-report" - #+ecl (compile-file-type :type :object) - #+mkcl (compile-file-type :fasl-p nil) - #+clisp "lib" #+sbcl "cfasl" - #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) - #+(or clisp ecl mkcl) - (when (null map-all-source-files) - (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) - (let* ((patterns (if map-all-source-files (list *wild-file*) - (loop :for type :in file-types - :collect (make-pathname :type type :defaults *wild-file*)))) - (destination-directory - (if centralize-lisp-binaries - `(,default-toplevel-directory - ,@(when include-per-user-information - (cdr (pathname-directory (user-homedir-pathname)))) - :implementation ,*wild-inferiors*) - `(:root ,*wild-inferiors* :implementation)))) - (initialize-output-translations - `(:output-translations - ,@source-to-target-mappings - #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory)) - ,@(loop :for pattern :in patterns - :collect `((:root ,*wild-inferiors* ,pattern) - (,@destination-directory ,pattern))) - (t t) - :ignore-inherited-configuration)))) + (defmethod process-source-registry ((x symbol) &key inherit register) + (process-source-registry (funcall x) :inherit inherit :register register)) + (defmethod process-source-registry ((pathname #-gcl2.6 pathname #+gcl2.6 t) &key inherit register) + (cond + ((directory-pathname-p pathname) + (let ((*here-directory* (resolve-symlinks* pathname))) + (process-source-registry (validate-source-registry-directory pathname) + :inherit inherit :register register))) + ((probe-file* pathname :truename *resolve-symlinks*) + (let ((*here-directory* (pathname-directory-pathname pathname))) + (process-source-registry (validate-source-registry-file pathname) + :inherit inherit :register register))) + (t + (inherit-source-registry inherit :register register)))) + (defmethod process-source-registry ((string string) &key inherit register) + (process-source-registry (parse-source-registry-string string) + :inherit inherit :register register)) + (defmethod process-source-registry ((x null) &key inherit register) + (declare (ignorable x)) + (inherit-source-registry inherit :register register)) + (defmethod process-source-registry ((form cons) &key inherit register) + (let ((*source-registry-exclusions* *default-source-registry-exclusions*)) + (dolist (directive (cdr (validate-source-registry-form form))) + (process-source-registry-directive directive :inherit inherit :register register)))) - (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) - (declare (ignorable operation-class system args)) - (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil) - (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. -ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, -which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, -and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. -In case you insist on preserving your previous A-B-L configuration, but -do not know how to achieve the same effect with A-O-T, you may use function -ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; -call that function where you would otherwise have loaded and configured A-B-L.")))) + (defun flatten-source-registry (&optional parameter) + (remove-duplicates + (while-collecting (collect) + (with-pathname-defaults () ;; be location-independent + (inherit-source-registry + `(wrapping-source-registry + ,parameter + ,@*default-source-registries*) + :register #'(lambda (directory &key recurse exclude) + (collect (list directory :recurse recurse :exclude exclude)))))) + :test 'equal :from-end t)) + ;; Will read the configuration and initialize all internal variables. + (defun compute-source-registry (&optional parameter (registry *source-registry*)) + (dolist (entry (flatten-source-registry parameter)) + (destructuring-bind (directory &key recurse exclude) entry + (let* ((h (make-hash-table :test 'equal))) ; table to detect duplicates + (register-asd-directory + directory :recurse recurse :exclude exclude :collect + #'(lambda (asd) + (let* ((name (pathname-name asd)) + (name (if (typep asd 'logical-pathname) + ;; logical pathnames are upper-case, + ;; at least in the CLHS and on SBCL, + ;; yet (coerce-name :foo) is lower-case. + ;; won't work well with (load-system "Foo") + ;; instead of (load-system 'foo) + (string-downcase name) + name))) + (cond + ((gethash name registry) ; already shadowed by something else + nil) + ((gethash name h) ; conflict at current level + (when *verbose-out* + (warn (compatfmt "~@<In source-registry entry ~A~@[/~*~] ~ + found several entries for ~A - picking ~S over ~S~:>") + directory recurse name (gethash name h) asd))) + (t + (setf (gethash name registry) asd) + (setf (gethash name h) asd)))))) + h))) + (values)) -;;; run-shell-command -;; WARNING! The function below is not just deprecated but also dysfunctional. -;; Please use asdf/run-program:run-program instead. -(with-upgradability () - (defun run-shell-command (control-string &rest args) - "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and -synchronously execute the result using a Bourne-compatible shell, with -output to *VERBOSE-OUT*. Returns the shell's exit code. + (defvar *source-registry-parameter* nil) -PLEASE DO NOT USE. -Deprecated function, for backward-compatibility only. -Please use ASDF-DRIVER:RUN-PROGRAM instead." - (let ((command (apply 'format nil control-string args))) - (asdf-message "; $ ~A~%" command) - (run-program command :force-shell t :ignore-error-status t :output *verbose-out*)))) + (defun initialize-source-registry (&optional (parameter *source-registry-parameter*)) + ;; Record the parameter used to configure the registry + (setf *source-registry-parameter* parameter) + ;; Clear the previous registry database: + (setf *source-registry* (make-hash-table :test 'equal)) + ;; Do it! + (compute-source-registry parameter)) -(with-upgradability () - (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. + ;; Checks an initial variable to see whether the state is initialized + ;; or cleared. In the former case, return current configuration; in + ;; the latter, initialize. ASDF will call this function at the start + ;; of (asdf:find-system) to make sure the source registry is initialized. + ;; However, it will do so *without* a parameter, at which point it + ;; will be too late to provide a parameter to this function, though + ;; you may override the configuration explicitly by calling + ;; initialize-source-registry directly with your parameter. + (defun ensure-source-registry (&optional parameter) + (unless (source-registry-initialized-p) + (initialize-source-registry parameter)) + (values)) -;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED. -(with-upgradability () - (defgeneric component-property (component property)) - (defgeneric (setf component-property) (new-value component property)) + (defun sysdef-source-registry-search (system) + (ensure-source-registry) + (values (gethash (primary-system-name system) *source-registry*)))) - (defmethod component-property ((c component) property) - (cdr (assoc property (slot-value c 'properties) :test #'equal))) - (defmethod (setf component-property) (new-value (c component) property) - (let ((a (assoc property (slot-value c 'properties) :test #'equal))) - (if a - (setf (cdr a) new-value) - (setf (slot-value c 'properties) - (acons property new-value (slot-value c 'properties))))) - new-value)) ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. @@ -9263,25 +9516,28 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." ;; TODO: automatically generate interface with reexport? (:export #:defsystem #:find-system #:locate-system #:coerce-name - #:oos #:operate #:traverse #:perform-plan + #:oos #:operate #:traverse #:perform-plan #:sequential-plan #:system-definition-pathname #:with-system-definitions #:search-for-system-definition #:find-component #:component-find-path #:compile-system #:load-system #:load-systems #:require-system #:test-system #:clear-system - #:operation #:upward-operation #:downward-operation #:make-operation + #:operation #:make-operation #:find-operation + #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation #:build-system #:build-op #:load-op #:prepare-op #:compile-op #:prepare-source-op #:load-source-op #:test-op #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type #:hostname #:input-files #:output-files #:output-file #:perform - #:operation-done-p #:explain #:action-description #:component-sibling-dependencies + #:operation-done-p #:explain #:action-description #:component-sideway-dependencies #:needed-in-image-p ;; #:run-program ; we can't export it, because SB-GROVEL :use's both ASDF and SB-EXT. #:component-load-dependencies #:run-shell-command ; deprecated, do not use - #:bundle-op #:precompiled-system #:compiled-file #:bundle-system + #:bundle-op #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system #+ecl #:make-build - #:program-op #:load-fasl-op #:fasl-op #:lib-op #:binary-op + #:basic-fasl-op #:prepare-fasl-op #:fasl-op #:load-fasl-op #:monolithic-fasl-op + #:lib-op #:dll-op #:binary-op #:program-op + #:monolithic-lib-op #:monolithic-dll-op #:monolithic-binary-op #:concatenate-source-op #:load-concatenated-source-op #:compile-concatenated-source-op @@ -9357,7 +9613,7 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." #:missing-dependency #:missing-dependency-of-version #:circular-dependency ; errors - #:duplicate-names + #:duplicate-names #:non-toplevel-system #:non-system-system #:try-recompiling #:retry @@ -9391,6 +9647,7 @@ Please use ASDF-DRIVER:RUN-PROGRAM instead." #:system-registered-p #:registered-systems #:already-loaded-systems #:resolve-location #:asdf-message + #:*user-cache* #:user-output-translations-pathname #:system-output-translations-pathname #:user-output-translations-directory-pathname diff --git a/src/general-info/release-20e.txt b/src/general-info/release-20e.txt index f36f6d0..90df1d4 100644 --- a/src/general-info/release-20e.txt +++ b/src/general-info/release-20e.txt @@ -23,7 +23,7 @@ New in this release: * Feature enhancements * Changes - * ASDF2 updated to version 2.32. + * ASDF2 updated to version 3.0.1.. * DEFINE-COMPILER-MACRO now has source-location information for the macro definition. * :ALIEN-CALLBACK added to *FEATURES* for platforms that support ----------------------------------------------------------------------- Summary of changes: src/contrib/asdf/asdf.lisp | 3683 ++++++++++++++++++++------------------ src/general-info/release-20e.txt | 2 +- 2 files changed, 1971 insertions(+), 1714 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-52-g7adafd9
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via 7adafd921406485dfea0fb8e9290f5ae7f8aa5e5 (commit) via 1d1ffdf93cb3a67a495b9fe4ea1e3dc679fd401c (commit) via 21f9b46373c76e44a72b1f7f73cd292397388962 (commit) via 92c7c5d0c4e9904f1a86a6e3b306ca869d710593 (commit) from 99afcf7a7ef0b0451cfcb477f8ad241aad930086 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit 7adafd921406485dfea0fb8e9290f5ae7f8aa5e5 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Aug 1 23:25:55 2014 -0700 Use the fdlibm routines for exp and log. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 8f29490..df0bb8c 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -79,8 +79,8 @@ (def-math-rtn "atanh" 1) ;;; Exponential and Logarithmic. -(def-math-rtn "exp" 1) -(def-math-rtn "log" 1) +(def-math-rtn ("__ieee754_exp" %exp) 1) +(def-math-rtn ("__ieee754_log" %log) 1) (def-math-rtn "log10" 1) (def-math-rtn ("__ieee754_pow" %pow) 2) commit 1d1ffdf93cb3a67a495b9fe4ea1e3dc679fd401c Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Aug 1 23:25:26 2014 -0700 Compile fdlibm routines e_exp.c and e_log.c diff --git a/src/lisp/Config.x86_darwin b/src/lisp/Config.x86_darwin index ccf021d..8c7c37b 100644 --- a/src/lisp/Config.x86_darwin +++ b/src/lisp/Config.x86_darwin @@ -18,7 +18,7 @@ OS_LIBS = EXEC_FINAL_OBJ = exec-final.o -OS_SRC += k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c s_log1p.c s_expm1.c e_pow.c +OS_SRC += k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c s_log1p.c s_expm1.c e_pow.c e_exp.c e_log.c k_sin.o : k_sin.c $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< @@ -44,3 +44,7 @@ s_exmp1.o : s_expm1.c e_pow.o : e_pow.c $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +e_exp.o : e_exp.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< +e_log.o : e_log.c + $(CC) -c $(CFLAGS) $(CPPFLAGS) $(CC_REM_PIO2) $< commit 21f9b46373c76e44a72b1f7f73cd292397388962 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Aug 1 23:10:46 2014 -0700 Update to use unions. diff --git a/src/lisp/e_exp.c b/src/lisp/e_exp.c index e201205..4d94a1e 100644 --- a/src/lisp/e_exp.c +++ b/src/lisp/e_exp.c @@ -108,15 +108,17 @@ P5 = 4.13813679705723846039e-08; /* 0x3E663769, 0x72BEA4D0 */ double y,hi,lo,c,t; int k,xsb; unsigned hx; + union { int i[2]; double d; } ux; - hx = __HI(x); /* high word of x */ + ux.d = x; + hx = ux.i[HIWORD]; /* high word of x */ xsb = (hx>>31)&1; /* sign bit of x */ hx &= 0x7fffffff; /* high word of |x| */ /* filter out non-finite argument */ if(hx >= 0x40862E42) { /* if |x|>=709.78... */ if(hx>=0x7ff00000) { - if(((hx&0xfffff)|__LO(x))!=0) + if(((hx&0xfffff)|ux.i[LOWORD])!=0) return x+x; /* NaN */ else return (xsb==0)? x:0.0; /* exp(+-inf)={inf,0} */ } @@ -147,10 +149,14 @@ P5 = 4.13813679705723846039e-08; /* 0x3E663769, 0x72BEA4D0 */ if(k==0) return one-((x*c)/(c-2.0)-x); else y = one-((lo-(x*c)/(2.0-c))-hi); if(k >= -1021) { - __HI(y) += (k<<20); /* add k to y's exponent */ + ux.d = y; + ux.i[HIWORD] += (k<<20); /* add k to y's exponent */ + y = ux.d; return y; } else { - __HI(y) += ((k+1000)<<20);/* add k to y's exponent */ + ux.d = y; + ux.i[HIWORD] += ((k+1000)<<20);/* add k to y's exponent */ + y = ux.d; return y*twom1000; } } diff --git a/src/lisp/e_log.c b/src/lisp/e_log.c index 3798bc8..4404ce1 100644 --- a/src/lisp/e_log.c +++ b/src/lisp/e_log.c @@ -92,9 +92,11 @@ static double zero = 0.0; double hfsq,f,s,z,R,w,t1,t2,dk; int k,hx,i,j; unsigned lx; + union { int i[2]; double d; } ux; - hx = __HI(x); /* high word of x */ - lx = __LO(x); /* low word of x */ + ux.d = x; + hx = ux.i[HIWORD]; /* high word of x */ + lx = ux.i[LOWORD]; /* low word of x */ k=0; if (hx < 0x00100000) { /* x < 2**-1022 */ @@ -102,13 +104,16 @@ static double zero = 0.0; return -two54/zero; /* log(+-0)=-inf */ if (hx<0) return (x-x)/zero; /* log(-#) = NaN */ k -= 54; x *= two54; /* subnormal number, scale up x */ - hx = __HI(x); /* high word of x */ + ux.d = x; + hx = ux.i[HIWORD]; /* high word of x */ } if (hx >= 0x7ff00000) return x+x; k += (hx>>20)-1023; hx &= 0x000fffff; i = (hx+0x95f64)&0x100000; - __HI(x) = hx|(i^0x3ff00000); /* normalize x or x/2 */ + ux.d = x; + ux.i[HIWORD] = hx|(i^0x3ff00000); /* normalize x or x/2 */ + x = ux.d; k += (i>>20); f = x-1.0; if((0x000fffff&(2+hx))<3) { /* |f| < 2**-20 */ commit 92c7c5d0c4e9904f1a86a6e3b306ca869d710593 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Aug 1 23:05:57 2014 -0700 Add fdlibm routines e_exp and e_log, as is. diff --git a/src/lisp/e_exp.c b/src/lisp/e_exp.c new file mode 100644 index 0000000..e201205 --- /dev/null +++ b/src/lisp/e_exp.c @@ -0,0 +1,156 @@ + +/* @(#)e_exp.c 1.6 04/04/22 */ +/* + * ==================================================== + * Copyright (C) 2004 by Sun Microsystems, Inc. All rights reserved. + * + * Permission to use, copy, modify, and distribute this + * software is freely granted, provided that this notice + * is preserved. + * ==================================================== + */ + +/* __ieee754_exp(x) + * Returns the exponential of x. + * + * Method + * 1. Argument reduction: + * Reduce x to an r so that |r| <= 0.5*ln2 ~ 0.34658. + * Given x, find r and integer k such that + * + * x = k*ln2 + r, |r| <= 0.5*ln2. + * + * Here r will be represented as r = hi-lo for better + * accuracy. + * + * 2. Approximation of exp(r) by a special rational function on + * the interval [0,0.34658]: + * Write + * R(r**2) = r*(exp(r)+1)/(exp(r)-1) = 2 + r*r/6 - r**4/360 + ... + * We use a special Remes algorithm on [0,0.34658] to generate + * a polynomial of degree 5 to approximate R. The maximum error + * of this polynomial approximation is bounded by 2**-59. In + * other words, + * R(z) ~ 2.0 + P1*z + P2*z**2 + P3*z**3 + P4*z**4 + P5*z**5 + * (where z=r*r, and the values of P1 to P5 are listed below) + * and + * | 5 | -59 + * | 2.0+P1*z+...+P5*z - R(z) | <= 2 + * | | + * The computation of exp(r) thus becomes + * 2*r + * exp(r) = 1 + ------- + * R - r + * r*R1(r) + * = 1 + r + ----------- (for better accuracy) + * 2 - R1(r) + * where + * 2 4 10 + * R1(r) = r - (P1*r + P2*r + ... + P5*r ). + * + * 3. Scale back to obtain exp(x): + * From step 1, we have + * exp(x) = 2^k * exp(r) + * + * Special cases: + * exp(INF) is INF, exp(NaN) is NaN; + * exp(-INF) is 0, and + * for finite argument, only exp(0)=1 is exact. + * + * Accuracy: + * according to an error analysis, the error is always less than + * 1 ulp (unit in the last place). + * + * Misc. info. + * For IEEE double + * if x > 7.09782712893383973096e+02 then exp(x) overflow + * if x < -7.45133219101941108420e+02 then exp(x) underflow + * + * Constants: + * The hexadecimal values are the intended ones for the following + * constants. The decimal values may be used, provided that the + * compiler will convert from decimal to binary accurately enough + * to produce the hexadecimal values shown. + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double +#else +static double +#endif +one = 1.0, +halF[2] = {0.5,-0.5,}, +huge = 1.0e+300, +twom1000= 9.33263618503218878990e-302, /* 2**-1000=0x01700000,0*/ +o_threshold= 7.09782712893383973096e+02, /* 0x40862E42, 0xFEFA39EF */ +u_threshold= -7.45133219101941108420e+02, /* 0xc0874910, 0xD52D3051 */ +ln2HI[2] ={ 6.93147180369123816490e-01, /* 0x3fe62e42, 0xfee00000 */ + -6.93147180369123816490e-01,},/* 0xbfe62e42, 0xfee00000 */ +ln2LO[2] ={ 1.90821492927058770002e-10, /* 0x3dea39ef, 0x35793c76 */ + -1.90821492927058770002e-10,},/* 0xbdea39ef, 0x35793c76 */ +invln2 = 1.44269504088896338700e+00, /* 0x3ff71547, 0x652b82fe */ +P1 = 1.66666666666666019037e-01, /* 0x3FC55555, 0x5555553E */ +P2 = -2.77777777770155933842e-03, /* 0xBF66C16C, 0x16BEBD93 */ +P3 = 6.61375632143793436117e-05, /* 0x3F11566A, 0xAF25DE2C */ +P4 = -1.65339022054652515390e-06, /* 0xBEBBBD41, 0xC5D26BF1 */ +P5 = 4.13813679705723846039e-08; /* 0x3E663769, 0x72BEA4D0 */ + + +#ifdef __STDC__ + double __ieee754_exp(double x) /* default IEEE double exp */ +#else + double __ieee754_exp(x) /* default IEEE double exp */ + double x; +#endif +{ + double y,hi,lo,c,t; + int k,xsb; + unsigned hx; + + hx = __HI(x); /* high word of x */ + xsb = (hx>>31)&1; /* sign bit of x */ + hx &= 0x7fffffff; /* high word of |x| */ + + /* filter out non-finite argument */ + if(hx >= 0x40862E42) { /* if |x|>=709.78... */ + if(hx>=0x7ff00000) { + if(((hx&0xfffff)|__LO(x))!=0) + return x+x; /* NaN */ + else return (xsb==0)? x:0.0; /* exp(+-inf)={inf,0} */ + } + if(x > o_threshold) return huge*huge; /* overflow */ + if(x < u_threshold) return twom1000*twom1000; /* underflow */ + } + + /* argument reduction */ + if(hx > 0x3fd62e42) { /* if |x| > 0.5 ln2 */ + if(hx < 0x3FF0A2B2) { /* and |x| < 1.5 ln2 */ + hi = x-ln2HI[xsb]; lo=ln2LO[xsb]; k = 1-xsb-xsb; + } else { + k = (int)(invln2*x+halF[xsb]); + t = k; + hi = x - t*ln2HI[0]; /* t*ln2HI is exact here */ + lo = t*ln2LO[0]; + } + x = hi - lo; + } + else if(hx < 0x3e300000) { /* when |x|<2**-28 */ + if(huge+x>one) return one+x;/* trigger inexact */ + } + else k = 0; + + /* x is now in primary range */ + t = x*x; + c = x - t*(P1+t*(P2+t*(P3+t*(P4+t*P5)))); + if(k==0) return one-((x*c)/(c-2.0)-x); + else y = one-((lo-(x*c)/(2.0-c))-hi); + if(k >= -1021) { + __HI(y) += (k<<20); /* add k to y's exponent */ + return y; + } else { + __HI(y) += ((k+1000)<<20);/* add k to y's exponent */ + return y*twom1000; + } +} diff --git a/src/lisp/e_log.c b/src/lisp/e_log.c new file mode 100644 index 0000000..3798bc8 --- /dev/null +++ b/src/lisp/e_log.c @@ -0,0 +1,139 @@ + +/* @(#)e_log.c 1.3 95/01/18 */ +/* + * ==================================================== + * Copyright (C) 1993 by Sun Microsystems, Inc. All rights reserved. + * + * Developed at SunSoft, a Sun Microsystems, Inc. business. + * Permission to use, copy, modify, and distribute this + * software is freely granted, provided that this notice + * is preserved. + * ==================================================== + */ + +/* __ieee754_log(x) + * Return the logrithm of x + * + * Method : + * 1. Argument Reduction: find k and f such that + * x = 2^k * (1+f), + * where sqrt(2)/2 < 1+f < sqrt(2) . + * + * 2. Approximation of log(1+f). + * Let s = f/(2+f) ; based on log(1+f) = log(1+s) - log(1-s) + * = 2s + 2/3 s**3 + 2/5 s**5 + ....., + * = 2s + s*R + * We use a special Reme algorithm on [0,0.1716] to generate + * a polynomial of degree 14 to approximate R The maximum error + * of this polynomial approximation is bounded by 2**-58.45. In + * other words, + * 2 4 6 8 10 12 14 + * R(z) ~ Lg1*s +Lg2*s +Lg3*s +Lg4*s +Lg5*s +Lg6*s +Lg7*s + * (the values of Lg1 to Lg7 are listed in the program) + * and + * | 2 14 | -58.45 + * | Lg1*s +...+Lg7*s - R(z) | <= 2 + * | | + * Note that 2s = f - s*f = f - hfsq + s*hfsq, where hfsq = f*f/2. + * In order to guarantee error in log below 1ulp, we compute log + * by + * log(1+f) = f - s*(f - R) (if f is not too large) + * log(1+f) = f - (hfsq - s*(hfsq+R)). (better accuracy) + * + * 3. Finally, log(x) = k*ln2 + log(1+f). + * = k*ln2_hi+(f-(hfsq-(s*(hfsq+R)+k*ln2_lo))) + * Here ln2 is split into two floating point number: + * ln2_hi + ln2_lo, + * where n*ln2_hi is always exact for |n| < 2000. + * + * Special cases: + * log(x) is NaN with signal if x < 0 (including -INF) ; + * log(+INF) is +INF; log(0) is -INF with signal; + * log(NaN) is that NaN with no signal. + * + * Accuracy: + * according to an error analysis, the error is always less than + * 1 ulp (unit in the last place). + * + * Constants: + * The hexadecimal values are the intended ones for the following + * constants. The decimal values may be used, provided that the + * compiler will convert from decimal to binary accurately enough + * to produce the hexadecimal values shown. + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double +#else +static double +#endif +ln2_hi = 6.93147180369123816490e-01, /* 3fe62e42 fee00000 */ +ln2_lo = 1.90821492927058770002e-10, /* 3dea39ef 35793c76 */ +two54 = 1.80143985094819840000e+16, /* 43500000 00000000 */ +Lg1 = 6.666666666666735130e-01, /* 3FE55555 55555593 */ +Lg2 = 3.999999999940941908e-01, /* 3FD99999 9997FA04 */ +Lg3 = 2.857142874366239149e-01, /* 3FD24924 94229359 */ +Lg4 = 2.222219843214978396e-01, /* 3FCC71C5 1D8E78AF */ +Lg5 = 1.818357216161805012e-01, /* 3FC74664 96CB03DE */ +Lg6 = 1.531383769920937332e-01, /* 3FC39A09 D078C69F */ +Lg7 = 1.479819860511658591e-01; /* 3FC2F112 DF3E5244 */ + +static double zero = 0.0; + +#ifdef __STDC__ + double __ieee754_log(double x) +#else + double __ieee754_log(x) + double x; +#endif +{ + double hfsq,f,s,z,R,w,t1,t2,dk; + int k,hx,i,j; + unsigned lx; + + hx = __HI(x); /* high word of x */ + lx = __LO(x); /* low word of x */ + + k=0; + if (hx < 0x00100000) { /* x < 2**-1022 */ + if (((hx&0x7fffffff)|lx)==0) + return -two54/zero; /* log(+-0)=-inf */ + if (hx<0) return (x-x)/zero; /* log(-#) = NaN */ + k -= 54; x *= two54; /* subnormal number, scale up x */ + hx = __HI(x); /* high word of x */ + } + if (hx >= 0x7ff00000) return x+x; + k += (hx>>20)-1023; + hx &= 0x000fffff; + i = (hx+0x95f64)&0x100000; + __HI(x) = hx|(i^0x3ff00000); /* normalize x or x/2 */ + k += (i>>20); + f = x-1.0; + if((0x000fffff&(2+hx))<3) { /* |f| < 2**-20 */ + if(f==zero) if(k==0) return zero; else {dk=(double)k; + return dk*ln2_hi+dk*ln2_lo;} + R = f*f*(0.5-0.33333333333333333*f); + if(k==0) return f-R; else {dk=(double)k; + return dk*ln2_hi-((R-dk*ln2_lo)-f);} + } + s = f/(2.0+f); + dk = (double)k; + z = s*s; + i = hx-0x6147a; + w = z*z; + j = 0x6b851-hx; + t1= w*(Lg2+w*(Lg4+w*Lg6)); + t2= z*(Lg1+w*(Lg3+w*(Lg5+w*Lg7))); + i |= j; + R = t2+t1; + if(i>0) { + hfsq=0.5*f*f; + if(k==0) return f-(hfsq-s*(hfsq+R)); else + return dk*ln2_hi-((hfsq-(s*(hfsq+R)+dk*ln2_lo))-f); + } else { + if(k==0) return f-s*(f-R); else + return dk*ln2_hi-((s*(f-R)-dk*ln2_lo)-f); + } +} ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 4 +- src/lisp/Config.x86_darwin | 6 +- src/lisp/e_exp.c | 162 ++++++++++++++++++++++++++++++++++++++++++++ src/lisp/e_log.c | 144 +++++++++++++++++++++++++++++++++++++++ 4 files changed, 313 insertions(+), 3 deletions(-) create mode 100644 src/lisp/e_exp.c create mode 100644 src/lisp/e_log.c hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-08-4-gc0052f5
by rtoy＠common-lisp.net 08 Apr '15

08 Apr '15

This is an automated email from the git hooks/post-receive script. It was generated because a ref change was pushed to the repository containing the project "CMU Common Lisp". The branch, master has been updated via c0052f5544d27980c74d5a17cd55dc2069085602 (commit) from 9e687a21f823e0c9fd5af32ab112dbe66476a9c6 (commit) Those revisions listed above that are new to this repository have not appeared on any other notification email; so we list those revisions in full, below. - Log ----------------------------------------------------------------- commit c0052f5544d27980c74d5a17cd55dc2069085602 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 9 12:53:57 2014 -0700 Fix ticket:105 by not flaming out on a closed stream. * code/reader.lisp: * The READER-ERROR condition tries to be helpful and print out the position of where the error occurred using FILE-POSITION. But FILE-POSITION flames out when the stream is closed, so check for a closed stream before calling FILE-POSITION * tests/trac.lisp: * Add test from the bug report. * general-info/release-20f.txt: * Update. diff --git a/src/code/reader.lisp b/src/code/reader.lisp index b06230c..996b1f3 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -62,8 +62,11 @@ (reader-error-format-arguments condition)) nil error-stream (file-position error-stream))) + (format t "open-stream-p ~A~%" (open-stream-p error-stream)) (format stream (intl:gettext "Reader error ~@[at ~D ~]on ~S:~%~?") - (file-position error-stream) error-stream + (and (open-stream-p error-stream) + (file-position error-stream)) + error-stream (reader-error-format-control condition) (reader-error-format-arguments condition)))))) diff --git a/src/general-info/release-20f.txt b/src/general-info/release-20f.txt index b6ce0d5..388ca02 100644 --- a/src/general-info/release-20f.txt +++ b/src/general-info/release-20f.txt @@ -109,6 +109,7 @@ New in this release: * Ticket #101, item 1 fixed. * Ticket #105, fixed. * Ticket #84 fixed on x86. + * Ticket #105 fixed. * Other changes: diff --git a/tests/trac.lisp b/tests/trac.lisp index 9a02189..571b069 100644 --- a/tests/trac.lisp +++ b/tests/trac.lisp @@ -366,4 +366,33 @@ (assert-error 'reader-error (read-from-string ".1e-45")) (assert-error 'reader-error (read-from-string "1d-324")) (assert-error 'reader-error (read-from-string "1w-324"))) + +(defun read-string-fn (str) + (handler-case + (let ((acc nil)) + (with-input-from-string + (stream str) + (loop do + (let* ((eof-marker (cons nil nil)) + (elem (read stream nil eof-marker))) + (if (eq elem eof-marker) + (loop-finish) + (push elem acc))))) + (setq acc (nreverse acc)) + (values :OK acc)) + (error (condition) + (return-from read-string-fn + (values :ERROR (format nil "~A" condition)))) + (storage-condition (condition) + (return-from read-string-fn + (values :STORAGE (format nil "~A" condition)))))) + +(define-test trac.105 + (:tag :trac) + (assert-equal (values :ERROR + "Reader error on #<String-Input Stream>: +No dispatch function defined for #\\W.") + (read-string-fn "#\wtf"))) + + \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: src/code/reader.lisp | 5 ++++- src/general-info/release-20f.txt | 1 + tests/trac.lisp | 29 +++++++++++++++++++++++++++++ 3 files changed, 34 insertions(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0