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

[git] CMU Common Lisp branch master updated. snapshot-2014-06-25-g7e56a8c
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 7e56a8c7ebb5b33e2d755ef725900fd4310ffc3e (commit) from 2ade088e991102f642e20a3d20239bf8b2b52633 (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 7e56a8c7ebb5b33e2d755ef725900fd4310ffc3e Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Jul 26 09:04:27 2014 -0700 Comment code, add license header, and conform to cmucl C style. diff --git a/src/lisp/sincos.c b/src/lisp/sincos.c index edd0eca..e879425 100644 --- a/src/lisp/sincos.c +++ b/src/lisp/sincos.c @@ -1,6 +1,19 @@ +/* + + This code was written as part of the CMU Common Lisp project at + Carnegie Mellon University, and has been placed in the public domain. + +*/ + #include "fdlibm.h" -void lisp_sincos (double x, double *s, double *c) +/* + * sincos function. Compute sin(x) and cos(x) faster than computing + * each individually. Speedup comes from doing the pi argument + * reduction just once. + */ +void +lisp_sincos (double x, double *s, double *c) { int ix; union { int i[2]; double d; } ux; ----------------------------------------------------------------------- Summary of changes: src/lisp/sincos.c | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-68-g60d71b6
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 60d71b68ef6af3e5fb3e045f7ce2a42a5ff23ac1 (commit) via 1b876280ab1774cb36fb63906c58cd5af1e5d230 (commit) from 21aad0ecc9f96297deedf9362c19fd877910592a (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 60d71b68ef6af3e5fb3e045f7ce2a42a5ff23ac1 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 15:30:51 2014 -0700 Fix up the inverse hyperbolics. * fdlibm.h: * Declare fdlibm_log1p and __ieee754_log * e_acosh.c: * Use unions to get the parts of a double. * Use fdlibm_log1p instead of log1p. * e_atanh.c: * Use unions to get the parts of a double. * Use fdlibm_log1p instead of log1p. * s_asinh.c: * Rename from asinh to fdlibm_asinh. * Use unions to get the parts of a double. * Use fdlibm_log1p instead of log1p. diff --git a/src/lisp/e_acosh.c b/src/lisp/e_acosh.c index 6839554..fb248d5 100644 --- a/src/lisp/e_acosh.c +++ b/src/lisp/e_acosh.c @@ -45,7 +45,10 @@ ln2 = 6.93147180559945286227e-01; /* 0x3FE62E42, 0xFEFA39EF */ { double t; int hx; - hx = __HI(x); + union { int i[2]; double d; } ux; + + ux.d = x; + hx = ux.i[HIWORD]; if(hx<0x3ff00000) { /* x < 1 */ return (x-x)/(x-x); } else if(hx >=0x41b00000) { /* x > 2**28 */ @@ -53,13 +56,13 @@ ln2 = 6.93147180559945286227e-01; /* 0x3FE62E42, 0xFEFA39EF */ return x+x; } else return __ieee754_log(x)+ln2; /* acosh(huge)=log(2x) */ - } else if(((hx-0x3ff00000)|__LO(x))==0) { + } else if(((hx-0x3ff00000)|ux.i[LOWORD])==0) { return 0.0; /* acosh(1) = 0 */ } else if (hx > 0x40000000) { /* 2**28 > x > 2 */ t=x*x; return __ieee754_log(2.0*x-one/(x+sqrt(t-one))); } else { /* 1<x<2 */ t = x-one; - return log1p(t+sqrt(2.0*t+t*t)); + return fdlibm_log1p(t+sqrt(2.0*t+t*t)); } } diff --git a/src/lisp/e_atanh.c b/src/lisp/e_atanh.c index 302a89f..3588436 100644 --- a/src/lisp/e_atanh.c +++ b/src/lisp/e_atanh.c @@ -50,19 +50,24 @@ static double zero = 0.0; double t; int hx,ix; unsigned lx; - hx = __HI(x); /* high word */ - lx = __LO(x); /* low word */ + union { int i[2]; double d; } ux; + + ux.d = x; + hx = ux.i[HIWORD]; /* high word */ + lx = ux.i[LOWORD]; /* low word */ ix = hx&0x7fffffff; if ((ix|((lx|(-lx))>>31))>0x3ff00000) /* |x|>1 */ return (x-x)/(x-x); if(ix==0x3ff00000) return x/zero; if(ix<0x3e300000&&(huge+x)>zero) return x; /* x<2**-28 */ - __HI(x) = ix; /* x <- |x| */ + ux.d = x; + ux.i[HIWORD] = ix; /* x <- |x| */ + x = ux.d; if(ix<0x3fe00000) { /* x < 0.5 */ t = x+x; - t = 0.5*log1p(t+t*x/(one-x)); + t = 0.5*fdlibm_log1p(t+t*x/(one-x)); } else - t = 0.5*log1p((x+x)/(one-x)); + t = 0.5*fdlibm_log1p((x+x)/(one-x)); if(hx>=0) return t; else return -t; } diff --git a/src/lisp/fdlibm.h b/src/lisp/fdlibm.h index 325d7d4..72f57f8 100644 --- a/src/lisp/fdlibm.h +++ b/src/lisp/fdlibm.h @@ -52,7 +52,9 @@ extern double fdlibm_sin(double x); extern double fdlibm_cos(double x); extern double fdlibm_tan(double x); extern double fdlibm_expm1(double x); +extern double fdlibm_log1p(double x); extern double __ieee754_exp(double x); +extern double __ieee754_log(double x); #endif diff --git a/src/lisp/s_asinh.c b/src/lisp/s_asinh.c index c809467..6cae81f 100644 --- a/src/lisp/s_asinh.c +++ b/src/lisp/s_asinh.c @@ -34,15 +34,18 @@ ln2 = 6.93147180559945286227e-01, /* 0x3FE62E42, 0xFEFA39EF */ huge= 1.00000000000000000000e+300; #ifdef __STDC__ - double asinh(double x) + double fdlibm_asinh(double x) #else - double asinh(x) + double fdlibm_asinh(x) double x; #endif { double t,w; int hx,ix; - hx = __HI(x); + union { int i[2]; double d; } ux; + + ux.d = x; + hx = ux.i[HIWORD]; ix = hx&0x7fffffff; if(ix>=0x7ff00000) return x+x; /* x is inf or NaN */ if(ix< 0x3e300000) { /* |x|<2**-28 */ @@ -55,7 +58,7 @@ huge= 1.00000000000000000000e+300; w = __ieee754_log(2.0*t+one/(sqrt(x*x+one)+t)); } else { /* 2.0 > |x| > 2**-28 */ t = x*x; - w =log1p(fabs(x)+t/(one+sqrt(one+t))); + w =fdlibm_log1p(fabs(x)+t/(one+sqrt(one+t))); } if(hx>0) return w; else return -w; } commit 1b876280ab1774cb36fb63906c58cd5af1e5d230 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Sat Aug 2 15:17:58 2014 -0700 Import inverse hyperbolic functions from fdlibm, as is. diff --git a/src/lisp/e_acosh.c b/src/lisp/e_acosh.c new file mode 100644 index 0000000..6839554 --- /dev/null +++ b/src/lisp/e_acosh.c @@ -0,0 +1,65 @@ + +/* @(#)e_acosh.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_acosh(x) + * Method : + * Based on + * acosh(x) = log [ x + sqrt(x*x-1) ] + * we have + * acosh(x) := log(x)+ln2, if x is large; else + * acosh(x) := log(2x-1/(sqrt(x*x-1)+x)) if x>2; else + * acosh(x) := log1p(t+sqrt(2.0*t+t*t)); where t=x-1. + * + * Special cases: + * acosh(x) is NaN with signal if x<1. + * acosh(NaN) is NaN without signal. + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double +#else +static double +#endif +one = 1.0, +ln2 = 6.93147180559945286227e-01; /* 0x3FE62E42, 0xFEFA39EF */ + +#ifdef __STDC__ + double __ieee754_acosh(double x) +#else + double __ieee754_acosh(x) + double x; +#endif +{ + double t; + int hx; + hx = __HI(x); + if(hx<0x3ff00000) { /* x < 1 */ + return (x-x)/(x-x); + } else if(hx >=0x41b00000) { /* x > 2**28 */ + if(hx >=0x7ff00000) { /* x is inf of NaN */ + return x+x; + } else + return __ieee754_log(x)+ln2; /* acosh(huge)=log(2x) */ + } else if(((hx-0x3ff00000)|__LO(x))==0) { + return 0.0; /* acosh(1) = 0 */ + } else if (hx > 0x40000000) { /* 2**28 > x > 2 */ + t=x*x; + return __ieee754_log(2.0*x-one/(x+sqrt(t-one))); + } else { /* 1<x<2 */ + t = x-one; + return log1p(t+sqrt(2.0*t+t*t)); + } +} diff --git a/src/lisp/e_atanh.c b/src/lisp/e_atanh.c new file mode 100644 index 0000000..302a89f --- /dev/null +++ b/src/lisp/e_atanh.c @@ -0,0 +1,68 @@ + +/* @(#)e_atanh.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_atanh(x) + * Method : + * 1.Reduced x to positive by atanh(-x) = -atanh(x) + * 2.For x>=0.5 + * 1 2x x + * atanh(x) = --- * log(1 + -------) = 0.5 * log1p(2 * --------) + * 2 1 - x 1 - x + * + * For x<0.5 + * atanh(x) = 0.5*log1p(2x+2x*x/(1-x)) + * + * Special cases: + * atanh(x) is NaN if |x| > 1 with signal; + * atanh(NaN) is that NaN with no signal; + * atanh(+-1) is +-INF with signal. + * + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double one = 1.0, huge = 1e300; +#else +static double one = 1.0, huge = 1e300; +#endif + +static double zero = 0.0; + +#ifdef __STDC__ + double __ieee754_atanh(double x) +#else + double __ieee754_atanh(x) + double x; +#endif +{ + double t; + int hx,ix; + unsigned lx; + hx = __HI(x); /* high word */ + lx = __LO(x); /* low word */ + ix = hx&0x7fffffff; + if ((ix|((lx|(-lx))>>31))>0x3ff00000) /* |x|>1 */ + return (x-x)/(x-x); + if(ix==0x3ff00000) + return x/zero; + if(ix<0x3e300000&&(huge+x)>zero) return x; /* x<2**-28 */ + __HI(x) = ix; /* x <- |x| */ + if(ix<0x3fe00000) { /* x < 0.5 */ + t = x+x; + t = 0.5*log1p(t+t*x/(one-x)); + } else + t = 0.5*log1p((x+x)/(one-x)); + if(hx>=0) return t; else return -t; +} diff --git a/src/lisp/s_asinh.c b/src/lisp/s_asinh.c new file mode 100644 index 0000000..c809467 --- /dev/null +++ b/src/lisp/s_asinh.c @@ -0,0 +1,61 @@ + +/* @(#)s_asinh.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. + * ==================================================== + */ + +/* asinh(x) + * Method : + * Based on + * asinh(x) = sign(x) * log [ |x| + sqrt(x*x+1) ] + * we have + * asinh(x) := x if 1+x*x=1, + * := sign(x)*(log(x)+ln2)) for large |x|, else + * := sign(x)*log(2|x|+1/(|x|+sqrt(x*x+1))) if|x|>2, else + * := sign(x)*log1p(|x| + x^2/(1 + sqrt(1+x^2))) + */ + +#include "fdlibm.h" + +#ifdef __STDC__ +static const double +#else +static double +#endif +one = 1.00000000000000000000e+00, /* 0x3FF00000, 0x00000000 */ +ln2 = 6.93147180559945286227e-01, /* 0x3FE62E42, 0xFEFA39EF */ +huge= 1.00000000000000000000e+300; + +#ifdef __STDC__ + double asinh(double x) +#else + double asinh(x) + double x; +#endif +{ + double t,w; + int hx,ix; + hx = __HI(x); + ix = hx&0x7fffffff; + if(ix>=0x7ff00000) return x+x; /* x is inf or NaN */ + if(ix< 0x3e300000) { /* |x|<2**-28 */ + if(huge+x>one) return x; /* return x inexact except 0 */ + } + if(ix>0x41b00000) { /* |x| > 2**28 */ + w = __ieee754_log(fabs(x))+ln2; + } else if (ix>0x40000000) { /* 2**28 > |x| > 2.0 */ + t = fabs(x); + w = __ieee754_log(2.0*t+one/(sqrt(x*x+one)+t)); + } else { /* 2.0 > |x| > 2**-28 */ + t = x*x; + w =log1p(fabs(x)+t/(one+sqrt(one+t))); + } + if(hx>0) return w; else return -w; +} ----------------------------------------------------------------------- Summary of changes: src/lisp/e_acosh.c | 68 ++++++++++++++++++++++++++++++++++++++++++++++++ src/lisp/e_atanh.c | 73 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/lisp/fdlibm.h | 2 ++ src/lisp/s_asinh.c | 64 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 207 insertions(+) create mode 100644 src/lisp/e_acosh.c create mode 100644 src/lisp/e_atanh.c create mode 100644 src/lisp/s_asinh.c hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. 20e-6-g861ae22
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 861ae22a3596ca5e40530a734076d6dea131c273 (commit) from 61218b92d2f2ed8b83816a5037b1afb46c3c6619 (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 861ae22a3596ca5e40530a734076d6dea131c273 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Oct 23 19:47:38 2013 -0700 Update to ASDF 3.0.3. diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp index e90fae7..3592557 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 3.0.2: Another System Definition Facility. +;;; This is ASDF 3.0.3: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -54,7 +54,7 @@ (declaim (optimize (speed 1) (safety 3) (debug 3))) (setf ext:*gc-verbose* nil)) -#+(or abcl clisp clozure cmu ecl xcl) +#+(or abcl clisp clozure cmu ecl xcl) ;; punt on hard package upgrade on those implementations (eval-when (:load-toplevel :compile-toplevel :execute) (unless (member :asdf3 *features*) (let* ((existing-version @@ -71,7 +71,7 @@ (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 #+abcl 2.25 #+cmu 2.018 #-(or abcl cmu) 2.27)) + (< existing-version-number 2.27)) (rename-package :asdf away) (when *load-verbose* (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))) @@ -86,7 +86,7 @@ ;; CAUTION: we must handle the first few packages specially for hot-upgrade. ;; This package definition MUST NOT change unless its name too changes; ;; if/when it changes, don't forget to add new functions missing from below. - ;; Until then, asdf/package is frozen to forever + ;; Until then, uiop/package is frozen to forever ;; import and export the same exact symbols as for ASDF 2.27. ;; Any other symbol must be import-from'ed and re-export'ed in a different package. (:use :common-lisp) @@ -562,7 +562,14 @@ or when loading the package is optional." (home-package-p existing to-package) (symbol-package-name existing))) (t (ensure-inherited name symbol to-package from-package t shadowed imported inherited))))))) + (defun recycle-symbol (name recycle exported) + ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE + ;; packages, and a hash-table of names (strings) of symbols scheduled to be + ;; EXPORTED from the package being defined. It returns two values, the + ;; symbol found (if any, or else NIL), and a boolean flag indicating whether + ;; a symbol was found. The caller (DEFINE-PACKAGE) will then do the + ;; re-homing of the symbol, etc. (check-type name string) (check-type recycle list) (check-type exported hash-table) @@ -776,6 +783,28 @@ or when loading the package is optional." :mix ,mix :reexport ,reexport :unintern ,unintern))))) (defmacro define-package (package &rest clauses) + "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form +$KEYWORD . ARGS$. +DEFINE-PACKAGE supports the following keywords: +USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE. +RECYCLE -- Recycle the package's exported symbols from the specified packages, +in order. For every symbol scheduled to be exported by the DEFINE-PACKAGE, +either through an :EXPORT option or a :REEXPORT option, if the symbol exists in +one of the :RECYCLE packages, the first such symbol is re-homed to the package +being defined. +For the sake of idempotence, it is important that the package being defined +should appear in first position if it already exists, and even if it doesn't, +ahead of any package that is not going to be deleted afterwards and never +created again. In short, except for special cases, always make it the first +package on the list if the list is not empty. +MIX -- Takes a list of package designators. MIX behaves like +$:USE PKG1 PKG2 ... PKGn$ but additionally uses :SHADOWING-IMPORT-FROM to +resolve conflicts in favor of the first found symbol. It may still yield +an error if there is a conflict with an explicitly :SHADOWING-IMPORT-FROM symbol. +REEXPORT -- Takes a list of package designators. For each package, p, in the list, +export symbols with the same name as those exported from p. Note that in the case +of shadowing, etc. the symbols with the same name may not be the same symbols. +UNINTERN -- Remove symbols here from PACKAGE." (let ((ensure-form `(apply 'ensure-package ',(parse-define-package-form package clauses)))) `(progn @@ -846,10 +875,14 @@ or when loading the package is optional." ;;;; Early meta-level tweaks -#+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) - clozure lispworks (and sbcl sb-unicode) scl) +#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks sbcl scl) (eval-when (:load-toplevel :compile-toplevel :execute) - (pushnew :asdf-unicode *features*)) + ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode + ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. + (when (and #+allegro (member :ics *features*) + #+(or clisp cmu ecl mkcl) (member :unicode *features*) + #+sbcl (member :sb-unicode *features*)) + (pushnew :asdf-unicode *features*))) #+allegro (eval-when (:load-toplevel :compile-toplevel :execute) @@ -860,6 +893,20 @@ or when loading the package is optional." (setf excl:*warn-on-nested-reader-conditionals* nil)) (setf *print-readably* nil)) +#+clozure (in-package :ccl) +#+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117 +(eval-when (:load-toplevel :compile-toplevel :execute) + (unless (fboundp 'external-process-wait) + (in-development-mode + (defun external-process-wait (proc) + (when (and (external-process-pid proc) (eq (external-process-%status proc) :running)) + (with-interrupts-enabled + (wait-on-semaphore (external-process-completed proc)))) + (values (external-process-%exit-code proc) + (external-process-%status proc)))))) +#+clozure (in-package :uiop/common-lisp) + + #+cormanlisp (eval-when (:load-toplevel :compile-toplevel :execute) (deftype logical-pathname () nil) @@ -962,6 +1009,12 @@ or when loading the package is optional." ;;;; compatfmt: avoid fancy format directives when unsupported (eval-when (:load-toplevel :compile-toplevel :execute) (defun frob-substrings (string substrings &optional frob) + "for each substring in SUBSTRINGS, find occurrences of it within STRING +that don't use parts of matched occurrences of previous strings, and +FROB them, that is to say, remove them if FROB is NIL, +replace by FROB if FROB is a STRING, or if FROB is a FUNCTION, +call FROB with the match and a function that emits a string in the output. +Return a string made of the parts not omitted or emitted by FROB." (declare (optimize (speed 0) (safety 3) (debug 3))) (let ((length (length string)) (stream nil)) (labels ((emit-string (x &optional (start 0) (end (length x))) @@ -998,8 +1051,6 @@ or when loading the package is optional." #+(or gcl genera) (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>"))) #-(or gcl genera) format)) - - ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities for ASDF @@ -1007,7 +1058,7 @@ or when loading the package is optional." (:nicknames :asdf/utility) (:recycle :uiop/utility :asdf/utility :asdf) (:use :uiop/common-lisp :uiop/package) - ;; import and reexport a few things defined in :asdf/common-lisp + ;; import and reexport a few things defined in :uiop/common-lisp (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt @@ -1021,14 +1072,15 @@ or when loading the package is optional." #:remove-plist-keys #:remove-plist-key ;; plists #:emptyp ;; sequences #:+non-base-chars-exist-p+ ;; characters + #:+max-character-type-index+ #:character-type-index #:+character-types+ #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings - #:first-char #:last-char #:split-string + #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ #:string-prefix-p #:string-enclosed-p #:string-suffix-p #:find-class* ;; CLOS #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps #:earlier-stamp #:stamps-earliest #:earliest-stamp #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f - #:list-to-hash-set ;; hash-table + #:list-to-hash-set #:ensure-gethash ;; hash-table #:ensure-function #:access-at #:access-at-count ;; functions #:call-function #:call-functions #:register-hook-function #:match-condition-p #:match-any-condition-p ;; conditions @@ -1070,9 +1122,9 @@ or when loading the package is optional." ;; undefining the previous function is the portable way ;; of overriding any incompatible previous gf, except on CLISP. ;; We usually try to do it only for the functions that need it, - ;; which happens in asdf/upgrade - however, for ECL, we need this hammer, + ;; which happens in asdf/upgrade - however, for ECL, we need this hammer ;; (which causes issues in clisp) - ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) ; XXX + ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) `((undefine-function ',name))) #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl @@ -1188,23 +1240,54 @@ Returns two values: $A B C$ and $1 2 3$." ;;; Characters -(with-upgradability () +(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR. (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) +(with-upgradability () + (defparameter +character-types+ ;; assuming a simple hierarchy + #(#+non-base-chars-exist-p base-char #+lispworks lw:simple-char character)) + (defparameter +max-character-type-index+ (1- (length +character-types+)))) + +(with-upgradability () + (defun character-type-index (x) + (declare (ignorable x)) + #.(case +max-character-type-index+ + (0 0) + (1 '(etypecase x + (character (if (typep x 'base-char) 0 1)) + (symbol (if (subtypep x 'base-char) 0 1)))) + (otherwise + '(or (position-if (etypecase x + (character #'(lambda (type) (typep x type))) + (symbol #'(lambda (type) (subtypep x type)))) + +character-types+) + (error "Not a character or character type: ~S" x)))))) + ;;; Strings (with-upgradability () (defun base-string-p (string) + "Does the STRING only contain BASE-CHARs?" (declare (ignorable string)) (and #+non-base-chars-exist-p (eq 'base-char (array-element-type string)))) (defun strings-common-element-type (strings) + "What least subtype of CHARACTER can contain all the elements of all the 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)) + #.(if +non-base-chars-exist-p+ + `(aref +character-types+ + (loop :with index = 0 :for s :in strings :do + (cond + ((= index ,+max-character-type-index+) (return index)) + ((emptyp s)) ;; NIL or empty string + ((characterp s) (setf index (max index (character-type-index s)))) + ((stringp s) (unless (>= index (character-type-index (array-element-type s))) + (setf index (reduce 'max s :key #'character-type-index + :initial-value index)))) + (t (error "Invalid string designator ~S for ~S" s 'strings-common-element-type))) + :finally (return index))) + ''character)) (defun reduce/strcat (strings &key key start end) "Reduce a list as if by STRCAT, accepting KEY START and END keywords like REDUCE. @@ -1222,12 +1305,16 @@ NIL is interpreted as an empty string. A character is interpreted as a string of :finally (return output))) (defun strcat (&rest strings) + "Concatenate strings. +NIL is interpreted as an empty string, a character as a string of length one." (reduce/strcat strings)) (defun first-char (s) + "Return the first character of a non-empty string S, or NIL" (and (stringp s) (plusp (length s)) (char s 0))) (defun last-char (s) + "Return the last character of a non-empty string S, or NIL" (and (stringp s) (plusp (length s)) (char s (1- (length s))))) (defun split-string (string &key max (separator '(#\Space #\Tab))) @@ -1238,6 +1325,7 @@ starting the separation from the end, e.g. when called with arguments \"a.b.c.d.e\" :max 3 :separator \".\" it will return (\"a.b.c\" \"d\" \"e\")." (block () (let ((list nil) (words 0) (end (length string))) + (when (zerop end) (return nil)) (flet ((separatorp (char) (find char separator)) (done () (return (cons (subseq string 0 end) list)))) (loop @@ -1270,6 +1358,22 @@ starting the separation from the end, e.g. when called with arguments (and (string-prefix-p prefix string) (string-suffix-p string suffix)))) + (defvar +cr+ (coerce #(#\Return) 'string)) + (defvar +lf+ (coerce #(#\Linefeed) 'string)) + (defvar +crlf+ (coerce #(#\Return #\Linefeed) 'string)) + + (defun stripln (x) + "Strip a string X from any ending CR, LF or CRLF. +Return two values, the stripped string and the ending that was stripped, +or the original value and NIL if no stripping took place. +Since our STRCAT accepts NIL as empty string designator, +the two results passed to STRCAT always reconstitute the original string" + (check-type x string) + (block nil + (flet ((c (end) (when (string-suffix-p x end) + (return (values (subseq x 0 (- (length x) (length end))) end))))) + (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil))))) + ;;; CLOS (with-upgradability () @@ -1280,7 +1384,7 @@ starting the separation from the end, e.g. when called with arguments (symbol (find-class x errorp environment))))) -;;; stamps: a REAL or boolean where NIL=-infinity, T=+infinity +;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype stamp () '(or real boolean))) (with-upgradability () @@ -1304,12 +1408,6 @@ starting the separation from the end, e.g. when called with arguments (define-modify-macro latest-stamp-f (&rest stamps) latest-stamp)) -;;; Hash-tables -(with-upgradability () - (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) - (dolist (x list h) (setf (gethash x h) t)))) - - ;;; Function designators (with-upgradability () (defun ensure-function (fun &key (package :cl)) @@ -1320,14 +1418,17 @@ If the FUN is a non-sequence literal constant, return constantly that, i.e. for a boolean keyword character number or pathname. Otherwise if FUN is a non-literally constant symbol, return its FDEFINITION. If FUN is a CONS, return the function that applies its CAR -to the appended list of the rest of its CDR and the arguments. +to the appended list of the rest of its CDR and the arguments, +unless the CAR is LAMBDA, in which case the expression is evaluated. If FUN is a string, READ a form from it in the specified PACKAGE (default: CL) and EVAL that in a (FUNCTION ...) context." (etypecase fun (function fun) ((or boolean keyword character number pathname) (constantly fun)) - ((or function symbol) fun) - (cons #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args)))) + (symbol fun) + (cons (if (eq 'lambda (car fun)) + (eval fun) + #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))) (string (eval `(function ,(with-standard-io-syntax (let ((*package* (find-package package))) (read-from-string fun)))))))) @@ -1357,7 +1458,7 @@ instead of a list." (defun access-at-count (at) "From an AT specification, extract a COUNT of maximum number - of sub-objects to read as per ACCESS-AT" +of sub-objects to read as per ACCESS-AT" (cond ((integerp at) (1+ at)) @@ -1365,16 +1466,38 @@ instead of a list." (1+ (first at))))) (defun call-function (function-spec &rest arguments) + "Call the function designated by FUNCTION-SPEC as per ENSURE-FUNCTION, +with the given ARGUMENTS" (apply (ensure-function function-spec) arguments)) (defun call-functions (function-specs) + "For each function in the list FUNCTION-SPECS, in order, call the function as per CALL-FUNCTION" (map () 'call-function function-specs)) (defun register-hook-function (variable hook &optional call-now-p) - (pushnew hook (symbol-value variable)) + "Push the HOOK function (a designator as per ENSURE-FUNCTION) onto the hook VARIABLE. +When CALL-NOW-P is true, also call the function immediately." + (pushnew hook (symbol-value variable) :test 'equal) (when call-now-p (call-function hook)))) +;;; Hash-tables +(with-upgradability () + (defun ensure-gethash (key table default) + "Lookup the TABLE for a KEY as by gethash, but if not present, +call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION, +set the corresponding entry to the result in the table, and return that result." + (multiple-value-bind (value foundp) (gethash key table) + (if foundp + value + (setf (gethash key table) (values (call-function default)))))) + + (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) + "Convert a LIST into hash-table that has the same elements when viewed as a set, +up to the given equality TEST" + (dolist (x list h) (setf (gethash x h) t)))) + + ;;; Version handling (with-upgradability () (defun unparse-version (version-list) @@ -1471,6 +1594,7 @@ or a string describing the format-control of a simple-condition." (loop :for x :in conditions :thereis (match-condition-p x condition))) (defun call-with-muffled-conditions (thunk conditions) + "calls the THUNK in a context where the CONDITIONS are muffled" (handler-bind ((t #'(lambda (c) (when (match-any-condition-p c conditions) (muffle-warning c))))) (funcall thunk))) @@ -1478,7 +1602,6 @@ or a string describing the format-control of a simple-condition." (defmacro with-muffled-conditions ((conditions) &body body) `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) - ;;;; --------------------------------------------------------------------------- ;;;; Access to the Operating System @@ -1487,7 +1610,7 @@ or a string describing the format-control of a simple-condition." (:recycle :uiop/os :asdf/os :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility) (:export - #:featurep #:os-unix-p #:os-windows-p #:os-genera-p #:detect-os ;; features + #:featurep #:os-unix-p #:os-macosx-p #:os-windows-p #:os-genera-p #:detect-os ;; features #:getenv #:getenvp ;; environment variables #:implementation-identifier ;; implementation identifier #:implementation-type #:*implementation-type* @@ -1501,6 +1624,11 @@ or a string describing the format-control of a simple-condition." ;;; Features (with-upgradability () (defun featurep (x &optional (*features* *features*)) + "Checks whether a feature expression X is true with respect to the *FEATURES* set, +as per the CLHS standard for #+ and #-. Beware that just like the CLHS, +we assume symbols from the KEYWORD package are used, but that unless you're using #+/#- +your reader will not have magically used the KEYWORD package, so you need specify +keywords explicitly." (cond ((atom x) (and (member x *features*) t)) ((eq :not (car x)) (assert (null (cddr x))) (not (featurep (cadr x)))) @@ -1509,22 +1637,38 @@ or a string describing the format-control of a simple-condition." (t (error "Malformed feature specification ~S" x)))) (defun os-unix-p () + "Is the underlying operating system some Unix variant?" (or #+abcl (featurep :unix) #+(and (not abcl) (or unix cygwin darwin)) t)) + (defun os-macosx-p () + "Is the underlying operating system MacOS X?" + ;; OS-MACOSX is not mutually exclusive with OS-UNIX, + ;; in fact the former implies the latter. + (or + #+allegro (featurep :macosx) + #+clisp (featurep :macos) + (featurep :darwin))) + (defun os-windows-p () + "Is the underlying operating system Microsoft Windows?" (or #+abcl (featurep :windows) #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t)) (defun os-genera-p () + "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?" (or #+genera t)) (defun os-oldmac-p () + "Is the underlying operating system an (emulated?) MacOS 9 or earlier?" (or #+mcl t)) (defun detect-os () + "Detects the current operating system. Only needs be run at compile-time, +except on ABCL where it might change between FASL compilation and runtime." (loop* :with o :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p) + (:os-macosx . os-macosx-p) (:genera . os-genera-p) (:os-oldmac . os-oldmac-p)) :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*) :else :do (setf *features* (remove feature *features*)) @@ -1538,6 +1682,9 @@ that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port (with-upgradability () (defun getenv (x) + "Query the environment, as in C getenv. +Beware: may return empty string if a variable is present but empty; +use getenvp to return NIL in such a case." (declare (ignorable x)) #+(or abcl clisp ecl xcl) (ext:getenv x) #+allegro (sys:getenv x) @@ -1579,6 +1726,7 @@ then returning the non-empty string value of the variable" (with-upgradability () (defun first-feature (feature-sets) + "A helper for various feature detection functions" (dolist (x feature-sets) (multiple-value-bind (short long feature-expr) (if (consp x) @@ -1588,15 +1736,18 @@ then returning the non-empty string value of the variable" (return (values short long)))))) (defun implementation-type () + "The type of Lisp implementation used, as a short UIOP-standardized keyword" (first-feature '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) (:cmu :cmucl :cmu) :ecl :gcl (:lwpe :lispworks-personal-edition) (:lw :lispworks) :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) - (defvar *implementation-type* (implementation-type)) + (defvar *implementation-type* (implementation-type) + "The type of Lisp implementation used, as a short UIOP-standardized keyword") (defun operating-system () + "The operating system of the current host" (first-feature '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; try cygwin first! (:linux :linux :linux-target) ;; for GCL at least, must appear before :bsd @@ -1605,6 +1756,7 @@ then returning the non-empty string value of the variable" :genera))) (defun architecture () + "The CPU architecture of the current host" (first-feature '((:x64 :x86-64 :x86_64 :x8664-target :amd64 (:and :word-size=64 :pc386)) (:x86 :x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) @@ -1625,6 +1777,7 @@ then returning the non-empty string value of the variable" (error "Can't determine fasl version."))) (defun lisp-version-string () + "return a string that identifies the current Lisp implementation version" (let ((s (lisp-implementation-version))) (car ; as opposed to OR, this idiom prevents some unreachable code warning (list @@ -1660,6 +1813,8 @@ then returning the non-empty string value of the variable" s)))) (defun implementation-identifier () + "Return a string that identifies the ABI of the current implementation, +suitable for use as a directory name to segregate Lisp FASLs, C dynamic libraries, etc." (substitute-if #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) (format nil "~(~a~@{~@[-~a~]~}~)" @@ -1673,6 +1828,7 @@ then returning the non-empty string value of the variable" (with-upgradability () (defun hostname () + "return the hostname of the current host" ;; Note: untested on RMCL #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) #+cormanlisp "localhost" ;; is there a better way? Does it matter? @@ -1686,6 +1842,7 @@ then returning the non-empty string value of the variable" #+cmu (defun parse-unix-namestring* (unix-namestring) + "variant of LISP::PARSE-UNIX-NAMESTRING that returns a pathname object" (multiple-value-bind (host device directory name type version) (lisp::parse-unix-namestring unix-namestring 0 (length unix-namestring)) (make-pathname :host (or host lisp::*unix-host*) :device device @@ -1735,22 +1892,27 @@ then returning the non-empty string value of the variable" ;;;; Jesse Hager: The Windows Shortcut File Format. ;;;; http://www.wotsit.org/list.asp?fc=13 -#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera. +#-(or clisp genera) ; CLISP doesn't need it, and READ-SEQUENCE annoys old Genera that doesn't need it (with-upgradability () (defparameter *link-initial-dword* 76) (defparameter *link-guid* #(1 20 2 0 0 0 0 0 192 0 0 0 0 0 0 70)) (defun read-null-terminated-string (s) + "Read a null-terminated string from an octet stream S" + ;; note: doesn't play well with UNICODE (with-output-to-string (out) (loop :for code = (read-byte s) :until (zerop code) :do (write-char (code-char code) out)))) (defun read-little-endian (s &optional (bytes 4)) + "Read a number in little-endian format from an byte (octet) stream S, +the number having BYTES octets (defaulting to 4)." (loop :for i :from 0 :below bytes :sum (ash (read-byte s) (* 8 i)))) (defun parse-file-location-info (s) + "helper to parse-windows-shortcut" (let ((start (file-position s)) (total-length (read-little-endian s)) (end-of-header (read-little-endian s)) @@ -1774,6 +1936,8 @@ then returning the non-empty string value of the variable" (read-null-terminated-string s)))))) (defun parse-windows-shortcut (pathname) + "From a .lnk windows shortcut, extract the pathname linked to" + ;; NB: doesn't do much checking & doesn't look like it will work well with UNICODE. (with-open-file (s pathname :element-type '(unsigned-byte 8)) (handler-case (when (and (= (read-little-endian s) *link-initial-dword*) @@ -1822,7 +1986,7 @@ then returning the non-empty string value of the variable" #:merge-pathnames* #:nil-pathname #:*nil-pathname* #:with-pathname-defaults ;; Predicates - #:pathname-equal #:logical-pathname-p #:physical-pathname-p + #:pathname-equal #:logical-pathname-p #:physical-pathname-p #:physicalize-pathname #:absolute-pathname-p #:relative-pathname-p #:hidden-pathname-p #:file-pathname-p ;; Directories #:pathname-directory-pathname #:pathname-parent-directory-pathname @@ -1835,7 +1999,7 @@ then returning the non-empty string value of the variable" #:subpathname #:subpathname* #:ensure-absolute-pathname #:pathname-root #:pathname-host-pathname - #:subpathp + #:subpathp #:enough-pathname #:with-enough-pathname #:call-with-enough-pathname ;; Checking constraints #:ensure-pathname ;; implemented in filesystem.lisp to accommodate for existence constraints ;; Wildcard pathnames @@ -1851,7 +2015,9 @@ then returning the non-empty string value of the variable" (with-upgradability () (defun normalize-pathname-directory-component (directory) - "Given a pathname directory component, return an equivalent form that is a list" + "Convert the DIRECTORY component from a format usable by the underlying +implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format +that is a list and not a string." #+gcl2.6 (setf directory (substitute :back :parent directory)) (cond #-(or cmu sbcl scl) ;; these implementations already normalize directory components. @@ -1869,6 +2035,8 @@ then returning the non-empty string value of the variable" (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory)))) (defun denormalize-pathname-directory-component (directory-component) + "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable +by the underlying implementation's MAKE-PATHNAME and other primitives" #-gcl2.6 directory-component #+gcl2.6 (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back))) @@ -1879,7 +2047,7 @@ then returning the non-empty string value of the variable" (t d)))) (defun merge-pathname-directory-components (specified defaults) - ;; Helper for merge-pathnames* that handles directory components. + "Helper for MERGE-PATHNAMES* that handles directory components" (let ((directory (normalize-pathname-directory-component specified))) (ecase (first directory) ((nil) defaults) @@ -1906,7 +2074,8 @@ then returning the non-empty string value of the variable" ;; This will be :unspecific if supported, or NIL if not. (defparameter *unspecific-pathname-type* #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific - #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil) + #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil + "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp) host (device () #+allegro devicep) name type version defaults @@ -1947,11 +2116,11 @@ and make a new pathname with corresponding components and specified logical HOST if the SPECIFIED pathname does not have an absolute directory, then the HOST and DEVICE both come from the DEFAULTS, whereas if the SPECIFIED pathname does have an absolute directory, -then the HOST and DEVICE both come from the SPECIFIED. +then the HOST and DEVICE both come from the SPECIFIED pathname. This is what users want on a modern Unix or Windows operating system, -unlike the MERGE-PATHNAME behavior. +unlike the MERGE-PATHNAMES behavior. Also, if either argument is NIL, then the other argument is returned unmodified; -this is unlike MERGE-PATHNAME which always merges with a pathname, +this is unlike MERGE-PATHNAMES which always merges with a pathname, by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." (when (null specified) (return-from merge-pathnames* defaults)) (when (null defaults) (return-from merge-pathnames* specified)) @@ -1983,9 +2152,23 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." :type (funcall unspecific-handler type) :version (funcall unspecific-handler version)))))) + (defun logical-pathname-p (x) + "is X a logical-pathname?" + (typep x 'logical-pathname)) + + (defun physical-pathname-p (x) + "is X a pathname that is not a logical-pathname?" + (and (pathnamep x) (not (logical-pathname-p x)))) + + (defun physicalize-pathname (x) + "if X is a logical pathname, use translate-logical-pathname on it." + ;; Ought to be the same as translate-logical-pathname, except the latter borks on CLISP + (let ((p (when x (pathname x)))) + (if (logical-pathname-p p) (translate-logical-pathname p) p))) + (defun nil-pathname (&optional (defaults *default-pathname-defaults*)) "A pathname that is as neutral as possible for use as defaults - when merging, making or parsing pathnames" +when merging, making or parsing pathnames" ;; 19.2.2.2.1 says a NIL host can mean a default host; ;; see also "valid physical pathname host" in the CLHS glossary, that suggests ;; strings and lists of strings or :unspecific @@ -1999,15 +2182,20 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." ;; the default shouldn't matter, but we really want something physical #-mcl ,@'(:defaults defaults))) - (defvar *nil-pathname* (nil-pathname (translate-logical-pathname (user-homedir-pathname)))) + (defvar *nil-pathname* (nil-pathname (physicalize-pathname (user-homedir-pathname))) + "A pathname that is as neutral as possible for use as defaults +when merging, making or parsing pathnames") (defmacro with-pathname-defaults ((&optional defaults) &body body) + "Execute BODY in a context where the *DEFAULT-PATHNAME-DEFAULTS* are as neutral as possible +when merging, making or parsing pathnames" `(let ((*default-pathname-defaults* ,(or defaults '*nil-pathname*))) ,@body))) ;;; Some pathname predicates (with-upgradability () (defun pathname-equal (p1 p2) + "Are the two pathnames P1 and P2 reasonably equal in the paths they denote?" (when (stringp p1) (setf p1 (pathname p1))) (when (stringp p2) (setf p2 (pathname p2))) (flet ((normalize-component (x) @@ -2027,12 +2215,6 @@ by default *DEFAULT-PATHNAME-DEFAULTS*, which cannot be NIL." (=? pathname-type) (=? pathname-version))))))) - (defun logical-pathname-p (x) - (typep x 'logical-pathname)) - - (defun physical-pathname-p (x) - (and (pathnamep x) (not (logical-pathname-p x)))) - (defun absolute-pathname-p (pathspec) "If PATHSPEC is a pathname or namestring object that parses as a pathname possessing an :ABSOLUTE directory component, return the (parsed) pathname. @@ -2219,7 +2401,7 @@ The last #\\/-separated substring is interpreted as follows: 1- If TYPE is :DIRECTORY or ENSURE-DIRECTORY is true, the string is made the last directory component, and NAME and TYPE are NIL. if the string is empty, it's the empty pathname with all slots NIL. -2- If TYPE is NIL, the substring is file-namestring, and its NAME and TYPE +2- If TYPE is NIL, the substring is a file-namestring, and its NAME and TYPE are separated by SPLIT-NAME-TYPE. 3- If TYPE is a string, it is the given TYPE, and the whole string is the NAME. @@ -2228,7 +2410,7 @@ Any directory named .. is read as DOT-DOT, which must be one of :BACK or :UP and defaults to :BACK. HOST, DEVICE and VERSION components are taken from DEFAULTS, -which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS in NIL. +which itself defaults to *NIL-PATHNAME*, also used if DEFAULTS is NIL. No host or device can be specified in the string itself, which makes it unsuitable for absolute pathnames outside Unix. @@ -2329,6 +2511,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." (subpathname (ensure-directory-pathname pathname) subpath :type type))) (defun pathname-root (pathname) + "return the root directory for the host and device of given PATHNAME" (make-pathname* :directory '(:absolute) :name nil :type nil :version nil :defaults pathname ;; host device, and on scl, *some* @@ -2336,6 +2519,7 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun pathname-host-pathname (pathname) + "return a pathname with the same host as given PATHNAME, and all other fields NIL" (make-pathname* :directory nil :name nil :type nil :version nil :device nil :defaults pathname ;; host device, and on scl, *some* @@ -2343,6 +2527,8 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) (defun subpathp (maybe-subpath base-pathname) + "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that +when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." (and (pathnamep maybe-subpath) (pathnamep base-pathname) (absolute-pathname-p maybe-subpath) (absolute-pathname-p base-pathname) (directory-pathname-p base-pathname) (not (wild-pathname-p base-pathname)) @@ -2351,7 +2537,33 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." (let ((enough (enough-namestring maybe-subpath base-pathname))) (and (relative-pathname-p enough) (pathname enough)))))) + (defun enough-pathname (maybe-subpath base-pathname) + "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that +when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." + (check-type maybe-subpath (or null pathname)) + (check-type base-pathname (or null pathname)) + (when (pathnamep base-pathname) (assert (absolute-pathname-p base-pathname))) + (or (and base-pathname (subpathp maybe-subpath base-pathname)) + maybe-subpath)) + + (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) + "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null, +or else to its current value), call THUNK with ENOUGH-PATHNAME for MAYBE-SUBPATH +given DEFAULTS-PATHNAME as a base pathname." + (let ((enough (enough-pathname maybe-subpath defaults-pathname)) + (*default-pathname-defaults* (or defaults-pathname *default-pathname-defaults*))) + (funcall thunk enough))) + + (defmacro with-enough-pathname ((pathname-var &key (pathname pathname-var) + (defaults *default-pathname-defaults*)) + &body body) + "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME" + `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body))) + (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) + "Given a pathname designator PATH, return an absolute pathname as specified by PATH +considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior, +with a format control-string and other arguments as arguments" (cond ((absolute-pathname-p path)) ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error)) @@ -2370,28 +2582,37 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." ;;; Wildcard pathnames (with-upgradability () - (defparameter *wild* (or #+cormanlisp "*" :wild)) - (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild)) - (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors)) + (defparameter *wild* (or #+cormanlisp "*" :wild) + "Wild component for use with MAKE-PATHNAME") + (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild) + "Wild directory component for use with MAKE-PATHNAME") + (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors) + "Wild-inferiors directory component for use with MAKE-PATHNAME") (defparameter *wild-file* (make-pathname :directory nil :name *wild* :type *wild* - :version (or #-(or allegro abcl xcl) *wild*))) + :version (or #-(or allegro abcl xcl) *wild*)) + "A pathname object with wildcards for matching any file in a given directory") (defparameter *wild-directory* (make-pathname* :directory `(:relative ,*wild-directory-component*) - :name nil :type nil :version nil)) + :name nil :type nil :version nil) + "A pathname object with wildcards for matching any subdirectory") (defparameter *wild-inferiors* (make-pathname* :directory `(:relative ,*wild-inferiors-component*) - :name nil :type nil :version nil)) + :name nil :type nil :version nil) + "A pathname object with wildcards for matching any recursive subdirectory") (defparameter *wild-path* - (merge-pathnames* *wild-file* *wild-inferiors*)) + (merge-pathnames* *wild-file* *wild-inferiors*) + "A pathname object with wildcards for matching any file in any recursive subdirectory") (defun wilden (path) + "From a pathname, return a wildcard pathname matching any file in any subdirectory of given pathname's directory" (merge-pathnames* *wild-path* path))) ;;; Translate a pathname (with-upgradability () (defun relativize-directory-component (directory-component) + "Given the DIRECTORY-COMPONENT of a pathname, return an otherwise similar relative directory component" (let ((directory (normalize-pathname-directory-component directory-component))) (cond ((stringp directory) @@ -2402,17 +2623,21 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." directory)))) (defun relativize-pathname-directory (pathspec) + "Given a PATHNAME, return a relative pathname with otherwise the same components" (let ((p (pathname pathspec))) (make-pathname* :directory (relativize-directory-component (pathname-directory p)) :defaults p))) (defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) + "Given a PATHNAME, return the character used to delimit directory names on this host and device." (let ((foo (make-pathname* :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) #-scl (defun directorize-pathname-host-device (pathname) + "Given a PATHNAME, return a pathname that has representations of its HOST and DEVICE components +added to its DIRECTORY component. This is useful for output translations." #+(or unix abcl) (when (and #+abcl (os-unix-p) (physical-pathname-p pathname)) (return-from directorize-pathname-host-device pathname)) @@ -2457,6 +2682,13 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." pathname))) (defun* (translate-pathname*) (path absolute-source destination &optional root source) + "A wrapper around TRANSLATE-PATHNAME to be used by the ASDF output-translations facility. +PATH is the pathname to be translated. +ABSOLUTE-SOURCE is an absolute pathname to use as source for translate-pathname, +DESTINATION is either a function, to be called with PATH and ABSOLUTE-SOURCE, +or a relative pathname, to be merged with ROOT and used as destination for translate-pathname +or an absolute pathname, to be used as destination for translate-pathname. +In that last case, if ROOT is non-NIL, PATH is first transformated by DIRECTORIZE-PATHNAME-HOST-DEVICE." (declare (ignore source)) (cond ((functionp destination) @@ -2546,10 +2778,12 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" ;;; Probing the filesystem (with-upgradability () (defun truename* (p) + "Nicer variant of TRUENAME that plays well with NIL and avoids logical pathname contexts" ;; avoids both logical-pathname merging and physical resolution issues (and p (handler-case (with-pathname-defaults () (truename p)) (file-error () nil)))) (defun safe-file-write-date (pathname) + "Safe variant of FILE-WRITE-DATE that may return NIL rather than raise an error." ;; If FILE-WRITE-DATE returns NIL, it's possible that ;; the user or some other agent has deleted an input file. ;; Also, generated files will not exist at the time planning is done @@ -2559,7 +2793,7 @@ a CL pathname satisfying all the specified constraints as per ENSURE-PATHNAME" ;; as if the file were very old. ;; (or should we treat the case in a different, special way?) (and pathname - (handler-case (file-write-date (translate-logical-pathname pathname)) + (handler-case (file-write-date (physicalize-pathname pathname)) (file-error () nil)))) (defun probe-file* (p &key truename) @@ -2581,7 +2815,7 @@ or the original (parsed) pathname if it is false (the default)." (if truename (probe-file p) (ignore-errors - (let ((pp (translate-logical-pathname p))) + (let ((pp (physicalize-pathname p))) (and #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) #+(and lispworks unix) (system:get-file-stat pp) @@ -2616,23 +2850,31 @@ or the original (parsed) pathname if it is false (the default)." (file-error () nil))))))) (defun directory-exists-p (x) + "Is X the name of a directory that exists on the filesystem?" (let ((p (probe-file* x :truename t))) (and (directory-pathname-p p) p))) (defun file-exists-p (x) + "Is X the name of a file that exists on the filesystem?" (let ((p (probe-file* x :truename t))) (and (file-pathname-p p) p))) (defun directory* (pathname-spec &rest keys &key &allow-other-keys) + "Return a list of the entries in a directory by calling DIRECTORY. +Try to override the defaults to not resolving symlinks, if implementation allows." (apply 'directory pathname-spec (append keys '#.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) #+(or clozure digitool) '(:follow-links nil) #+clisp '(:circle t :if-does-not-exist :ignore) #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+lispworks '(:link-transparency nil) #+sbcl (when (find-symbol* :resolve-symlinks '#:sb-impl nil) '(:resolve-symlinks nil)))))) (defun filter-logical-directory-results (directory entries merger) + "Given ENTRIES in a DIRECTORY, remove if the directory is logical +the entries which are physical yet when transformed by MERGER have a different TRUENAME. +This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames." (if (logical-pathname-p directory) ;; Try hard to not resolve logical-pathname into physical pathnames; ;; otherwise logical-pathname users/lovers will be disappointed. @@ -2642,7 +2884,7 @@ or the original (parsed) pathname if it is false (the default)." ;; translating the LPN commute. (loop :for f :in entries :for p = (or (and (logical-pathname-p f) f) - (let* ((u (ignore-errors (funcall merger f)))) + (let* ((u (ignore-errors (call-function merger f)))) ;; The first u avoids a cumbersome (truename u) error. ;; At this point f should already be a truename, ;; but isn't quite in CLISP, for it doesn't have :version :newest @@ -2651,6 +2893,8 @@ or the original (parsed) pathname if it is false (the default)." entries)) (defun directory-files (directory &optional (pattern *wild-file*)) + "Return a list of the files in a directory according to the PATTERN, +which is not very portable to override. Try not resolve symlinks if implementation allows." (let ((dir (pathname directory))) (when (logical-pathname-p dir) ;; Because of the filtering we do below, @@ -2675,6 +2919,7 @@ or the original (parsed) pathname if it is false (the default)." :version (make-pathname-component-logical (pathname-version f)))))))) (defun subdirectories (directory) + "Given a DIRECTORY pathname designator, return a list of the subdirectories under it." (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* @@ -2712,6 +2957,9 @@ 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) + "Given a DIRECTORY, call-function the COLLECTOR function designator +on the directory if COLLECTP returns true when CALL-FUNCTION'ed with the directory, +and recurse each of its subdirectories on which the RECURSEP returns true when CALL-FUNCTION'ed with them." (when (call-function collectp directory) (call-function collector directory)) (dolist (subdir (subdirectories directory)) @@ -2745,6 +2993,7 @@ or the original (parsed) pathname if it is false (the default)." :finally (return p)))))) (defun resolve-symlinks (path) + "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH." #-allegro (truenamize path) #+allegro (if (physical-pathname-p path) @@ -2756,6 +3005,7 @@ or the original (parsed) pathname if it is false (the default)." Defaults to T.") (defun resolve-symlinks* (path) + "RESOLVE-SYMLINKS in PATH iff *RESOLVE-SYMLINKS* is T (the default)." (if *resolve-symlinks* (and path (resolve-symlinks path)) path))) @@ -2849,7 +3099,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (unless (pathnamep p) (return nil)) (check want-logical (logical-pathname-p p) "Expected a logical pathname") (check want-physical (physical-pathname-p p) "Expected a physical pathname") - (transform ensure-physical () (translate-logical-pathname p)) + (transform ensure-physical () (physicalize-pathname p)) (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") @@ -2886,14 +3136,18 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." ;;; Pathname defaults (with-upgradability () (defun get-pathname-defaults (&optional (defaults *default-pathname-defaults*)) + "Find the actual DEFAULTS to use for pathnames, including +resolving them with respect to GETCWD if the DEFAULTS were relative" (or (absolute-pathname-p defaults) (merge-pathnames* defaults (getcwd)))) (defun call-with-current-directory (dir thunk) + "call the THUNK in a context where the current directory was changed to DIR, if not NIL. +Note that this operation is usually NOT thread-safe." (if dir (let* ((dir (resolve-symlinks* (get-pathname-defaults (pathname-directory-pathname dir)))) - (*default-pathname-defaults* dir) - (cwd (getcwd))) + (cwd (getcwd)) + (*default-pathname-defaults* dir)) (chdir dir) (unwind-protect (funcall thunk) @@ -2908,13 +3162,18 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." ;;; Environment pathnames (with-upgradability () (defun inter-directory-separator () + "What character does the current OS conventionally uses to separate directories?" (if (os-unix-p) #\: #\;)) (defun split-native-pathnames-string (string &rest constraints &key &allow-other-keys) + "Given a string of pathnames specified in native OS syntax, separate them in a list, +check constraints and normalize each one as per ENSURE-PATHNAME." (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 ensure-directory want-directory on-error &allow-other-keys) + "Extract a pathname from a user-configured environment variable, as per native OS, +check constraints and normalize as per ENSURE-PATHNAME." ;; For backward compatibility with ASDF 2, want-directory implies ensure-directory (apply 'parse-native-namestring (getenvp x) :ensure-directory (or ensure-directory want-directory) @@ -2922,16 +3181,23 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathname ,x)) constraints)) (defun getenv-pathnames (x &rest constraints &key on-error &allow-other-keys) + "Extract a list of pathname from a user-configured environment variable, as per native OS, +check constraints and normalize each one as per ENSURE-PATHNAME." (apply 'split-native-pathnames-string (getenvp x) :on-error (or on-error `(error "In (~S ~S), invalid pathname ~*~S: ~*~?" getenv-pathnames ,x)) constraints)) (defun getenv-absolute-directory (x) + "Extract an absolute directory pathname from a user-configured environment variable, +as per native OS" (getenv-pathname x :want-absolute t :ensure-directory t)) (defun getenv-absolute-directories (x) + "Extract a list of absolute directories from a user-configured environment variable, +as per native OS" (getenv-pathnames x :want-absolute t :ensure-directory t)) (defun lisp-implementation-directory (&key truename) + "Where are the system files of the current installation of the CL implementation?" (declare (ignorable truename)) #+(or clozure ecl gcl mkcl sbcl) (let ((dir @@ -2947,6 +3213,7 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." dir))) (defun lisp-implementation-pathname-p (pathname) + "Is the PATHNAME under the current installation of the CL implementation?" ;; Other builtin systems are those under the implementation directory (and (when pathname (if-let (impdir (lisp-implementation-directory)) @@ -2961,18 +3228,23 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." ;;; Simple filesystem operations (with-upgradability () (defun ensure-all-directories-exist (pathnames) + "Ensure that for every pathname in PATHNAMES, we ensure its directories exist" (dolist (pathname pathnames) (when pathname - (ensure-directories-exist (translate-logical-pathname pathname))))) + (ensure-directories-exist (physicalize-pathname pathname))))) (defun rename-file-overwriting-target (source target) - #+clisp ;; But for a bug in CLISP 2.48, we should use :if-exists :overwrite and be atomic - (posix:copy-file source target :method :rename) + "Rename a file, overwriting any previous file with the TARGET name, +in an atomic way if the implementation allows." + #+clisp ;; in recent enough versions of CLISP, :if-exists :overwrite would make it atomic + (progn (funcall 'require "syscalls") + (symbol-call :posix :copy-file source target :method :rename)) #-clisp (rename-file source target #+clozure :if-exists #+clozure :rename-and-delete)) (defun delete-file-if-exists (x) + "Delete a file X if it already exists" (when x (handler-case (delete-file x) (file-error () nil)))) (defun delete-empty-directory (directory-pathname) @@ -2995,8 +3267,9 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." #+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 + #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) + #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl xcl) + (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera (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. @@ -3061,19 +3334,24 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (:recycle :uiop/stream :asdf/stream :asdf) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/filesystem) (:export - #:*default-stream-element-type* #:*stderr* #:setup-stderr + #:*default-stream-element-type* + #:*stdin* #:setup-stdin #:*stdout* #:setup-stdout #:*stderr* #:setup-stderr #:detect-encoding #:*encoding-detection-hook* #:always-default-encoding #:encoding-external-format #:*encoding-external-format-hook* #:default-encoding-external-format #:*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-output-file #:call-with-output-file + #:null-device-pathname #:call-with-null-input #:with-null-input + #:call-with-null-output #:with-null-output #:finish-outputs #:format! #:safe-format! #: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 + #:read-file-string #:read-file-line #:read-file-lines #:safe-read-file-line + #:read-file-forms #:read-file-form #:safe-read-file-form #:eval-input #:eval-thunk #:standard-eval-thunk + #:println #:writeln ;; Temporary files #:*temporary-directory* #:temporary-directory #:default-temporary-directory #:setup-temporary-directory @@ -3083,18 +3361,48 @@ If you're suicidal or extremely confident, just use :VALIDATE T." (in-package :uiop/stream) (with-upgradability () - (defvar *default-stream-element-type* (or #+(or abcl cmu cormanlisp scl xcl) 'character :default) + (defvar *default-stream-element-type* + (or #+(or abcl cmu cormanlisp scl xcl) 'character + #+lispworks 'lw:simple-char + :default) "default element-type for open (depends on the current CL implementation)") + (defvar *stdin* *standard-input* + "the original standard input stream at startup") + + (defun setup-stdin () + (setf *stdin* + #.(or #+clozure 'ccl::*stdin* + #+(or cmu scl) 'system:*stdin* + #+ecl 'ext::+process-standard-input+ + #+sbcl 'sb-sys:*stdin* + '*standard-input*))) + + (defvar *stdout* *standard-output* + "the original standard output stream at startup") + + (defun setup-stdout () + (setf *stdout* + #.(or #+clozure 'ccl::*stdout* + #+(or cmu scl) 'system:*stdout* + #+ecl 'ext::+process-standard-output+ + #+sbcl 'sb-sys:*stdout* + '*standard-output*))) + (defvar *stderr* *error-output* "the original error output stream at startup") (defun setup-stderr () (setf *stderr* - #+allegro excl::*stderr* - #+clozure ccl::*stderr* - #-(or allegro clozure) *error-output*)) - (setup-stderr)) + #.(or #+allegro 'excl::*stderr* + #+clozure 'ccl::*stderr* + #+(or cmu scl) 'system:*stderr* + #+ecl 'ext::+process-error-output+ + #+sbcl 'sb-sys:*stderr* + '*error-output*))) + + ;; Run them now. In image.lisp, we'll register them to be run at image restart. + (setup-stdin) (setup-stdout) (setup-stderr)) ;;; Encodings (mostly hooks only; full support requires asdf-encodings) @@ -3113,9 +3421,9 @@ reading emacs-style -*- coding: utf-8 -*- specifications, and falling back to utf-8 or latin1 if nothing is specified.") (defparameter *utf-8-external-format* - #+(and asdf-unicode (not clisp)) :utf-8 - #+(and asdf-unicode clisp) charset:utf-8 - #-asdf-unicode :default + (if (featurep :asdf-unicode) + (or #+clisp charset:utf-8 :utf-8) + :default) "Default :external-format argument to pass to CL:OPEN and also CL:LOAD or CL:COMPILE-FILE to best process a UTF-8 encoded file. On modern implementations, this will decode UTF-8 code points as CL characters. @@ -3124,6 +3432,8 @@ with non-ASCII code points being read as several CL characters; hopefully, if done consistently, that won't affect program behavior too much.") (defun always-default-encoding (pathname) + "Trivial function to use as *encoding-detection-hook*, +always 'detects' the *default-encoding*" (declare (ignore pathname)) *default-encoding*) @@ -3131,11 +3441,15 @@ hopefully, if done consistently, that won't affect program behavior too much.") "Hook for an extension to define a function to automatically detect a file's encoding") (defun detect-encoding (pathname) + "Detects the encoding of a specified file, going through user-configurable hooks" (if (and pathname (not (directory-pathname-p pathname)) (probe-file* pathname)) (funcall *encoding-detection-hook* pathname) *default-encoding*)) (defun default-encoding-external-format (encoding) + "Default, ignorant, function to transform a character ENCODING as a +portable keyword to an implementation-dependent EXTERNAL-FORMAT specification. +Load system ASDF-ENCODINGS to hook in a better one." (case encoding (:default :default) ;; for backward-compatibility only. Explicit usage discouraged. (:utf-8 *utf-8-external-format*) @@ -3145,16 +3459,20 @@ hopefully, if done consistently, that won't affect program behavior too much.") (defvar *encoding-external-format-hook* #'default-encoding-external-format - "Hook for an extension to define a mapping between non-default encodings -and implementation-defined external-format's") + "Hook for an extension (e.g. ASDF-ENCODINGS) to define a better mapping +from non-default encodings to and implementation-defined external-format's") (defun encoding-external-format (encoding) + "Transform a portable ENCODING keyword to an implementation-dependent EXTERNAL-FORMAT, +going through all the proper hooks." (funcall *encoding-external-format-hook* (or encoding *default-encoding*)))) ;;; Safe syntax (with-upgradability () - (defvar *standard-readtable* (copy-readtable nil)) + (defvar *standard-readtable* (with-standard-io-syntax *readtable*) + "The standard readtable, implementing the syntax specified by the CLHS. +It must never be modified, though only good implementations will even enforce that.") (defmacro with-safe-io-syntax ((&key (package :cl)) &body body) "Establish safe CL reader options around the evaluation of BODY" @@ -3169,10 +3487,10 @@ and implementation-defined external-format's") (funcall thunk)))) (defun safe-read-from-string (string &key (package :cl) (eof-error-p t) eof-value (start 0) end preserve-whitespace) + "Read from STRING using a safe syntax, as per WITH-SAFE-IO-SYNTAX" (with-safe-io-syntax (:package package) (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace)))) - ;;; Output to a stream or string, FORMAT-style (with-upgradability () (defun call-with-output (output function) @@ -3269,6 +3587,40 @@ Other keys are accepted but discarded." (declare (ignore element-type external-format if-exists if-does-not-exist)) `(call-with-output-file ,pathname #'(lambda (,var) ,@body) ,@keys))) +;;; Null device +(with-upgradability () + (defun null-device-pathname () + "Pathname to a bit bucket device that discards any information written to it +and always returns EOF when read from" + (cond + ((os-unix-p) #p"/dev/null") + ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax? + (t (error "No /dev/null on your OS")))) + (defun call-with-null-input (fun &rest keys &key element-type external-format if-does-not-exist) + (declare (ignore element-type external-format if-does-not-exist)) + (apply 'call-with-input-file (null-device-pathname) fun keys)) + (defmacro with-null-input ((var &rest keys + &key element-type external-format if-does-not-exist) + &body body) + (declare (ignore element-type external-format if-does-not-exist)) + "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device." + `(call-with-null-input #'(lambda (,var) ,@body) ,@keys)) + (defun call-with-null-output (fun + &key (element-type *default-stream-element-type*) + (external-format *utf-8-external-format*) + (if-exists :overwrite) + (if-does-not-exist :error)) + (call-with-output-file + (null-device-pathname) fun + :element-type element-type :external-format external-format + :if-exists if-exists :if-does-not-exist if-does-not-exist)) + (defmacro with-null-output ((var &rest keys + &key element-type external-format if-does-not-exist if-exists) + &body body) + "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device." + (declare (ignore element-type external-format if-exists if-does-not-exist)) + `(call-with-null-output #'(lambda (,var) ,@body) ,@keys))) + ;;; Ensure output buffers are flushed (with-upgradability () (defun finish-outputs (&rest streams) @@ -3276,8 +3628,8 @@ Other keys are accepted but discarded." Useful for portably flushing I/O before user input or program exit." ;; CCL notably buffers its stream output by default. (dolist (s (append streams - (list *stderr* *error-output* *standard-output* *trace-output* - *debug-io* *terminal-io* *debug-io* *query-io*))) + (list *stdout* *stderr* *error-output* *standard-output* *trace-output* + *debug-io* *terminal-io* *query-io*))) (ignore-errors (finish-output s))) (values)) @@ -3285,9 +3637,11 @@ Useful for portably flushing I/O before user input or program exit." "Just like format, but call finish-outputs before and after the output." (finish-outputs stream) (apply 'format stream format args) - (finish-output stream)) + (finish-outputs stream)) (defun safe-format! (stream format &rest args) + "Variant of FORMAT that is safe against both +dangerous syntax configuration and errors while printing." (with-safe-io-syntax () (ignore-errors (apply 'format! stream format args)) (finish-outputs stream)))) ; just in case format failed @@ -3317,6 +3671,7 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." (when (< end buffer-size) (return)))))) (defun concatenate-files (inputs output) + "create a new OUTPUT file the contents of which a the concatenate of the INPUTS files." (with-open-file (o output :element-type '(unsigned-byte 8) :direction :output :if-exists :rename-and-delete) (dolist (input inputs) @@ -3325,25 +3680,32 @@ Otherwise, using WRITE-SEQUENCE using a buffer of size BUFFER-SIZE." (copy-stream-to-stream i o :element-type '(unsigned-byte 8)))))) (defun copy-file (input output) + "Copy contents of the INPUT file to the OUTPUT file" ;; 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)) + (defun slurp-stream-string (input &key (element-type 'character) stripped) "Read the contents of the INPUT stream as a string" - (with-open-stream (input input) - (with-output-to-string (output) - (copy-stream-to-stream input output :element-type element-type)))) + (let ((string + (with-open-stream (input input) + (with-output-to-string (output) + (copy-stream-to-stream input output :element-type element-type))))) + (if stripped (stripln string) string))) (defun slurp-stream-lines (input &key count) "Read the contents of the INPUT stream as a list of lines, return those lines. +Note: relies on the Lisp's READ-LINE, but additionally removes any remaining CR +from the line-ending if the file or stream had CR+LF but Lisp only removed LF. + Read no more than COUNT lines." (check-type count (or null integer)) (with-open-stream (input input) (loop :for n :from 0 :for l = (and (or (not count) (< n count)) (read-line input nil nil)) - :while l :collect l))) + ;; stripln: to remove CR when the OS sends CRLF and Lisp only remove LF + :while l :collect (stripln l)))) (defun slurp-stream-line (input &key (at 0)) "Read the contents of the INPUT stream as a list of lines, @@ -3396,6 +3758,14 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" (apply 'call-with-input-file file 'slurp-stream-lines keys)) + (defun read-file-line (file &rest keys &key (at 0) &allow-other-keys) + "Open input FILE with option KEYS (except AT), +and read its contents as per SLURP-STREAM-LINE with given AT specifier. +BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" + (apply 'call-with-input-file file + #'(lambda (input) (slurp-stream-line input :at at)) + (remove-plist-key :at keys))) + (defun read-file-forms (file &rest keys &key count &allow-other-keys) "Open input FILE with option KEYS (except COUNT), and read its contents as per SLURP-STREAM-FORMS with given COUNT. @@ -3412,6 +3782,13 @@ BEWARE: be sure to use WITH-SAFE-IO-SYNTAX, or some variant thereof" #'(lambda (input) (slurp-stream-form input :at at)) (remove-plist-key :at keys))) + (defun safe-read-file-line (pathname &rest keys &key (package :cl) &allow-other-keys) + "Reads the specified line from the top of a file using a safe standardized syntax. +Extracts the line using READ-FILE-LINE, +within an WITH-SAFE-IO-SYNTAX using the specified PACKAGE." + (with-safe-io-syntax (:package package) + (apply 'read-file-line pathname (remove-plist-key :package keys)))) + (defun safe-read-file-form (pathname &rest keys &key (package :cl) &allow-other-keys) "Reads the specified form from the top of a file using a safe standardized syntax. Extracts the form using READ-FILE-FORM, @@ -3448,10 +3825,20 @@ If a string, repeatedly read and evaluate from it, returning the last values." (let ((*read-eval* t)) (eval-thunk thunk)))))) +(with-upgradability () + (defun println (x &optional (stream *standard-output*)) + "Variant of PRINC that also calls TERPRI afterwards" + (princ x stream) (terpri stream) (values)) + + (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys) + "Variant of WRITE that also calls TERPRI afterwards" + (apply 'write x keys) (terpri stream) (values))) + ;;; Using temporary files (with-upgradability () (defun default-temporary-directory () + "Return a default directory to use for temporary files" (or (when (os-unix-p) (or (getenv-pathname "TMPDIR" :ensure-directory t) @@ -3460,71 +3847,99 @@ If a string, repeatedly read and evaluate from it, returning the last values." (getenv-pathname "TEMP" :ensure-directory t)) (subpathname (user-homedir-pathname) "tmp/"))) - (defvar *temporary-directory* nil) + (defvar *temporary-directory* nil "User-configurable location for temporary files") (defun temporary-directory () + "Return a directory to use for temporary files" (or *temporary-directory* (default-temporary-directory))) (defun setup-temporary-directory () + "Configure a default temporary directory to use." (setf *temporary-directory* (default-temporary-directory)) ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1 #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*)) (defun call-with-temporary-file (thunk &key + (want-stream-p t) (want-pathname-p t) prefix keep (direction :io) (element-type *default-stream-element-type*) - (external-format :default)) + (external-format *utf-8-external-format*)) + "Call a THUNK with STREAM and PATHNAME arguments identifying a temporary file. +The pathname will be based on appending a random suffix to PREFIX. +This utility will KEEP the file past its extent if and only if explicitly requested. +The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT." #+gcl2.6 (declare (ignorable external-format)) (check-type direction (member :output :io)) + (assert (or want-stream-p want-pathname-p)) (loop :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory)) + :with results = () :for counter :from (random (ash 1 32)) - :for pathname = (pathname (format nil "~A~36R" prefix counter)) :do + :for pathname = (pathname (format nil "~A~36R" prefix counter)) + :for okp = nil :do ;; TODO: on Unix, do something about umask ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL - ;; TODO: on Unix, use CFFI and mkstemp -- but asdf/driver is precisely meant to not depend on CFFI or on anything! Grrrr. - (with-open-file (stream pathname - :direction direction - :element-type element-type - #-gcl2.6 :external-format #-gcl2.6 external-format - :if-exists nil :if-does-not-exist :create) - (when stream - (return - (if keep - (funcall thunk stream pathname) - (unwind-protect - (funcall thunk stream pathname) - (ignore-errors (delete-file pathname))))))))) + ;; TODO: on Unix, use CFFI and mkstemp -- but UIOP is precisely meant to not depend on CFFI or on anything! Grrrr. + (unwind-protect + (progn + (with-open-file (stream pathname + :direction direction + :element-type element-type + #-gcl2.6 :external-format #-gcl2.6 external-format + :if-exists nil :if-does-not-exist :create) + (when stream + (setf okp pathname) + (when want-stream-p + (setf results + (multiple-value-list + (if want-pathname-p + (funcall thunk stream pathname) + (funcall thunk stream))))))) + (when okp + (if want-stream-p + (return (apply 'values results)) + (return (funcall thunk pathname))))) + (when (and okp (not keep)) + (ignore-errors (delete-file-if-exists okp)))))) (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) (pathname (gensym "PATHNAME") pathnamep) prefix keep direction element-type external-format) &body body) "Evaluate BODY where the symbols specified by keyword arguments -STREAM and PATHNAME are bound corresponding to a newly created temporary file -ready for I/O. Unless KEEP is specified, delete the file afterwards." +STREAM and PATHNAME (if respectively specified) are bound corresponding +to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE. +The STREAM will be closed if no binding is specified. +Unless KEEP is specified, delete the file afterwards." (check-type stream symbol) (check-type pathname symbol) - `(flet ((think (,stream ,pathname) - ,@(unless pathnamep `((declare (ignore ,pathname)))) - ,@(unless streamp `((when ,stream (close ,stream)))) + (assert (or streamp pathnamep)) + `(flet ((think (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@body)) #-gcl (declare (dynamic-extent #'think)) (call-with-temporary-file #'think + :want-stream-p ,streamp + :want-pathname-p ,pathnamep ,@(when direction `(:direction ,direction)) ,@(when prefix `(:prefix ,prefix)) ,@(when keep `(:keep ,keep)) ,@(when element-type `(:element-type ,element-type)) - ,@(when external-format `(:external-format external-format))))) + ,@(when external-format `(:external-format ,external-format))))) + + (defun get-temporary-file (&key prefix) + (with-temporary-file (:pathname pn :keep t :prefix prefix) + pn)) ;; Temporary pathnames in simple cases where no contention is assumed (defun add-pathname-suffix (pathname suffix) + "Add a SUFFIX to the name of a PATHNAME, return a new pathname" (make-pathname :name (strcat (pathname-name pathname) suffix) :defaults pathname)) (defun tmpize-pathname (x) + "Return a new pathname modified from X by adding a trivial deterministic suffix" (add-pathname-suffix x "-ASDF-TMP")) (defun call-with-staging-pathname (pathname fun) @@ -3677,6 +4092,7 @@ This is designed to abstract away the implementation specific quit forms." stream)) (defun print-backtrace (&rest keys &key stream count) + "Print a backtrace" (declare (ignore stream count)) (with-safe-io-syntax (:package :cl) (let ((*print-readably* nil) @@ -3688,6 +4104,7 @@ This is designed to abstract away the implementation specific quit forms." (ignore-errors (apply 'raw-print-backtrace keys))))) (defun print-condition-backtrace (condition &key (stream *stderr*) count) + "Print a condition after a backtrace triggered by that condition" ;; We print the condition *after* the backtrace, ;; for the sake of who sees the backtrace at a terminal. ;; It is up to the caller to print the condition *before*, with some context. @@ -3697,10 +4114,12 @@ This is designed to abstract away the implementation specific quit forms." condition))) (defun fatal-condition-p (condition) + "Is the CONDITION fatal? It is if it matches any in *FATAL-CONDITIONS*" (match-any-condition-p condition *fatal-conditions*)) (defun handle-fatal-condition (condition) - "Depending on whether *LISP-INTERACTION* is set, enter debugger or die" + "Handle a fatal CONDITION: +depending on whether *LISP-INTERACTION* is set, enter debugger or die" (cond (*lisp-interaction* (invoke-debugger condition)) @@ -3710,10 +4129,12 @@ This is designed to abstract away the implementation specific quit forms." (die 99 "~A" condition)))) (defun call-with-fatal-condition-handler (thunk) + "Call THUNK in a context where fatal conditions are appropriately handled" (handler-bind (((satisfies fatal-condition-p) #'handle-fatal-condition)) (funcall thunk))) (defmacro with-fatal-condition-handler ((&optional) &body body) + "Execute BODY in a context where fatal conditions are appropriately handled" `(call-with-fatal-condition-handler #'(lambda () ,@body))) (defun shell-boolean-exit (x) @@ -3724,15 +4145,19 @@ This is designed to abstract away the implementation specific quit forms." ;;; Using image hooks (with-upgradability () (defun register-image-restore-hook (hook &optional (call-now-p t)) + "Regiter a hook function to be run when restoring a dumped image" (register-hook-function '*image-restore-hook* hook call-now-p)) (defun register-image-dump-hook (hook &optional (call-now-p nil)) + "Register a the hook function to be run before to dump an image" (register-hook-function '*image-dump-hook* hook call-now-p)) (defun call-image-restore-hook () + "Call the hook functions registered to be run when restoring a dumped image" (call-functions (reverse *image-restore-hook*))) (defun call-image-dump-hook () + "Call the hook functions registered to be run before to dump an image" (call-functions *image-dump-hook*))) @@ -3776,6 +4201,8 @@ if we are not called from a directly executable image." ((:prelude *image-prelude*) *image-prelude*) ((:entry-point *image-entry-point*) *image-entry-point*) (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) + "From a freshly restarted Lisp image, restore the saved Lisp environment +by setting appropriate variables, running various hooks, and calling any specified entry point." (when *image-restored-p* (if if-already-restored (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t)) @@ -3801,6 +4228,7 @@ if we are not called from a directly executable image." ((:postlude *image-postlude*) *image-postlude*) ((:dump-hook *image-dump-hook*) *image-dump-hook*) #+clozure prepend-symbols #+clozure (purify t)) + "Dump an image of the current Lisp environment at pathname FILENAME, with various options" (declare (ignorable filename output-name executable)) (setf *image-dumped-p* (if executable :executable t)) (setf *image-restored-p* :in-regress) @@ -3867,6 +4295,7 @@ if we are not called from a directly executable image." (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)) + "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options" ;; 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. @@ -3893,7 +4322,8 @@ if we are not called from a directly executable image." ;;; Some universal image restore hooks (with-upgradability () (map () 'register-image-restore-hook - '(setup-temporary-directory setup-stderr setup-command-line-arguments + '(setup-stdin setup-stdout setup-stderr + setup-command-line-arguments setup-temporary-directory #+abcl detect-os))) ;;;; ------------------------------------------------------------------------- ;;;; run-program initially from xcvb-driver. @@ -3909,7 +4339,7 @@ if we are not called from a directly executable image." #:escape-token #:escape-command ;;; run-program - #:slurp-input-stream + #:slurp-input-stream #:vomit-output-stream #:run-program #:subprocess-error #:subprocess-error-code #:subprocess-error-command #:subprocess-error-process @@ -3989,16 +4419,17 @@ omit the outer double-quotes if key argument :QUOTE is NIL" (when quote (princ #\" s))) (defun easy-sh-character-p (x) + "Is X an \"easy\" character that does not require quoting by the shell?" (or (alphanumericp x) (find x "+-_.,%@:/"))) (defun escape-sh-token (token &optional s) "Escape a string TOKEN within double-quotes if needed for use within a POSIX Bourne shell, outputing to S." - (escape-token token :stream s :quote #\" :good-chars - #'easy-sh-character-p + (escape-token token :stream s :quote #\" :good-chars #'easy-sh-character-p :escaper 'escape-sh-token-within-double-quotes)) (defun escape-shell-token (token &optional s) + "Escape a token for the current operating system shell" (cond ((os-unix-p) (escape-sh-token token s)) ((os-windows-p) (escape-windows-token token s)))) @@ -4033,43 +4464,74 @@ 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)) + (defun call-stream-processor (fun processor stream) + "Given FUN (typically SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM, +a PROCESSOR specification which is either an atom or a list specifying +a processor an keyword arguments, call the specified processor with +the given STREAM as input" + (if (consp processor) + (apply fun (first processor) stream (rest processor)) + (funcall fun processor stream))) + + (defgeneric slurp-input-stream (processor input-stream &key) + (:documentation + "SLURP-INPUT-STREAM is a generic function with two positional arguments +PROCESSOR and INPUT-STREAM and additional keyword arguments, that consumes (slurps) +the contents of the INPUT-STREAM and processes them according to a method +specified by PROCESSOR. + +Built-in methods include the following: +* if PROCESSOR is a function, it is called with the INPUT-STREAM as its argument +* if PROCESSOR is a list, its first element should be a function. It will be applied to a cons of the + INPUT-STREAM and the rest of the list. That is (x . y) will be treated as + $APPLY x <stream> y$ +* if PROCESSOR is an output-stream, the contents of INPUT-STREAM is copied to the output-stream, + per copy-stream-to-stream, with appropriate keyword arguments. +* if PROCESSOR is the symbol CL:STRING or the keyword :STRING, then the contents of INPUT-STREAM + are returned as a string, as per SLURP-STREAM-STRING. +* if PROCESSOR is the keyword :LINES then the INPUT-STREAM will be handled by SLURP-STREAM-LINES. +* if PROCESSOR is the keyword :LINE then the INPUT-STREAM will be handled by SLURP-STREAM-LINE. +* if PROCESSOR is the keyword :FORMS then the INPUT-STREAM will be handled by SLURP-STREAM-FORMS. +* if PROCESSOR is the keyword :FORM then the INPUT-STREAM will be handled by SLURP-STREAM-FORM. +* if PROCESSOR is T, it is treated the same as *standard-output*. If it is NIL, NIL is returned. + +Programmers are encouraged to define their own methods for this generic function.")) #-(or gcl2.6 genera) - (defmethod slurp-input-stream ((function function) input-stream &key &allow-other-keys) + (defmethod slurp-input-stream ((function function) input-stream &key) (funcall function input-stream)) - (defmethod slurp-input-stream ((list cons) input-stream &key &allow-other-keys) - (apply (first list) (cons input-stream (rest list)))) + (defmethod slurp-input-stream ((list cons) input-stream &key) + (apply (first list) input-stream (rest list))) #-(or gcl2.6 genera) (defmethod slurp-input-stream ((output-stream stream) input-stream - &key linewise prefix (element-type 'character) buffer-size &allow-other-keys) + &key linewise prefix (element-type 'character) buffer-size) (copy-stream-to-stream input-stream output-stream :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) - (defmethod slurp-input-stream ((x (eql 'string)) stream &key &allow-other-keys) + (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped) (declare (ignorable x)) - (slurp-stream-string stream)) + (slurp-stream-string stream :stripped stripped)) - (defmethod slurp-input-stream ((x (eql :string)) stream &key &allow-other-keys) + (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped) (declare (ignorable x)) - (slurp-stream-string stream)) + (slurp-stream-string stream :stripped stripped)) - (defmethod slurp-input-stream ((x (eql :lines)) stream &key count &allow-other-keys) + (defmethod slurp-input-stream ((x (eql :lines)) stream &key count) (declare (ignorable x)) (slurp-stream-lines stream :count count)) - (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0) &allow-other-keys) + (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0)) (declare (ignorable x)) (slurp-stream-line stream :at at)) - (defmethod slurp-input-stream ((x (eql :forms)) stream &key count &allow-other-keys) + (defmethod slurp-input-stream ((x (eql :forms)) stream &key count) (declare (ignorable x)) (slurp-stream-forms stream :count count)) - (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0) &allow-other-keys) + (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0)) (declare (ignorable x)) (slurp-stream-form stream :at at)) @@ -4077,6 +4539,10 @@ by /bin/sh in POSIX" (declare (ignorable x)) (apply 'slurp-input-stream *standard-output* stream keys)) + (defmethod slurp-input-stream ((x null) stream &key) + (declare (ignorable x stream)) + nil) + (defmethod slurp-input-stream ((pathname pathname) input &key (element-type *default-stream-element-type*) @@ -4095,8 +4561,7 @@ by /bin/sh in POSIX" :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) + &key linewise prefix (element-type 'character) buffer-size) (declare (ignorable stream linewise prefix element-type buffer-size)) (cond #+(or gcl2.6 genera) @@ -4104,12 +4569,91 @@ by /bin/sh in POSIX" #+(or gcl2.6 genera) ((output-stream-p x) (copy-stream-to-stream - input-stream output-stream + stream x :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) (t (error "Invalid ~S destination ~S" 'slurp-input-stream x))))) +(with-upgradability () + (defgeneric vomit-output-stream (processor output-stream &key) + (:documentation + "VOMIT-OUTPUT-STREAM is a generic function with two positional arguments +PROCESSOR and OUTPUT-STREAM and additional keyword arguments, that produces (vomits) +some content onto the OUTPUT-STREAM, according to a method specified by PROCESSOR. + +Built-in methods include the following: +* if PROCESSOR is a function, it is called with the OUTPUT-STREAM as its argument +* if PROCESSOR is a list, its first element should be a function. + It will be applied to a cons of the OUTPUT-STREAM and the rest of the list. + That is (x . y) will be treated as $APPLY x <stream> y$ +* if PROCESSOR is an input-stream, its contents will be copied the OUTPUT-STREAM, + per copy-stream-to-stream, with appropriate keyword arguments. +* if PROCESSOR is a string, its contents will be printed to the OUTPUT-STREAM. +* if PROCESSOR is T, it is treated the same as *standard-input*. If it is NIL, nothing is done. + +Programmers are encouraged to define their own methods for this generic function.")) + + #-(or gcl2.6 genera) + (defmethod vomit-output-stream ((function function) output-stream &key) + (funcall function output-stream)) + + (defmethod vomit-output-stream ((list cons) output-stream &key) + (apply (first list) output-stream (rest list))) + + #-(or gcl2.6 genera) + (defmethod vomit-output-stream ((input-stream stream) output-stream + &key linewise prefix (element-type 'character) buffer-size) + (copy-stream-to-stream + input-stream output-stream + :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) + + (defmethod vomit-output-stream ((x string) stream &key fresh-line terpri) + (princ x stream) + (when fresh-line (fresh-line stream)) + (when terpri (terpri stream)) + (values)) + + (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) + (declare (ignorable x)) + (apply 'vomit-output-stream *standard-input* stream keys)) + + (defmethod vomit-output-stream ((x null) stream &key) + (declare (ignorable x stream)) + (values)) + + (defmethod vomit-output-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 vomit-output-stream (x stream + &key linewise prefix (element-type 'character) buffer-size) + (declare (ignorable stream linewise prefix element-type buffer-size)) + (cond + #+(or gcl2.6 genera) + ((functionp x) (funcall x stream)) + #+(or gcl2.6 genera) + ((input-stream-p x) + (copy-stream-to-stream + x stream + :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) + (t + (error "Invalid ~S source ~S" 'vomit-output-stream x))))) + + ;;;; ----- Running an external program ----- ;;; Simple variant of run-program with no input, and capturing output ;;; On some implementations, may output to a temporary file... @@ -4124,215 +4668,531 @@ by /bin/sh in POSIX" (subprocess-error-command condition) (subprocess-error-code condition))))) - (defun run-program (command - &key output ignore-error-status force-shell - (element-type *default-stream-element-type*) - (external-format :default) - &allow-other-keys) + ;;; Internal helpers for run-program + (defun %normalize-command (command) + "Given a COMMAND as a list or string, transform it in a format suitable +for the implementation's underlying run-program function" + (etypecase command + #+os-unix (string `("/bin/sh" "-c" ,command)) + #+os-unix (list command) + #+os-windows + (string + ;; NB: We do NOT add cmd /c here. You might want to. + #+(or allegro clisp) command + ;; On ClozureCL for Windows, we assume you are using + ;; r15398 or later in 1.9 or later, + ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858 + #+clozure (cons "cmd" (strcat "/c " command)) + ;; NB: On other Windows implementations, this is utterly bogus + ;; except in the most trivial cases where no quoting is needed. + ;; Use at your own risk. + #-(or allegro clisp clozure) (list "cmd" "/c" command)) + #+os-windows + (list + #+allegro (escape-windows-command command) + #-allegro command))) + + (defun %active-io-specifier-p (specifier) + "Determines whether a run-program I/O specifier requires Lisp-side processing +via SLURP-INPUT-STREAM or VOMIT-OUTPUT-STREAM (return T), +or whether it's already taken care of by the implementation's underlying run-program." + (not (typep specifier '(or null string pathname (member :interactive :output) + #+(or cmu (and sbcl os-unix) scl) (or stream (eql t)) + #+lispworks file-stream)))) ;; not a type!? comm:socket-stream + + (defun %normalize-io-specifier (specifier &optional role) + "Normalizes a portable I/O specifier for %RUN-PROGRAM into an implementation-dependent +argument to pass to the internal RUN-PROGRAM" + (declare (ignorable role)) + (etypecase specifier + (null (or #+(or allegro lispworks) (null-device-pathname))) + (string (pathname specifier)) + (pathname specifier) + (stream specifier) + ((eql :stream) :stream) + ((eql :interactive) + #+allegro nil + #+clisp :terminal + #+(or clozure cmu ecl sbcl scl) t) + #+(or allegro clozure cmu ecl lispworks sbcl scl) + ((eql :output) + (if (eq role :error-output) + :output + (error "Wrong specifier ~S for role ~S" specifier role))))) + + (defun %interactivep (input output error-output) + (member :interactive (list input output error-output))) + + #+clisp + (defun clisp-exit-code (raw-exit-code) + (typecase raw-exit-code + (null 0) ; no error + (integer raw-exit-code) ; negative: signal + (t -1))) + + (defun %run-program (command + &rest keys + &key input (if-input-does-not-exist :error) + output (if-output-exists :overwrite) + error-output (if-error-output-exists :overwrite) + directory wait + #+allegro separate-streams + &allow-other-keys) + "A portable abstraction of a low-level call to the implementation's run-program or equivalent. +It spawns a subprocess that runs the specified COMMAND (a list of program and arguments). +INPUT, OUTPUT and ERROR-OUTPUT specify a portable IO specifer, +to be normalized by %NORMALIZE-IO-SPECIFIER. +It returns a process-info plist with possible keys: + PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM." + ;; NB: these implementations have unix vs windows set at compile-time. + (declare (ignorable if-input-does-not-exist if-output-exists if-error-output-exists)) + (assert (not (and wait (member :stream (list input output error-output))))) + #-(or allegro clozure cmu (and lispworks os-unix) sbcl scl) + (progn command keys directory + (error "run-program not available")) + #+(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl) + (let* ((%command (%normalize-command command)) + (%input (%normalize-io-specifier input :input)) + (%output (%normalize-io-specifier output :output)) + (%error-output (%normalize-io-specifier error-output :error-output)) + #+(and allegro os-windows) (interactive (%interactivep input output error-output)) + (process* + #+allegro + (multiple-value-list + (apply + 'excl:run-shell-command + #+os-unix (coerce (cons (first %command) %command) 'vector) + #+os-windows %command + :input %input + :output %output + :error-output %error-output + :directory directory :wait wait + #+os-windows :show-window #+os-windows (if interactive nil :hide) + :allow-other-keys t keys)) + #-allegro + (with-current-directory (#-sbcl directory) + #+clisp + (flet ((run (f &rest args) + (multiple-value-list + (apply f :input %input :output %output + :allow-other-keys t `(,@args ,@keys))))) + (assert (eq %error-output :terminal)) + ;;; since we now always return a code, we can't use this code path, anyway! + (etypecase %command + #+os-windows (string (run 'ext:run-shell-command %command)) + (list (run 'ext:run-program (car %command) + :arguments (cdr %command))))) + #+(or clozure cmu ecl sbcl scl) + (#-ecl progn #+ecl multiple-value-list + (apply + '#+(or cmu ecl scl) ext:run-program + #+clozure ccl:run-program #+sbcl sb-ext:run-program + (car %command) (cdr %command) + :input %input + :output %output + :error %error-output + :wait wait + :allow-other-keys t + (append + #+(or clozure cmu sbcl scl) + `(:if-input-does-not-exist ,if-input-does-not-exist + :if-output-exists ,if-output-exists + :if-error-exists ,if-error-output-exists) + #+sbcl `(:search t + :if-output-does-not-exist :create + :if-error-does-not-exist :create) + #-sbcl keys #+sbcl (if directory keys (remove-plist-key :directory keys))))) + #+(and lispworks os-unix) ;; note: only used on Unix in non-interactive case + (multiple-value-list + (apply + 'system:run-shell-command + (cons "/usr/bin/env" %command) ; lispworks wants a full path. + :input %input :if-input-does-not-exist if-input-does-not-exist + :output %output :if-output-exists if-output-exists + :error-output %error-output :if-error-output-exists if-error-output-exists + :wait wait :save-exit-status t :allow-other-keys t keys)))) + (process-info-r ())) + (flet ((prop (key value) (push key process-info-r) (push value process-info-r))) + #+allegro + (cond + (wait (prop :exit-code (first process*))) + (separate-streams + (destructuring-bind (in out err pid) process* + (prop :process pid) + (when (eq input :stream) (prop :input-stream in)) + (when (eq output :stream) (prop :output-stream out)) + (when (eq error-output :stream) (prop :error-stream err)))) + (t + (prop :process (third process*)) + (let ((x (first process*))) + (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) + (0) + (1 (prop :input-stream x)) + (2 (prop :output-stream x)) + (3 (prop :bidir-stream x)))) + (when (eq error-output :stream) + (prop :error-stream (second process*))))) + #+clisp + (cond + (wait (prop :exit-code (clisp-exit-code (first process*)))) + (t + (ecase (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)) + (0) + (1 (prop :input-stream (first process*))) + (2 (prop :output-stream (first process*))) + (3 (prop :bidir-stream (pop process*)) + (prop :input-stream (pop process*)) + (prop :output-stream (pop process*)))))) + #+(or clozure cmu sbcl scl) + (progn + (prop :process process*) + (when (eq input :stream) + (prop :input-stream + #+clozure (ccl:external-process-input-stream process*) + #+(or cmu scl) (ext:process-input process*) + #+sbcl (sb-ext:process-input process*))) + (when (eq output :stream) + (prop :output-stream + #+clozure (ccl:external-process-output-stream process*) + #+(or cmu scl) (ext:process-output process*) + #+sbcl (sb-ext:process-output process*))) + (when (eq error-output :stream) + (prop :error-output-stream + #+clozure (ccl:external-process-error-stream process*) + #+(or cmu scl) (ext:process-error process*) + #+sbcl (sb-ext:process-error process*)))) + #+ecl + (destructuring-bind (stream code process) process* + (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) + (cond + ((zerop mode)) + ((null process*) (prop :exit-code -1)) + (t (prop (case mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) stream)))) + (when code (prop :exit-code code)) + (when process (prop :process process))) + #+lispworks + (if wait + (prop :exit-code (first process*)) + (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) + (if (zerop mode) + (prop :process (first process*)) + (destructuring-bind (x err pid) process* + (prop :process pid) + (prop (ecase mode (1 :input-stream) (2 :output-stream) (3 :bidir-stream)) x) + (when (eq error-output :stream) (prop :error-stream err)))))) + (nreverse process-info-r)))) + + (defun %wait-process-result (process-info) + (or (getf process-info :exit-code) + (let ((process (getf process-info :process))) + (when process + ;; 1- wait + #+clozure (ccl::external-process-wait process) + #+(or cmu scl) (ext:process-wait process) + #+(and ecl os-unix) (ext:external-process-wait process) + #+sbcl (sb-ext:process-wait process) + ;; 2- extract result + #+allegro (sys:reap-os-subprocess :pid process :wait t) + #+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 (system:pid-exit-status process :wait t) + #+sbcl (sb-ext:process-exit-code process))))) + + (defun %check-result (exit-code &key command process ignore-error-status) + (unless ignore-error-status + (unless (eql exit-code 0) + (cerror "IGNORE-ERROR-STATUS" + 'subprocess-error :command command :code exit-code :process process))) + exit-code) + + (defun %call-with-program-io (gf tval stream-easy-p fun direction spec activep returner + &key element-type external-format &allow-other-keys) + ;; handle redirection for run-program and system + ;; SPEC is the specification for the subprocess's input or output or error-output + ;; TVAL is the value used if the spec is T + ;; GF is the generic function to call to handle arbitrary values of SPEC + ;; STREAM-EASY-P is T if we're going to use a RUN-PROGRAM that copies streams in the background + ;; (it's only meaningful on CMUCL, SBCL, SCL that actually do it) + ;; DIRECTION is :INPUT, :OUTPUT or :ERROR-OUTPUT for the direction of this io argument + ;; FUN is a function of the new reduced spec and an activity function to call with a stream + ;; when the subprocess is active and communicating through that stream. + ;; ACTIVEP is a boolean true if we will get to run code while the process is running + ;; ELEMENT-TYPE and EXTERNAL-FORMAT control what kind of temporary file we may open. + ;; RETURNER is a function called with the value of the activity. + ;; --- TODO (fare(a)tunes.org) handle if-output-exists and such when doing it the hard way. + (declare (ignorable stream-easy-p)) + (let* ((actual-spec (if (eq spec t) tval spec)) + (activity-spec (if (eq actual-spec :output) + (ecase direction + ((:input :output) + (error "~S not allowed as a ~S ~S spec" + :output 'run-program direction)) + ((:error-output) + nil)) + actual-spec))) + (labels ((activity (stream) + (call-function returner (call-stream-processor gf activity-spec stream))) + (easy-case () + (funcall fun actual-spec nil)) + (hard-case () + (if activep + (funcall fun :stream #'activity) + (with-temporary-file (:pathname tmp) + (ecase direction + (:input + (with-output-file (s tmp :if-exists :overwrite + :external-format external-format + :element-type element-type) + (activity s)) + (funcall fun tmp nil)) + ((:output :error-output) + (multiple-value-prog1 (funcall fun tmp nil) + (with-input-file (s tmp + :external-format external-format + :element-type element-type) + (activity s))))))))) + (typecase activity-spec + ((or null string pathname (eql :interactive)) + (easy-case)) + #+(or cmu (and sbcl os-unix) scl) ;; streams are only easy on implementations that try very hard + (stream + (if stream-easy-p (easy-case) (hard-case))) + (t + (hard-case)))))) + + (defmacro place-setter (place) + (when place + (let ((value (gensym))) + `#'(lambda (,value) (setf ,place ,value))))) + + (defmacro with-program-input (((reduced-input-var + &optional (input-activity-var (gensym) iavp)) + input-form &key setf stream-easy-p active keys) &body body) + `(apply '%call-with-program-io 'vomit-output-stream *standard-input* ,stream-easy-p + #'(lambda (,reduced-input-var ,input-activity-var) + ,@(unless iavp `((declare (ignore ,input-activity-var)))) + ,@body) + :input ,input-form ,active (place-setter ,setf) ,keys)) + + (defmacro with-program-output (((reduced-output-var + &optional (output-activity-var (gensym) oavp)) + output-form &key setf stream-easy-p active keys) &body body) + `(apply '%call-with-program-io 'slurp-input-stream *standard-output* ,stream-easy-p + #'(lambda (,reduced-output-var ,output-activity-var) + ,@(unless oavp `((declare (ignore ,output-activity-var)))) + ,@body) + :output ,output-form ,active (place-setter ,setf) ,keys)) + + (defmacro with-program-error-output (((reduced-error-output-var + &optional (error-output-activity-var (gensym) eoavp)) + error-output-form &key setf stream-easy-p active keys) + &body body) + `(apply '%call-with-program-io 'slurp-input-stream *error-output* ,stream-easy-p + #'(lambda (,reduced-error-output-var ,error-output-activity-var) + ,@(unless eoavp `((declare (ignore ,error-output-activity-var)))) + ,@body) + :error-output ,error-output-form ,active (place-setter ,setf) ,keys)) + + (defun %use-run-program (command &rest keys + &key input output error-output ignore-error-status &allow-other-keys) + ;; helper for RUN-PROGRAM when using %run-program + #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) + (error "Not implemented on this platform") + (assert (not (member :stream (list input output error-output)))) + (let* ((active-input-p (%active-io-specifier-p input)) + (active-output-p (%active-io-specifier-p output)) + (active-error-output-p (%active-io-specifier-p error-output)) + (activity + (cond + (active-output-p :output) + (active-input-p :input) + (active-error-output-p :error-output) + (t nil))) + (wait (not activity)) + output-result error-output-result exit-code) + (with-program-output ((reduced-output output-activity) + output :keys keys :setf output-result + :stream-easy-p t :active (eq activity :output)) + (with-program-error-output ((reduced-error-output error-output-activity) + error-output :keys keys :setf error-output-result + :stream-easy-p t :active (eq activity :error-output)) + (with-program-input ((reduced-input input-activity) + input :keys keys + :stream-easy-p t :active (eq activity :input)) + (let ((process-info + (apply '%run-program command + :wait wait :input reduced-input :output reduced-output + :error-output (if (eq error-output :output) :output reduced-error-output) + keys))) + (labels ((get-stream (stream-name &optional fallbackp) + (or (getf process-info stream-name) + (when fallbackp + (getf process-info :bidir-stream)))) + (run-activity (activity stream-name &optional fallbackp) + (if-let (stream (get-stream stream-name fallbackp)) + (funcall activity stream) + (error 'subprocess-error + :code `(:missing ,stream-name) + :command command :process process-info)))) + (unwind-protect + (ecase activity + ((nil)) + (:input (run-activity input-activity :input-stream t)) + (:output (run-activity output-activity :output-stream t)) + (:error-output (run-activity error-output-activity :error-output-stream))) + (loop :for (() val) :on process-info :by #'cddr + :when (streamp val) :do (ignore-errors (close val))) + (setf exit-code + (%check-result (%wait-process-result process-info) + :command command :process process-info + :ignore-error-status ignore-error-status)))))))) + (values output-result error-output-result exit-code))) + + (defun %normalize-system-command (command) ;; helper for %USE-SYSTEM + (etypecase command + (string command) + (list (escape-shell-command + (if (os-unix-p) (cons "exec" command) command))))) + + (defun %redirected-system-command (command in out err directory) ;; helper for %USE-SYSTEM + (flet ((redirect (spec operator) + (let ((pathname + (typecase spec + (null (null-device-pathname)) + (string (pathname spec)) + (pathname spec) + ((eql :output) + (assert (equal operator "2>")) + (return-from redirect '(" 2>&1")))))) + (when pathname + (list " " operator " " + (escape-shell-token (native-namestring pathname))))))) + (multiple-value-bind (before after) + (let ((normalized (%normalize-system-command command))) + (if (os-unix-p) + (values '("exec") (list " ; " normalized)) + (values (list normalized) ()))) + (reduce/strcat + (append + before (redirect in "<") (redirect out ">") (redirect err "2>") + (when (and directory (os-unix-p)) `("cd " (escape-shell-token directory) " ; ")) + after))))) + + (defun %system (command &rest keys + &key input output error-output directory &allow-other-keys) + "A portable abstraction of a low-level call to libc's system()." + (declare (ignorable input output error-output directory keys)) + #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl) + (%wait-process-result + (apply '%run-program (%normalize-system-command command) :wait t keys)) + #+(or abcl clisp cormanlisp ecl gcl (and lispworks os-windows) mkcl xcl) + (let ((%command (%redirected-system-command command input output error-output directory))) + #+(and lispworks os-windows) + (system:call-system %command :current-directory directory :wait t) + #-(and lispworks os-windows) + (with-current-directory ((unless (os-unix-p) directory)) + #+(or abcl xcl) (ext:run-shell-command %command) + #+clisp (clisp-exit-code (ext:shell %command)) + #+cormanlisp (win32:system %command) + #+ecl (let ((*standard-input* *stdin*) + (*standard-output* *stdout*) + (*error-output* *stderr*)) + (ext:system %command)) + #+gcl (lisp:system %command) + #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) + #+mkcl ;; PROBABLY BOGUS -- ask jcb + (multiple-value-bind (io process exit-code) + (mkcl:run-program #+windows %command #+windows () + #-windows "/bin/sh" #-windows (list "-c" %command) + :input t :output t))))) + + (defun %use-system (command &rest keys + &key input output error-output ignore-error-status &allow-other-keys) + ;; helper for RUN-PROGRAM when using %system + (let (output-result error-output-result exit-code) + (with-program-output ((reduced-output) + output :keys keys :setf output-result) + (with-program-error-output ((reduced-error-output) + error-output :keys keys :setf error-output-result) + (with-program-input ((reduced-input) input :keys keys) + (setf exit-code + (%check-result (apply '%system command + :input reduced-input :output reduced-output + :error-output reduced-error-output keys) + :command command + :ignore-error-status ignore-error-status))))) + (values output-result error-output-result exit-code))) + + (defun run-program (command &rest keys + &key ignore-error-status force-shell + (input nil inputp) (if-input-does-not-exist :error) + output (if-output-exists :overwrite) + (error-output nil error-output-p) (if-error-output-exists :overwrite) + (element-type #-clozure *default-stream-element-type* #+clozure 'character) + (external-format *utf-8-external-format*) + &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). -Always call a shell (rather than directly execute the command) +Always call a shell (rather than directly execute the command when possible) if FORCE-SHELL is specified. -Signal a SUBPROCESS-ERROR if the process wasn't successful (exit-code 0), +Signal a continuable 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. - +If OUTPUT is a pathname, a string designating a pathname, or NIL designating the null device, +the file at that path is used as output. +If it's :INTERACTIVE, output is inherited from the current process. Otherwise, OUTPUT should be a value that is a suitable first argument to -SLURP-INPUT-STREAM. In this case, RUN-PROGRAM will create a temporary stream -for the program output. The program output, in that stream, will be processed -by SLURP-INPUT-STREAM, according to the using OUTPUT as the first argument. -RUN-PROGRAM will return whatever SLURP-INPUT-STREAM 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: The current version does not honor :OUTPUT NIL on Allegro. Setting - ;; the :INPUT and :OUTPUT arguments to RUN-SHELL-COMMAND on ACL actually do - ;; what :OUTPUT :INTERACTIVE is advertised to do here. To get the behavior - ;; specified for :OUTPUT NIL, one would have to grab up the process output - ;; into a stream and then throw it on the floor. The consequences of - ;; getting this wrong seemed so much worse than having excess output that it - ;; is not currently implemented. - - ;; TODO: specially recognize :output pathname ? - (declare (ignorable ignore-error-status element-type external-format)) +SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments. +In this case, RUN-PROGRAM will create a temporary stream for the program output. +The program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM, +using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords). +T designates the *STANDARD-OUTPUT* to be provided to SLURP-INPUT-STREAM. +The primary value resulting from that call (or NIL if no call was needed) +will be the first value returned by RUN-PROGRAM. +E.g., using :OUTPUT :STRING will have it return the entire output stream as a string. + +ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned +as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*. +Also :OUTPUT means redirecting the error output to the output stream, and NIL is returned. + +INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used, +no value is returned, and T designates the *STANDARD-INPUT*. + +Use ELEMENT-TYPE and EXTERNAL-FORMAT to specify how streams are created. + +One and only one of the stream slurping or vomiting may or may not happen +in parallel in parallel with the subprocess, depending on options and implementation. +Other streams are completely produced or consumed before or after the subprocess is spawned, +using temporary files. + +RUN-PROGRAM returns 3 values: +0- the result of the OUTPUT slurping if any, or NIL +1- the result of the ERROR-OUTPUT slurping if any, or NIL +2- either 0 if the subprocess exited with success status, +or an indication of failure via the EXIT-CODE of the process" + (declare (ignorable ignore-error-status)) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) (error "RUN-PROGRAM not implemented for this Lisp") - (labels (#+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl) - (run-program (command &key pipe interactive) - "runs the specified command (a list of program and arguments). - If using a pipe, returns two values: process and stream - If not using a pipe, returns one values: the process result; - also, inherits the output stream." - ;; NB: these implementations have unix vs windows set at compile-time. - (assert (not (and pipe interactive))) - (let* ((wait (not pipe)) - #-(and clisp os-windows) - (command - (etypecase command - #+os-unix (string `("/bin/sh" "-c" ,command)) - #+os-unix (list command) - #+os-windows - (string - ;; NB: We do NOT add cmd /c here. You might want to. - #+allegro command - ;; On ClozureCL for Windows, we assume you are using - ;; r15398 or later in 1.9 or later, - ;; so that bug 858 is fixed http://trac.clozure.com/ccl/ticket/858 - #+clozure (cons "cmd" (strcat "/c " command)) - ;; NB: On other Windows implementations, this is utterly bogus - ;; except in the most trivial cases where no quoting is needed. - ;; Use at your own risk. - #-(or allegro clozure) (list "cmd" "/c" command)) - #+os-windows - (list - #+(or allegro clozure) (escape-windows-command command) - #-(or allegro clozure) command))) - #+(and clozure os-windows) (command (list command)) - (process* - (multiple-value-list - #+allegro - (excl:run-shell-command - #+os-unix (coerce (cons (first command) command) 'vector) - #+os-windows command - :input nil - :output (and pipe :stream) :wait wait - #+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 - ,(if pipe :stream :terminal))))) - (etypecase command - #+os-windows (run 'ext:run-shell-command command) - (list (run 'ext:run-program (car command) - :arguments (cdr command))))) - #+lispworks - (system:run-shell-command - (cons "/usr/bin/env" command) ; lispworks wants a full path. - :input interactive :output (or (and pipe :stream) interactive) - :wait wait :save-exit-status (and pipe t)) - #+(or clozure cmu ecl sbcl scl) - (#+(or cmu ecl scl) ext:run-program - #+clozure ccl:run-program - #+sbcl sb-ext:run-program - (car command) (cdr command) - :input interactive :wait wait - :output (if pipe :stream t) - . #.(append - #+(or clozure cmu ecl sbcl scl) '(:error t) - ;; note: :external-format requires a recent SBCL - #+sbcl '(:search t :external-format external-format))))) - (process - #+allegro (if pipe (third process*) (first process*)) - #+ecl (third process*) - #-(or allegro ecl) (first process*)) - (stream - (when pipe - #+(or allegro lispworks ecl) (first process*) - #+clisp (first process*) - #+clozure (ccl::external-process-output process) - #+(or cmu scl) (ext:process-output process) - #+sbcl (sb-ext:process-output process)))) - (values process stream))) - #+(or allegro clisp clozure cmu ecl (and lispworks os-unix) sbcl scl) - (process-result (process pipe) - (declare (ignorable pipe)) - ;; 1- wait - #+(and clozure os-unix) (ccl::external-process-wait process) - #+(or cmu scl) (ext:process-wait process) - #+(and ecl os-unix) (ext:external-process-wait process) - #+sbcl (sb-ext:process-wait process) - ;; 2- extract result - #+allegro (if pipe (sys:reap-os-subprocess :pid process :wait t) process) - #+clisp 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:pipe-exit-status process :wait t) process) - #+sbcl (sb-ext:process-exit-code process)) - (check-result (exit-code process) - #+clisp - (setf exit-code - (typecase exit-code (integer exit-code) (null 0) (t -1))) - (unless (or ignore-error-status - (equal exit-code 0)) - (error 'subprocess-error :command command :code exit-code :process process)) - exit-code) - (use-run-program () - #-(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) - (let* ((interactive (eq output :interactive)) - (pipe (and output (not interactive)))) - (multiple-value-bind (process stream) - (run-program command :pipe pipe :interactive interactive) - (if (and output (not interactive)) - (unwind-protect - (slurp-input-stream output stream) - (when stream (close stream)) - (check-result (process-result process pipe) process)) - (unwind-protect - (check-result - #+(or allegro lispworks) ; when not capturing, returns the exit code! - process - #-(or allegro lispworks) (process-result process pipe) - process)))))) - (system-command (command) - (etypecase command - (string (if (os-windows-p) (format nil "cmd /c ~A" command) command)) - (list (escape-shell-command - (if (os-unix-p) (cons "exec" command) command))))) - (redirected-system-command (command out) - (format nil (if (os-unix-p) "exec > ~*~A ; ~2:*~A" "~A > ~A") - (system-command command) (native-namestring out))) - (system (command &key interactive) - (declare (ignorable interactive)) - #+(or abcl xcl) (ext:run-shell-command command) - #+allegro - (excl:run-shell-command - command - :input nil - :output nil - :error-output :output ; write STDERR to output, too - :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) - #+cormanlisp (win32:system command) - #+gcl (lisp:system command) - #+(and lispworks os-windows) - (system:call-system-showing-output - 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 () - #-windows "/bin/sh" (list "-c" command) - :input nil :output nil))) - (call-system (command-string &key interactive) - (check-result (system command-string :interactive interactive) nil)) - (use-system () - (let ((interactive (eq output :interactive))) - (if (and output (not interactive)) - (with-temporary-file (:pathname tmp :direction :output) - (call-system (redirected-system-command command tmp)) - (with-open-file (stream tmp - :direction :input - :if-does-not-exist :error - :element-type element-type - #-gcl2.6 :external-format #-gcl2.6 external-format) - (slurp-input-stream output stream))) - (call-system (system-command command) :interactive interactive))))) - (if (and (not force-shell) - #+(or clisp ecl) ignore-error-status - #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) nil) - (use-run-program) - (use-system))))) - + (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive)))) + (apply (if (or force-shell + #+(or clisp ecl) (or (not ignore-error-status) t) + #+clisp (eq error-output :interactive) + #+(or abcl clisp) (eq :error-output :output) + #+(and lispworks os-unix) (%interactivep input output error-output) + #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) t) + '%use-system '%use-run-program) + command + :input (default input inputp output) + :error-output (default error-output error-output-p output) + :if-input-does-not-exist if-input-does-not-exist + :if-output-exists if-output-exists + :if-error-output-exists if-error-output-exists + :element-type element-type :external-format external-format + keys)))) ;;;; ------------------------------------------------------------------------- ;;;; Support to build (compile and load) Lisp files @@ -4346,6 +5206,7 @@ ELEMENT-TYPE and EXTERNAL-FORMAT for the stream passed to the OUTPUT processor." #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*output-translation-function* #:*optimization-settings* #:*previous-optimization-settings* + #:*base-build-directory* #: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 @@ -4379,13 +5240,20 @@ Valid values are :error, :warn, and :ignore.") "How should ASDF react if it encounters a failure (per the ANSI spec of COMPILE-FILE) when compiling a file, which includes any non-style-warning warning. Valid values are :error, :warn, and :ignore. -Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.")) +Note that ASDF ALWAYS raises an error if it fails to create an output file when compiling.") + (defvar *base-build-directory* nil + "When set to a non-null value, it should be an absolute directory pathname, +which will serve as the *DEFAULT-PATHNAME-DEFAULTS* around a COMPILE-FILE, +what more while the input-file is shortened if possible to ENOUGH-PATHNAME relative to it. +This can help you produce more deterministic output for FASLs.")) ;;; Optimization settings (with-upgradability () - (defvar *optimization-settings* nil) - (defvar *previous-optimization-settings* nil) + (defvar *optimization-settings* nil + "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS") + (defvar *previous-optimization-settings* nil + "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS") (defun get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" #-(or clisp clozure cmu ecl sbcl scl) @@ -4414,6 +5282,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when #+sbcl (progn (defun sb-grovel-unknown-constant-condition-p (c) + "Detect SB-GROVEL unknown-constant conditions on older versions of SBCL" (and (typep c 'sb-int:simple-style-warning) (string-enclosed-p "Couldn't grovel for " @@ -4459,16 +5328,18 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when ;;;; ----- Filtering conditions while building ----- (with-upgradability () (defun call-with-muffled-compiler-conditions (thunk) + "Call given THUNK in a context where uninteresting conditions and compiler conditions are muffled" (call-with-muffled-conditions thunk (append *uninteresting-conditions* *uninteresting-compiler-conditions*))) (defmacro with-muffled-compiler-conditions ((&optional) &body body) - "Run BODY where uninteresting compiler conditions are muffled" + "Trivial syntax for CALL-WITH-MUFFLED-COMPILER-CONDITIONS" `(call-with-muffled-compiler-conditions #'(lambda () ,@body))) (defun call-with-muffled-loader-conditions (thunk) + "Call given THUNK in a context where uninteresting conditions and loader conditions are muffled" (call-with-muffled-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" + "Trivial syntax for CALL-WITH-MUFFLED-LOADER-CONDITIONS" `(call-with-muffled-loader-conditions #'(lambda () ,@body)))) @@ -4494,6 +5365,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (defun check-lisp-compile-warnings (warnings-p failure-p &optional context-format context-arguments) + "Given the warnings or failures as resulted from COMPILE-FILE or checking deferred warnings, +raise an error or warning as appropriate" (when failure-p (case *compile-file-failure-behaviour* (:warn (warn 'compile-failed-warning @@ -4519,6 +5392,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (defun check-lisp-compile-results (output warnings-p failure-p &optional context-format context-arguments) + "Given the results of COMPILE-FILE, raise an error or warning as appropriate" (unless output (error 'compile-file-error :context-format context-format :context-arguments context-arguments)) (check-lisp-compile-warnings warnings-p failure-p context-format context-arguments))) @@ -4531,6 +5405,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when ;;; See their respective docstrings. (with-upgradability () (defun reify-simple-sexp (sexp) + "Given a simple SEXP, return a representation of it as a portable SEXP. +Simple means made of symbols, numbers, characters, simple-strings, pathnames, cons cells." (etypecase sexp (symbol (reify-symbol sexp)) ((or number character simple-string pathname) sexp) @@ -4538,6 +5414,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when (simple-vector (vector (mapcar 'reify-simple-sexp (coerce sexp 'list)))))) (defun unreify-simple-sexp (sexp) + "Given the portable output of REIFY-SIMPLE-SEXP, return the simple SEXP it represents" (etypecase sexp ((or symbol number character simple-string pathname) sexp) (cons (cons (unreify-simple-sexp (car sexp)) (unreify-simple-sexp (cdr sexp)))) @@ -4789,6 +5666,8 @@ possibly in a different process." (terpri s)))) (defun warnings-file-type (&optional implementation-type) + "The pathname type for warnings files on given IMPLEMENTATION-TYPE, +where NIL designates the current one" (case (or implementation-type *implementation-type*) ((:acl :allegro) "allegro-warnings") ;;((:clisp) "clisp-warnings") @@ -4798,21 +5677,27 @@ possibly in a different process." ((:scl) "scl-warnings"))) (defvar *warnings-file-type* nil - "Type for warnings files") + "Pathname type for warnings files, or NIL if disabled") (defun enable-deferred-warnings-check () + "Enable the saving of deferred warnings" (setf *warnings-file-type* (warnings-file-type))) (defun disable-deferred-warnings-check () + "Disable the saving of deferred warnings" (setf *warnings-file-type* nil)) (defun warnings-file-p (file &optional implementation-type) + "Is FILE a saved warnings file for the given IMPLEMENTATION-TYPE? +If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* instead." (if-let (type (if implementation-type (warnings-file-type implementation-type) *warnings-file-type*)) (equal (pathname-type file) type))) (defun check-deferred-warnings (files &optional context-format context-arguments) + "Given a list of FILES in which deferred warnings were saved by CALL-WITH-DEFERRED-WARNINGS, +re-intern and raise any warnings that are still meaningful." (let ((file-errors nil) (failure-p nil) (warnings-p nil)) @@ -4853,6 +5738,9 @@ possibly in a different process." |# (defun call-with-saved-deferred-warnings (thunk warnings-file) + "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK +and save those warnings to the given file for latter use, +possibly in a different process. Otherwise just call THUNK." (if warnings-file (with-compilation-unit (:override t) (unwind-protect @@ -4864,21 +5752,22 @@ possibly in a different process." (funcall thunk))) (defmacro with-saved-deferred-warnings ((warnings-file) &body body) - "If WARNINGS-FILE is not nil, records the deferred-warnings around the BODY -and saves those warnings to the given file for latter use, -possibly in a different process. Otherwise just run the BODY." + "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS" `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file))) ;;; from ASDF (with-upgradability () (defun current-lisp-file-pathname () + "Portably return the PATHNAME of the current Lisp source file being compiled or loaded" (or *compile-file-pathname* *load-pathname*)) (defun load-pathname () - *load-pathname*) + "Portably return the LOAD-PATHNAME of the current source file or fasl" + *load-pathname*) ;; see magic for GCL in uiop/common-lisp (defun lispize-pathname (input-file) + "From a INPUT-FILE pathname, return a corresponding .lisp source pathname" (make-pathname :type "lisp" :defaults input-file)) (defun compile-file-type (&rest keys) @@ -4888,9 +5777,11 @@ possibly in a different process. Otherwise just run the BODY." #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys))) (defun call-around-hook (hook function) + "Call a HOOK around the execution of FUNCTION" (call-function (or hook 'funcall) function)) (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) + "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*" (let* ((keys (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format ,@(unless output-file '(:output-file))) keys))) @@ -4959,16 +5850,17 @@ it will filter them appropriately." (multiple-value-bind (output-truename warnings-p failure-p) (with-saved-deferred-warnings (warnings-file) (with-muffled-compiler-conditions () - (or #-(or ecl mkcl) - (apply 'compile-file input-file :output-file tmp-file - #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) - #-sbcl keywords) - #+ecl (apply 'compile-file input-file :output-file - (if object-file - (list* object-file :system-p t keywords) - (list* tmp-file keywords))) - #+mkcl (apply 'compile-file input-file - :output-file object-file :fasl-p nil keywords)))) + (with-enough-pathname (input-file :defaults *base-build-directory*) + (or #-(or ecl mkcl) + (apply 'compile-file input-file :output-file tmp-file + #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) + #-sbcl keywords) + #+ecl (apply 'compile-file input-file :output-file + (if object-file + (list* object-file :system-p t keywords) + (list* tmp-file keywords))) + #+mkcl (apply 'compile-file input-file + :output-file object-file :fasl-p nil keywords))))) (cond ((and output-truename (flet ((check-flag (flag behaviour) @@ -4999,6 +5891,7 @@ it will filter them appropriately." (values output-truename warnings-p failure-p)))) (defun load* (x &rest keys &key &allow-other-keys) + "Portable wrapper around LOAD that properly handles loading from a stream." (etypecase x ((or pathname string #-(or allegro clozure gcl2.6 genera) stream) (apply 'load x @@ -5021,6 +5914,7 @@ it will filter them appropriately." ;;; Links FASLs together (with-upgradability () (defun combine-fasls (inputs output) + "Combine a list of FASLs INPUTS into a single FASL OUTPUT" #-(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) @@ -5081,8 +5975,10 @@ it will filter them appropriately." (condition-arguments c)))))) (defun get-folder-path (folder) - (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path - #+(and lispworks mswindows) (sys:get-folder-path folder) + "Semi-portable implementation of a subset of LispWorks' sys:get-folder-path, +this function tries to locate the Windows FOLDER for one of +:LOCAL-APPDATA, :APPDATA or :COMMON-APPDATA." + (or #+(and lispworks mswindows) (sys:get-folder-path folder) ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData (ecase folder (:local-appdata (getenv-absolute-directory "LOCALAPPDATA")) @@ -5091,6 +5987,7 @@ it will filter them appropriately." (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) (defun user-configuration-directories () + "Determine user configuration directories" (let ((dirs `(,@(when (os-unix-p) (cons @@ -5105,6 +6002,7 @@ it will filter them appropriately." :from-end t :test 'equal))) (defun system-configuration-directories () + "Determine system user configuration directories" (cond ((os-unix-p) '(#p"/etc/common-lisp/")) ((os-windows-p) @@ -5112,23 +6010,28 @@ it will filter them appropriately." (list it))))) (defun in-first-directory (dirs x &key (direction :input)) + "Determine system user configuration directories" (loop :with fun = (ecase direction ((nil :input :probe) 'probe-file*) ((:output :io) 'identity)) :for dir :in dirs - :thereis (and dir (funcall fun (merge-pathnames* x (ensure-directory-pathname dir)))))) + :thereis (and dir (funcall fun (subpathname (ensure-directory-pathname dir) x))))) (defun in-user-configuration-directory (x &key (direction :input)) + "return pathname under user configuration directory, subpathname X" (in-first-directory (user-configuration-directories) x :direction direction)) (defun in-system-configuration-directory (x &key (direction :input)) + "return pathname under system configuration directory, subpathname X" (in-first-directory (system-configuration-directories) x :direction direction)) (defun configuration-inheritance-directive-p (x) + "Is X a configuration inheritance directive?" (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) (or (member x kw) (and (length=n-p x 1) (member (car x) kw))))) (defun report-invalid-form (reporter &rest args) + "Report an invalid form according to REPORTER and various ARGS" (etypecase reporter (null (apply 'error 'invalid-configuration args)) @@ -5139,10 +6042,12 @@ it will filter them appropriately." (cons (apply 'apply (append reporter args))))) - (defvar *ignored-configuration-form* nil) + (defvar *ignored-configuration-form* nil + "Have configuration forms been ignored while parsing the configuration?") (defun validate-configuration-form (form tag directive-validator &key location invalid-form-reporter) + "Validate a configuration FORM" (unless (and (consp form) (eq (car form) tag)) (setf *ignored-configuration-form* t) (report-invalid-form invalid-form-reporter :form form :location location) @@ -5171,6 +6076,7 @@ it will filter them appropriately." (return (nreverse x)))) (defun validate-configuration-file (file validator &key description) + "Validate a configuration file for conformance of its form with the validator function" (let ((forms (read-file-forms file))) (unless (length=n-p forms 1) (error (compatfmt "~@<One and only one form allowed for ~A. Got: ~3i~_~S~@:>~%") @@ -5203,6 +6109,7 @@ values of TAG include :source-registry and :output-translations." :inherit-configuration))) (defun resolve-relative-location (x &key ensure-directory wilden) + "Given a designator X for an relative location, resolve it to a pathname" (ensure-pathname (etypecase x (pathname x) @@ -5241,6 +6148,7 @@ directive.") "A specification as per RESOLVE-LOCATION of where the user keeps his FASL cache") (defun compute-user-cache () + "Compute the location of the default user-cache for translate-output objects" (setf *user-cache* (flet ((try (x &rest sub) (and x `(,x ,@sub)))) (or @@ -5253,6 +6161,7 @@ directive.") (register-image-restore-hook 'compute-user-cache) (defun resolve-absolute-location (x &key ensure-directory wilden) + "Given a designator X for an absolute location, resolve it to a pathname" (ensure-pathname (etypecase x (pathname x) @@ -5293,6 +6202,7 @@ directive.") (:ensure-directory boolean)) t) resolve-location)) (defun* (resolve-location) (x &key ensure-directory wilden directory) + "Resolve location designator X into a PATHNAME" ;; :directory backward compatibility, until 2014-01-16: accept directory as well as ensure-directory (loop* :with dirp = (or directory ensure-directory) :with (first . rest) = (if (atom x) (list x) x) @@ -5310,6 +6220,7 @@ directive.") :finally (return path))) (defun location-designator-p (x) + "Is X a designator for a location?" (flet ((absolute-component-p (c) (typep c '(or string pathname (member :root :home :here :user-cache)))) @@ -5321,26 +6232,25 @@ directive.") (and (consp x) (absolute-component-p (first x)) (every #'relative-component-p (rest x)))))) (defun location-function-p (x) + "Is X the specification of a location function?" (and (length=n-p x 2) - (eq (car x) :function) - (or (symbolp (cadr x)) - (and (consp (cadr x)) - (eq (caadr x) 'lambda) - (length=n-p (cadadr x) 2))))) + (eq (car x) :function))) (defvar *clear-configuration-hook* '()) (defun register-clear-configuration-hook (hook-function &optional call-now-p) + "Register a function to be called when clearing configuration" (register-hook-function '*clear-configuration-hook* hook-function call-now-p)) (defun clear-configuration () + "Call the functions in *CLEAR-CONFIGURATION-HOOK*" (call-functions *clear-configuration-hook*)) (register-image-dump-hook 'clear-configuration) - ;; If a previous version of ASDF failed to read some configuration, try again. (defun upgrade-configuration () + "If a previous version of ASDF failed to read some configuration, try again now." (when *ignored-configuration-form* (clear-configuration) (setf *ignored-configuration-form* nil)))) @@ -5388,17 +6298,19 @@ directive.") #+(or ecl mkcl) (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args))) ;;;; --------------------------------------------------------------------------- -;;;; Re-export all the functionality in asdf/driver +;;;; Re-export all the functionality in UIOP (uiop/package:define-package :uiop/driver (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils) (:use :uiop/common-lisp :uiop/package :uiop/utility - :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image + :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver) (:reexport - ;; NB: excluding asdf/common-lisp - ;; which include all of CL with compatibility modifications on select platforms. + ;; NB: excluding uiop/common-lisp + ;; which include all of CL with compatibility modifications on select platforms, + ;; that could cause potential conflicts for packages that would :use (cl uiop) + ;; or :use (closer-common-lisp uiop), etc. :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image :uiop/run-program :uiop/lisp-build @@ -5409,7 +6321,7 @@ directive.") (asdf/package:define-package :asdf/upgrade (:recycle :asdf/upgrade :asdf) - (:use :asdf/common-lisp :asdf/driver) + (:use :uiop/common-lisp :uiop) (:export #:asdf-version #:*previous-asdf-versions* #:*asdf-version* #:asdf-message #:*verbose-out* @@ -5457,13 +6369,13 @@ 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 "3.0.2") + (asdf-version "3.0.3") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) (push existing-version *previous-asdf-versions*) - (when (or *load-verbose* *verbose-out*) - (format *trace-output* + (when (or *verbose-out* *load-verbose*) + (format (or *verbose-out* *trace-output*) (compatfmt "~&~@<; ~@;Upgrading ASDF ~@[from version ~A ~]to version ~A~@:>~%") existing-version asdf-version))))) @@ -5483,7 +6395,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO #:inherit-source-registry #:process-source-registry ;; source-registry #:process-source-registry-directive #:trivial-system-p ;; bundle - ;; NB: it's too late to do anything about asdf-driver functions! + ;; NB: it's too late to do anything about uiop functions! )) (uninterned-symbols '(#:*asdf-revision* #:around #:asdf-method-combination @@ -5548,8 +6460,8 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ;;;; Components (asdf/package:define-package :asdf/component - (:recycle :asdf/component :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:component #:component-find-path #:component-name #:component-pathname #:component-relative-pathname @@ -5574,6 +6486,10 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO #:module-components ;; backward-compatibility. DO NOT USE. #:sub-components + ;; conditions + #:system-definition-error ;; top level, moved here because this is the earliest place for it. + #:duplicate-names + ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes #:name #:version #:description #:long-description #:author #:maintainer #:licence #:components-by-name #:components @@ -5607,7 +6523,24 @@ another pathname in a degenerate way.")) ;; Backward compatible way of computing the FILE-TYPE of a component. ;; TODO: find users, have them stop using that, remove it for ASDF4. - (defgeneric (source-file-type) (component system))) + (defgeneric (source-file-type) (component system)) + + (define-condition system-definition-error (error) () + ;; [this use of :report should be redundant, but unfortunately it's not. + ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function + ;; over print-object; this is always conditions::%print-condition for + ;; condition objects, which in turn does inheritance of :report options at + ;; run-time. fortunately, inheritance means we only need this kludge here in + ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] + #+cmu (:report print-object)) + + (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)))))) + + (when-upgrading (:when (find-class 'component nil)) (defmethod reinitialize-instance :after ((c component) &rest initargs &key) @@ -5838,7 +6771,7 @@ another pathname in a degenerate way.")) (asdf/package:define-package :asdf/system (:recycle :asdf :asdf/system) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/component) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component) (:export #:system #:proto-system #:system-source-file #:system-source-directory #:system-relative-pathname @@ -5948,9 +6881,9 @@ in which the system specification (.asd file) is located." ;;;; Stamp cache (asdf/package:define-package :asdf/cache - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp - #:consult-asdf-cache #:do-asdf-cache + #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*)) (in-package :asdf/cache) @@ -5988,29 +6921,39 @@ in which the system specification (.asd file) is located." (defmacro with-asdf-cache ((&key override) &body body) `(call-with-asdf-cache #'(lambda () ,@body) :override ,override)) - (defun compute-file-stamp (file) - (safe-file-write-date file)) + (defun normalize-namestring (pathname) + (let ((resolved (resolve-symlinks* + (ensure-absolute-pathname + (physicalize-pathname pathname) + 'get-pathname-defaults)))) + (with-pathname-defaults () (namestring resolved)))) - (defun register-file-stamp (file &optional (stamp (compute-file-stamp file))) - (set-asdf-cache-entry `(get-file-stamp ,file) (list stamp))) + (defun compute-file-stamp (normalized-namestring) + (with-pathname-defaults () + (safe-file-write-date normalized-namestring))) - (defun get-file-stamp (file) - (do-asdf-cache `(get-file-stamp ,file) (compute-file-stamp file)))) + (defun register-file-stamp (file &optional (stamp nil stampp)) + (let* ((namestring (normalize-namestring file)) + (stamp (if stampp stamp (compute-file-stamp namestring)))) + (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp)))) + (defun get-file-stamp (file) + (let ((namestring (normalize-namestring file))) + (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))) ;;;; ------------------------------------------------------------------------- ;;;; Finding systems (asdf/package:define-package :asdf/find-system (:recycle :asdf/find-system :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/cache) (:export #:remove-entry-from-registry #:coerce-entry-to-directory #:coerce-name #:primary-system-name #:coerce-filename #:find-system #:locate-system #:load-asd #:with-system-definitions #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems - #:system-definition-error #:missing-component #:missing-requires #:missing-parent + #:missing-component #:missing-requires #:missing-parent #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error #:load-system-definition-error #:error-name #:error-pathname #:error-condition #:*system-definition-search-functions* #:search-for-system-definition @@ -6026,15 +6969,6 @@ in which the system specification (.asd file) is located." (with-upgradability () (declaim (ftype (function (&optional t) t) initialize-source-registry)) ; forward reference - (define-condition system-definition-error (error) () - ;; [this use of :report should be redundant, but unfortunately it's not. - ;; cmucl's lisp::output-instance prefers the kernel:slot-class-print-function - ;; over print-object; this is always conditions::%print-condition for - ;; condition objects, which in turn does inheritance of :report options at - ;; run-time. fortunately, inheritance means we only need this kludge here in - ;; order to fix all conditions that build on it. -- rgr, 28-Jul-02.] - #+cmu (:report print-object)) - (define-condition missing-component (system-definition-error) ((requires :initform "(unnamed)" :reader missing-requires :initarg :requires) (parent :initform nil :reader missing-parent :initarg :parent))) @@ -6134,7 +7068,7 @@ called with an object of type asdf:system." (setf *system-definition-search-functions* (append ;; Remove known-incompatible sysdef functions from old versions of asdf. - (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf))) + (remove-if #'(lambda (x) (member x '(contrib-sysdef-search sysdef-find-asdf sysdef-preloaded-system-search))) *system-definition-search-functions*) ;; Tuck our defaults at the end of the list if they were absent. ;; This is imperfect, in case they were removed on purpose, @@ -6142,14 +7076,16 @@ called with an object of type asdf:system." ;; to upgrade asdf before he does such a thing rather than after. (remove-if #'(lambda (x) (member x *system-definition-search-functions*)) '(sysdef-central-registry-search - sysdef-source-registry-search - sysdef-preloaded-system-search))))) + sysdef-source-registry-search))))) (cleanup-system-definition-search-functions) (defun search-for-system-definition (system) - (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) - (cons 'find-system-if-being-defined - *system-definition-search-functions*))) + (block () + (let ((name (coerce-name system))) + (flet ((try (f) (if-let ((x (funcall f name))) (return x)))) + (try 'find-system-if-being-defined) + (map () #'try *system-definition-search-functions*) + (try 'sysdef-preloaded-system-search))))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -6177,7 +7113,7 @@ Going forward, we recommend new users should be using the source-registry. :truename truename)) (return file)) #-(or clisp genera) ; clisp doesn't need it, plain genera doesn't have read-sequence(!) - (when (os-windows-p) + (when (and (os-windows-p) (physical-pathname-p defaults)) (let ((shortcut (make-pathname :defaults defaults :case :local @@ -6252,7 +7188,9 @@ Going forward, we recommend new users should be using the source-registry. (setf (gethash (coerce-name system-name) *preloaded-systems*) keys)) (register-preloaded-system "asdf" :version *asdf-version*) + (register-preloaded-system "uiop" :version *asdf-version*) (register-preloaded-system "asdf-driver" :version *asdf-version*) + (register-preloaded-system "asdf-defsystem" :version *asdf-version*) (defmethod find-system ((name null) &optional (error-p t)) (declare (ignorable name)) @@ -6267,7 +7205,8 @@ Going forward, we recommend new users should be using the source-registry. (defun find-system-if-being-defined (name) (when *systems-being-defined* - (gethash (coerce-name name) *systems-being-defined*))) + ;; notable side effect: mark the system as being defined, to avoid infinite loops + (ensure-gethash (coerce-name name) *systems-being-defined* nil))) (defun call-with-system-definitions (thunk) (if *systems-being-defined* @@ -6298,7 +7237,7 @@ Going forward, we recommend new users should be using the source-registry. (*print-readably* nil) (*default-pathname-defaults* ;; resolve logical-pathnames so they won't wreak havoc in parsing namestrings. - (pathname-directory-pathname (translate-logical-pathname pathname)))) + (pathname-directory-pathname (physicalize-pathname pathname)))) (handler-bind ((error #'(lambda (condition) (error 'load-system-definition-error @@ -6319,13 +7258,13 @@ Going forward, we recommend new users should be using the source-registry. (read-file-form version-pathname))) (old-version (asdf-version))) (or (version<= old-version version) - (let ((old-pathname - (if-let (pair (system-registered-p "asdf")) - (system-source-file (cdr pair)))) - (key (list pathname old-version))) - (unless (gethash key *old-asdf-systems*) - (setf (gethash key *old-asdf-systems*) t) - (warn "~@<~ + (ensure-gethash + (list pathname old-version) *old-asdf-systems* + #'(lambda () + (let ((old-pathname + (if-let (pair (system-registered-p "asdf")) + (system-source-file (cdr pair))))) + (warn "~@<~ You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ @@ -6347,7 +7286,8 @@ Going forward, we recommend new users should be using the source-registry. then you might indeed want to either install and register a more recent version, ~ or use :ignore-inherited-configuration to avoid registering the old one. ~ Please consult ASDF documentation and/or experts.~@:>~%" - old-version old-pathname version pathname))))))) + old-version old-pathname version pathname) + t))))))) (defun locate-system (name) "Given a system NAME designator, try to locate where to load the system from. @@ -6384,6 +7324,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (defmethod find-system ((name string) &optional (error-p t)) (with-system-definitions () + (let ((primary-name (primary-system-name name))) + (unless (or (equal name primary-name) + (nth-value 1 (gethash primary-name *systems-being-defined*))) + (find-system primary-name nil))) (loop (restart-case (multiple-value-bind (foundp found-system pathname previous previous-time) @@ -6402,8 +7346,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (or (pathname-equal pathname previous-pathname) (and pathname previous-pathname (pathname-equal - (translate-logical-pathname pathname) - (translate-logical-pathname previous-pathname)))) + (physicalize-pathname pathname) + (physicalize-pathname previous-pathname)))) (stamp<= stamp previous-time)))))) ;; only load when it's a pathname that is different or has newer content, and not an old asdf (load-asd pathname :name name))) @@ -6426,7 +7370,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (asdf/package:define-package :asdf/find-component (:recycle :asdf/find-component :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/find-system) (:export #:find-component @@ -6556,7 +7500,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (asdf/package:define-package :asdf/operation (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:operation #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE. @@ -6591,11 +7535,8 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (with-upgradability () (defparameter *operations* (make-hash-table :test 'equal)) (defun make-operation (operation-class &rest initargs) - (let ((key (cons operation-class initargs))) - (multiple-value-bind (operation foundp) (gethash key *operations*) - (if foundp operation - (setf (gethash key *operations*) - (apply 'make-instance operation-class initargs)))))) + (ensure-gethash (cons operation-class initargs) *operations* + (list* 'make-instance operation-class initargs))) (defgeneric find-operation (context spec) (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) @@ -6620,7 +7561,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (asdf/package:define-package :asdf/action (:nicknames :asdf-action) (:recycle :asdf/action :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system #:asdf/cache :asdf/find-system :asdf/find-component :asdf/operation) (:export #:action #:define-convenience-action-methods @@ -6937,8 +7878,8 @@ in some previous image, or T if it needs to be done.") (asdf/package:define-package :asdf/lisp-action (:recycle :asdf/lisp-action :asdf) (:intern #:proclamations #:flags) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade - :asdf/cache :asdf/component :asdf/system :asdf/find-component :asdf/find-system + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache + :asdf/component :asdf/system :asdf/find-component :asdf/find-system :asdf/operation :asdf/action) (:export #:try-recompiling @@ -7187,7 +8128,7 @@ in some previous image, or T if it needs to be done.") (asdf/package:define-package :asdf/plan (:recycle :asdf/plan :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/operation :asdf/system :asdf/cache :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action) @@ -7635,14 +8576,15 @@ the action of OPERATION on COMPONENT in the PLAN")) (asdf/package:define-package :asdf/operate (:recycle :asdf/operate :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) (:export #:operate #:oos #:*systems-being-operated* #:build-system - #:load-system #:load-systems #:compile-system #:test-system #:require-system + #:load-system #:load-systems #:load-systems* + #:compile-system #:test-system #:require-system #:*load-system-operation* #:module-provide-asdf #:component-loaded-p #:already-loaded-systems)) (in-package :asdf/operate) @@ -7752,9 +8694,13 @@ for how to load or compile stuff") (apply 'operate *load-system-operation* system keys) t) + (defun load-systems* (systems &rest keys) + "Loading multiple systems at once." + (dolist (s systems) (apply 'load-system s keys))) + (defun load-systems (&rest systems) "Loading multiple systems at once." - (map () 'load-system systems)) + (load-systems* systems)) (defun compile-system (system &rest args &key force force-not verbose version &allow-other-keys) "Shorthand for `(asdf:operate 'asdf:compile-op system)`. See OPERATE for details." @@ -7848,7 +8794,7 @@ for how to load or compile stuff") (asdf/package:define-package :asdf/backward-internals (:recycle :asdf/backward-internals :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/system :asdf/component :asdf/operation :asdf/find-system :asdf/action :asdf/lisp-action) (:export ;; for internal use @@ -7938,7 +8884,7 @@ for how to load or compile stuff") (asdf/package:define-package :asdf/defsystem (:recycle :asdf/defsystem :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/cache :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate :asdf/backward-internals) @@ -7946,7 +8892,7 @@ for how to load or compile stuff") #:defsystem #:register-system-definition #:class-for-type #:*default-component-class* #:determine-system-directory #:parse-component-form - #:duplicate-names #:non-toplevel-system #:non-system-system + #:non-toplevel-system #:non-system-system #:sysdef-error-component #:check-component-input)) (in-package :asdf/defsystem) @@ -8001,12 +8947,6 @@ for how to load or compile stuff") ;;; 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))))) - (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)) @@ -8055,10 +8995,12 @@ for how to load or compile stuff") (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))) + (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))) + (safe-read-file-line (subpathname pathname subpath) + :at at))) (otherwise (invalid)))) (t @@ -8161,7 +9103,7 @@ for how to load or compile stuff") (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) + (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))) @@ -8182,7 +9124,7 @@ for how to load or compile stuff") (asdf/package:define-package :asdf/bundle (:recycle :asdf/bundle :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) (:export @@ -8284,7 +9226,7 @@ for how to load or compile stuff") ((member :binary :dll :lib :shared-library :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"))) + ((eql :dll) (cond ((os-macosx-p) "dylib") ((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"))))) @@ -8674,7 +9616,7 @@ for how to load or compile stuff") (asdf/package:define-package :asdf/concatenate-source (:recycle :asdf/concatenate-source :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/operation :asdf/system :asdf/find-system :asdf/defsystem :asdf/action :asdf/lisp-action :asdf/bundle) @@ -8728,15 +9670,18 @@ for how to load or compile stuff") (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))) + (let ((a (assoc e other-encodings))) + (if a (push (component-find-path c) (cdr a)) + (push (list a (component-find-path c)) other-encodings))))) + (unless (equal around-compile (around-compile-hook c)) + (push (component-find-path c) other-around-compile)) (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)) + (warn "~S uses encoding ~A but has sources that use these encodings:~{ ~A~}" + operation encoding + (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x))))) + 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)) @@ -8760,7 +9705,7 @@ for how to load or compile stuff") (asdf/package:define-package :asdf/output-translations (:recycle :asdf/output-translations :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade) + (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:*output-translations* #:*output-translations-parameter* #:invalid-output-translation @@ -8954,10 +9899,7 @@ and the order is by decreasing length of namestring of the source pathname.") (cond ((location-function-p dst) (funcall collect - (list trusrc - (if (symbolp (second dst)) - (fdefinition (second dst)) - (eval (second dst)))))) + (list trusrc (ensure-function (second dst))))) ((eq dst t) (funcall collect (list trusrc t))) (t @@ -9042,7 +9984,7 @@ effectively disabling the output translation facility." :return (translate-pathname* p absolute-source destination root source) :finally (return p))))) - ;; Hook into asdf/driver's output-translation mechanism + ;; Hook into uiop's output-translation mechanism #-cormanlisp (setf *output-translation-function* 'apply-output-translations) @@ -9220,15 +10162,13 @@ Deprecated function, for backward-compatibility only. Please use UIOP:RUN-PROGRAM instead." (let ((command (apply 'format nil control-string args))) (asdf-message "; $ ~A~%" command) - (handler-case - (progn - (run-program command :force-shell t :ignore-error-status nil :output *verbose-out*) - 0) - (subprocess-error (c) - (let ((code (subprocess-error-code c))) - (typecase code - (integer code) - (t 255)))))))) + (let ((exit-code + (ignore-errors + (nth-value 2 (run-program command :force-shell t :ignore-error-status t + :output *verbose-out*))))) + (typecase exit-code + ((integer 0 255) exit-code) + (t 255)))))) (with-upgradability () (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. @@ -9254,7 +10194,7 @@ Please use UIOP:RUN-PROGRAM instead." (asdf/package:define-package :asdf/source-registry (:recycle :asdf/source-registry :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/find-system) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) (:export #:*source-registry-parameter* #:*default-source-registries* #:invalid-source-registry @@ -9575,7 +10515,7 @@ system names to pathnames of .asd files") #:split #:make-collector #:loaded-systems ; makes for annoying SLIME completion #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade :asdf/cache + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/output-translations :asdf/source-registry @@ -9587,7 +10527,7 @@ system names to pathnames of .asd files") #:oos #:operate #:make-plan #: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 + #:compile-system #:load-system #:load-systems #:load-systems* #:require-system #:test-system #:clear-system #:operation #:make-operation #:find-operation #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation @@ -9737,7 +10677,7 @@ system names to pathnames of .asd files") (asdf/package:define-package :asdf/footer (:recycle :asdf/footer :asdf) - (:use :asdf/common-lisp :asdf/driver :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/operate :asdf/bundle :asdf/concatenate-source :asdf/output-translations :asdf/source-registry diff --git a/src/general-info/release-20f.txt b/src/general-info/release-20f.txt index 3b3f9ef..4077097 100644 --- a/src/general-info/release-20f.txt +++ b/src/general-info/release-20f.txt @@ -23,6 +23,7 @@ New in this release: * Feature enhancements * Changes + * Update to ASDF 3.0.3. * When *PRINT-CASE* is :DOWNCASE, integers are printed with lowercase letters when needed. * Micro-optimize KERNEL:DOUBLE-FLOAT-BITS for x86/sse2. ----------------------------------------------------------------------- Summary of changes: src/contrib/asdf/asdf.lisp | 1878 ++++++++++++++++++++++++++++---------- src/general-info/release-20f.txt | 1 + 2 files changed, 1410 insertions(+), 469 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-08-21-g3309732
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 33097329493c7a767bcc4434f3212badcb33236a (commit) from d2f946ac549cdc8da46c3bfbee61c52d8fd81f5e (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 33097329493c7a767bcc4434f3212badcb33236a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Aug 21 21:51:13 2014 -0700 Make exp signal errors using fdlibm_setexception. * src/lisp/e_exp.c * Use fdlibm_setexception * tests/trig.lisp: * Add tests for exp. diff --git a/src/lisp/e_exp.c b/src/lisp/e_exp.c index 8b7ff6d..034c590 100644 --- a/src/lisp/e_exp.c +++ b/src/lisp/e_exp.c @@ -130,12 +130,19 @@ P5 = 4.13813679705723846039e-08; /* 0x3E663769, 0x72BEA4D0 */ /* filter out non-finite argument */ if(hx >= 0x40862E42) { /* if |x|>=709.78... */ if(hx>=0x7ff00000) { - if(((hx&0xfffff)|ux.i[LOWORD])!=0) - return x+x; /* NaN */ - else return (xsb==0)? x:0.0; /* exp(+-inf)={inf,0} */ + if(((hx&0xfffff)|ux.i[LOWORD])!=0) { + /* NaN */ + return fdlibm_setexception(x, FDLIBM_INVALID); + } 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 */ + if(x > o_threshold) { + /* overflow */ + return fdlibm_setexception(x, FDLIBM_OVERFLOW); + } + + if(x < u_threshold) return x; /* underflow */ } /* argument reduction */ diff --git a/tests/trig.lisp b/tests/trig.lisp index 2f4a945..5001375 100644 --- a/tests/trig.lisp +++ b/tests/trig.lisp @@ -899,3 +899,16 @@ (kernel:%log1p -1d0))) (kernel::with-float-traps-masked (:invalid) (assert-true (ext:float-nan-p (kernel:%log1p *snan*))))) + +(define-test exp.exceptions + (:tag :fdlibm) + (assert-error 'floating-point-overflow + (kernel:%exp 710d0)) + (assert-true (ext:float-nan-p (kernel:%exp *qnan*))) + (assert-error 'floating-point-invalid-operation + (kernel:%exp *snan*)) + (assert-equal ext:double-float-positive-infinity + (kernel:%exp ext:double-float-positive-infinity)) + (kernel::with-float-traps-masked (:overflow) + (assert-equal ext:double-float-positive-infinity + (kernel:%exp 710d0)))) \ No newline at end of file ----------------------------------------------------------------------- Summary of changes: src/lisp/e_exp.c | 17 ++++++++++++----- tests/trig.lisp | 13 +++++++++++++ 2 files changed, 25 insertions(+), 5 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-05-1-g18e61a1
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 18e61a1940ee181a9583ded9044286d8b7983da7 (commit) from fc6ec6d77cdde9c73bb3b6c8a2c5d1d6ced9094f (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 18e61a1940ee181a9583ded9044286d8b7983da7 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue May 6 19:49:23 2014 -0700 Update to ASDF 3.1.2. diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp index 3592557..cce093d 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 3.0.3: Another System Definition Facility. +;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; buffer-read-only: t; -*- +;;; This is ASDF 3.1.2: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -19,7 +19,7 @@ ;;; http://www.opensource.org/licenses/mit-license.html on or about ;;; Monday; July 13, 2009) ;;; -;;; Copyright (c) 2001-2012 Daniel Barlow and contributors +;;; Copyright (c) 2001-2014 Daniel Barlow and contributors ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining ;;; a copy of this software and associated documentation files (the @@ -51,10 +51,16 @@ #+cmu (eval-when (:load-toplevel :compile-toplevel :execute) - (declaim (optimize (speed 1) (safety 3) (debug 3))) (setf ext:*gc-verbose* nil)) -#+(or abcl clisp clozure cmu ecl xcl) ;; punt on hard package upgrade on those implementations +;;; pre 1.3.0 ABCL versions do not support the bundle-op on Mac OS X +#+abcl +(eval-when (:load-toplevel :compile-toplevel :execute) + (unless (and (member :darwin *features*) + (second (third (sys::arglist 'directory)))) + (push :abcl-bundle-op-supported *features*))) + +;; Punt on hard package upgrade: from ASDF1 always, and even from ASDF2 on most implementations. (eval-when (:load-toplevel :compile-toplevel :execute) (unless (member :asdf3 *features*) (let* ((existing-version @@ -71,11 +77,12 @@ (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 2.27)) + (< existing-version-number + #+(or allegro clisp lispworks sbcl) 2.0 + #-(or allegro clisp lispworks sbcl) 2.27)) (rename-package :asdf away) (when *load-verbose* (format t "~&; Renamed old ~A package away to ~A~%" :asdf away)))))) - ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. ;; @@ -562,7 +569,7 @@ or when loading the package is optional." (home-package-p existing to-package) (symbol-package-name existing))) (t (ensure-inherited name symbol to-package from-package t shadowed imported inherited))))))) - + (defun recycle-symbol (name recycle exported) ;; Takes a symbol NAME (a string), a list of package designators for RECYCLE ;; packages, and a hash-table of names (strings) of symbols scheduled to be @@ -615,7 +622,7 @@ or when loading the package is optional." (unintern existing)) (when intern (intern* name package)))))))) - (declaim (ftype function ensure-exported)) + (declaim (ftype (function (t t t &optional t) t) ensure-exported)) (defun ensure-exported-to-user (name symbol to-package &optional recycle) (check-type name string) (check-type symbol symbol) @@ -656,7 +663,7 @@ or when loading the package is optional." import-from export intern recycle mix reexport unintern) - #+(or gcl2.6 genera) (declare (ignore documentation)) + #+genera (declare (ignore documentation)) (let* ((package-name (string name)) (nicknames (mapcar #'string nicknames)) (names (cons package-name nicknames)) @@ -678,7 +685,7 @@ or when loading the package is optional." ;; string to list home package and use package: (inherited (make-hash-table :test 'equal))) (when-package-fishiness (record-fishy package-name)) - #-(or gcl2.6 genera) + #-genera (when documentation (setf (documentation package t) documentation)) (loop :for p :in (set-difference (package-use-list package) (append mix use)) :do (note-package-fishiness :over-use name (package-names p)) @@ -758,22 +765,26 @@ or when loading the package is optional." :with documentation = nil :for (kw . args) :in clauses :when (eq kw :nicknames) :append args :into nicknames :else - :when (eq kw :documentation) - :do (cond - (documentation (error "define-package: can't define documentation twice")) - ((or (atom args) (cdr args)) (error "define-package: bad documentation")) - (t (setf documentation (car args)))) :else + :when (eq kw :documentation) + :do (cond + (documentation (error "define-package: can't define documentation twice")) + ((or (atom args) (cdr args)) (error "define-package: bad documentation")) + (t (setf documentation (car args)))) :else :when (eq kw :use) :append args :into use :and :do (setf use-p t) :else - :when (eq kw :shadow) :append args :into shadow :else - :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else - :when (eq kw :import-from) :collect args :into import-from :else - :when (eq kw :export) :append args :into export :else - :when (eq kw :intern) :append args :into intern :else - :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else - :when (eq kw :mix) :append args :into mix :else - :when (eq kw :reexport) :append args :into reexport :else - :when (eq kw :unintern) :append args :into unintern :else - :do (error "unrecognized define-package keyword ~S" kw) + :when (eq kw :shadow) :append args :into shadow :else + :when (eq kw :shadowing-import-from) :collect args :into shadowing-import-from :else + :when (eq kw :import-from) :collect args :into import-from :else + :when (eq kw :export) :append args :into export :else + :when (eq kw :intern) :append args :into intern :else + :when (eq kw :recycle) :append args :into recycle :and :do (setf recycle-p t) :else + :when (eq kw :mix) :append args :into mix :else + :when (eq kw :reexport) :append args :into reexport :else + :when (eq kw :use-reexport) :append args :into use :and :append args :into reexport + :and :do (setf use-p t) :else + :when (eq kw :mix-reexport) :append args :into mix :and :append args :into reexport + :and :do (setf use-p t) :else + :when (eq kw :unintern) :append args :into unintern :else + :do (error "unrecognized define-package keyword ~S" kw) :finally (return `(,package :nicknames ,nicknames :documentation ,documentation :use ,(if use-p use '(:common-lisp)) @@ -783,7 +794,7 @@ or when loading the package is optional." :mix ,mix :reexport ,reexport :unintern ,unintern))))) (defmacro define-package (package &rest clauses) - "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form + "DEFINE-PACKAGE takes a PACKAGE and a number of CLAUSES, of the form $KEYWORD . ARGS$. DEFINE-PACKAGE supports the following keywords: USE, SHADOW, SHADOWING-IMPORT-FROM, IMPORT-FROM, EXPORT, INTERN -- as per CL:DEFPACKAGE. @@ -797,10 +808,10 @@ should appear in first position if it already exists, and even if it doesn't, ahead of any package that is not going to be deleted afterwards and never created again. In short, except for special cases, always make it the first package on the list if the list is not empty. -MIX -- Takes a list of package designators. MIX behaves like +MIX -- Takes a list of package designators. MIX behaves like $:USE PKG1 PKG2 ... PKGn$ but additionally uses :SHADOWING-IMPORT-FROM to resolve conflicts in favor of the first found symbol. It may still yield -an error if there is a conflict with an explicitly :SHADOWING-IMPORT-FROM symbol. +an error if there is a conflict with an explicitly :IMPORT-FROM symbol. REEXPORT -- Takes a list of package designators. For each package, p, in the list, export symbols with the same name as those exported from p. Note that in the case of shadowing, etc. the symbols with the same name may not be the same symbols. @@ -808,10 +819,7 @@ UNINTERN -- Remove symbols here from PACKAGE." (let ((ensure-form `(apply 'ensure-package ',(parse-define-package-form package clauses)))) `(progn - #+clisp - (eval-when (:compile-toplevel :load-toplevel :execute) - ,ensure-form) - #+(or clisp ecl gcl) (defpackage ,package (:use)) + #+(or ecl gcl mkcl) (defpackage ,package (:use)) (eval-when (:compile-toplevel :load-toplevel :execute) ,ensure-form)))) @@ -823,21 +831,7 @@ UNINTERN -- Remove symbols here from PACKAGE." #+allegro ;; We need to disable autoloading BEFORE any mention of package ASDF. (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* - :test 'equalp :key 'car)) - #+gcl - ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, - ;; but can run ASDF 2.011. GCL 2.6 has even more issues. - (cond - ((or (< system::*gcl-major-version* 2) - (and (= system::*gcl-major-version* 2) - (< system::*gcl-minor-version* 6))) - (error "GCL 2.6 or later required to use ASDF")) - ((and (= system::*gcl-major-version* 2) - (= system::*gcl-minor-version* 6)) - (pushnew 'ignorable pcl::*variable-declarations-without-argument*) - (pushnew :gcl2.6 *features*)) - (t - (pushnew :gcl2.7 *features*)))) + :test 'equalp :key 'car))) ;; Compatibility with whoever calls asdf/package (define-package :asdf/package (:use :cl :uiop/package) (:reexport :uiop/package)) @@ -860,8 +854,6 @@ UNINTERN -- Remove symbols here from PACKAGE." (:export #:logical-pathname #:translate-logical-pathname #:make-broadcast-stream #:file-namestring) - #+gcl2.6 (:shadow #:type-of #:with-standard-io-syntax) ; causes errors when loading fasl(!) - #+gcl2.6 (:shadowing-import-from :system #:*load-pathname*) #+genera (:shadowing-import-from :scl #:boolean) #+genera (:export #:boolean #:ensure-directories-exist) #+mcl (:shadow #:user-homedir-pathname)) @@ -875,7 +867,7 @@ UNINTERN -- Remove symbols here from PACKAGE." ;;;; Early meta-level tweaks -#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks sbcl scl) +#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl) (eval-when (:load-toplevel :compile-toplevel :execute) ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. @@ -925,48 +917,21 @@ UNINTERN -- Remove symbols here from PACKAGE." (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) (unless (use-ecl-byte-compiler-p) (require :cmp))) -#+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 +#+gcl (eval-when (:load-toplevel :compile-toplevel :execute) (unless (member :ansi-cl *features*) (error "ASDF only supports GCL in ANSI mode. Aborting.~%")) (setf compiler::*compiler-default-type* (pathname "") - compiler::*lsp-ext* "")) - -#+gcl2.6 -(eval-when (:compile-toplevel :load-toplevel :execute) - (shadow 'type-of :uiop/common-lisp) - (shadowing-import 'system:*load-pathname* :uiop/common-lisp)) - -#+gcl2.6 -(eval-when (:compile-toplevel :load-toplevel :execute) - (export 'type-of :uiop/common-lisp) - (export 'system:*load-pathname* :uiop/common-lisp)) - -#+gcl2.6 ;; Doesn't support either logical-pathnames or output-translations. -(eval-when (:load-toplevel :compile-toplevel :execute) - (defvar *gcl2.6* t) - (deftype logical-pathname () nil) - (defun type-of (x) (class-name (class-of x))) - (defun wild-pathname-p (path) (declare (ignore path)) nil) - (defun translate-logical-pathname (x) x) - (defvar *compile-file-pathname* nil) - (defun pathname-match-p (in-pathname wild-pathname) - (declare (ignore in-wildname wild-wildname)) nil) - (defun translate-pathname (source from-wildname to-wildname &key) - (declare (ignore from-wildname to-wildname)) source) - (defun %print-unreadable-object (object stream type identity thunk) - (format stream "#<~@[~S ~]" (when type (type-of object))) - (funcall thunk) - (format stream "~@[ ~X~]>" (when identity (system:address object)))) - (defmacro with-standard-io-syntax (&body body) - `(progn ,@body)) - (defmacro with-compilation-unit (options &body body) - (declare (ignore options)) `(progn ,@body)) - (defmacro print-unreadable-object ((object stream &key type identity) &body body) - `(%print-unreadable-object ,object ,stream ,type ,identity (lambda () ,@body))) - (defun ensure-directories-exist (path) - (lisp:system (format nil "mkdir -p ~S" - (namestring (make-pathname :name nil :type nil :version nil :defaults path)))))) + compiler::*lsp-ext* "") + #.(let ((code ;; Only support very recent GCL 2.7.0 from November 2013 or later. + (cond + #+gcl + ((or (< system::*gcl-major-version* 2) + (and (= system::*gcl-major-version* 2) + (< system::*gcl-minor-version* 7))) + '(error "GCL 2.7 or later required to use ASDF"))))) + (eval code) + code)) #+genera (eval-when (:load-toplevel :compile-toplevel :execute) @@ -1015,7 +980,7 @@ FROB them, that is to say, remove them if FROB is NIL, replace by FROB if FROB is a STRING, or if FROB is a FUNCTION, call FROB with the match and a function that emits a string in the output. Return a string made of the parts not omitted or emitted by FROB." - (declare (optimize (speed 0) (safety 3) (debug 3))) + (declare (optimize (speed 0) (safety #-gcl 3 #+gcl 0) (debug 3))) (let ((length (length string)) (stream nil)) (labels ((emit-string (x &optional (start 0) (end (length x))) (when (< start end) @@ -1049,7 +1014,7 @@ Return a string made of the parts not omitted or emitted by FROB." (defmacro compatfmt (format) #+(or gcl genera) - (frob-substrings format `("~3i~_" #+(or genera gcl2.6) ,@'("~@<" "~@;" "~@:>" "~:>"))) + (frob-substrings format `("~3i~_" #+genera ,@'("~@<" "~@;" "~@:>" "~:>"))) #-(or gcl genera) format)) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities for ASDF @@ -1066,8 +1031,9 @@ Return a string made of the parts not omitted or emitted by FROB." (:export ;; magic helper to define debugging functions: #: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 + #:with-upgradability ;; (un)defining functions in an upgrade-friendly way + #:undefine-function #:undefine-functions #:defun* #:defgeneric* + #:nest #:if-let ;; basic flow control #:while-collecting #:appendf #:length=n-p #:ensure-list ;; lists #:remove-plist-keys #:remove-plist-key ;; plists #:emptyp ;; sequences @@ -1076,7 +1042,7 @@ Return a string made of the parts not omitted or emitted by FROB." #:base-string-p #:strings-common-element-type #:reduce/strcat #:strcat ;; strings #:first-char #:last-char #:split-string #:stripln #:+cr+ #:+lf+ #:+crlf+ #:string-prefix-p #:string-enclosed-p #:string-suffix-p - #:find-class* ;; CLOS + #:coerce-class ;; CLOS #:stamp< #:stamps< #:stamp*< #:stamp<= ;; stamps #:earlier-stamp #:stamps-earliest #:earliest-stamp #:later-stamp #:stamps-latest #:latest-stamp #:latest-stamp-f @@ -1098,6 +1064,9 @@ Return a string made of the parts not omitted or emitted by FROB." (defun undefine-function (function-spec) (cond ((symbolp function-spec) + ;; undefining the previous function is the portable way + ;; of overriding any incompatible previous gf, + ;; but CLISP needs extra help with getting rid of previous methods. #+clisp (let ((f (and (fboundp function-spec) (fdefinition function-spec)))) (when (typep f 'clos:standard-generic-function) @@ -1106,7 +1075,7 @@ Return a string made of the parts not omitted or emitted by FROB." (fmakunbound function-spec)) ((and (consp function-spec) (eq (car function-spec) 'setf) (consp (cdr function-spec)) (null (cddr function-spec))) - #-gcl2.6 (fmakunbound function-spec)) + (fmakunbound function-spec)) (t (error "bad function spec ~S" function-spec)))) (defun undefine-functions (function-spec-list) (map () 'undefine-function function-spec-list)) @@ -1119,29 +1088,28 @@ Return a string made of the parts not omitted or emitted by FROB." name) (declare (ignorable supersede)) `(progn - ;; undefining the previous function is the portable way - ;; of overriding any incompatible previous gf, except on CLISP. ;; We usually try to do it only for the functions that need it, - ;; which happens in asdf/upgrade - however, for ECL, we need this hammer - ;; (which causes issues in clisp) - ,@(when (or #-clisp supersede #+(or ecl gcl2.7) t) + ;; which happens in asdf/upgrade - however, for ECL, we need this hammer. + ,@(when (or supersede #+ecl t) `((undefine-function ',name))) - #-gcl ; gcl 2.7.0 notinline functions lose secondary return values :-( ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl `((declaim (notinline ,name)))) (,',def ,name ,formals ,@rest)))))) (defdef defgeneric* defgeneric) (defdef defun* defun)) (defmacro with-upgradability ((&optional) &body body) + "Evaluate BODY at compile- load- and run- times, with DEFUN and DEFGENERIC modified +to also declare the functions NOTINLINE and to accept a wrapping the function name +specification into a list with keyword argument SUPERSEDE (which defaults to T if the name +is not wrapped, and NIL if it is wrapped). If SUPERSEDE is true, call UNDEFINE-FUNCTION +to supersede any previous definition." `(eval-when (:compile-toplevel :load-toplevel :execute) ,@(loop :for form :in body :collect (if (consp form) (destructuring-bind (car . cdr) form (case car ((defun) `(defun* ,@cdr)) - ((defgeneric) - (unless (or #+gcl2.6 (and (consp (car cdr)) (eq 'setf (caar cdr)))) - `(defgeneric* ,@cdr))) + ((defgeneric) `(defgeneric* ,@cdr)) (otherwise form))) form))))) @@ -1167,9 +1135,13 @@ Return a string made of the parts not omitted or emitted by FROB." (if file (load file) (error "Failed to locate debug utility file: ~S" utility-file))))))) - ;;; Flow control (with-upgradability () + (defmacro nest (&rest things) + "Macro to do keep code nesting and indentation under control." ;; Thanks to mbaringer + (reduce #'(lambda (outer inner) `(,@outer ,inner)) + things :from-end t)) + (defmacro if-let (bindings &body (then-form &optional else-form)) ;; from alexandria ;; bindings can be (var form) or ((var1 form1) ...) (let* ((binding-list (if (and (consp bindings) (symbolp (car bindings))) @@ -1242,6 +1214,7 @@ Returns two values: $A B C$ and $1 2 3$." ;;; Characters (with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR. (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) + #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow??? (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) (with-upgradability () @@ -1294,7 +1267,8 @@ Returns two values: $A B C$ and $1 2 3$." 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))) + (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 @@ -1375,15 +1349,6 @@ the two results passed to STRCAT always reconstitute the original string" (when x (c +crlf+) (c +lf+) (c +cr+) (values x nil))))) -;;; CLOS -(with-upgradability () - (defun find-class* (x &optional (errorp t) environment) - (etypecase x - ((or standard-class built-in-class) x) - #+gcl2.6 (keyword nil) - (symbol (find-class x errorp environment))))) - - ;;; stamps: a REAL or a boolean where NIL=-infinity, T=+infinity (eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) (deftype stamp () '(or real boolean))) @@ -1425,7 +1390,8 @@ and EVAL that in a (FUNCTION ...) context." (etypecase fun (function fun) ((or boolean keyword character number pathname) (constantly fun)) - (symbol fun) + (hash-table (lambda (x) (gethash x fun))) + (symbol (fdefinition fun)) (cons (if (eq 'lambda (car fun)) (eval fun) #'(lambda (&rest args) (apply (car fun) (append (cdr fun) args))))) @@ -1481,16 +1447,49 @@ When CALL-NOW-P is true, also call the function immediately." (when call-now-p (call-function hook)))) +;;; CLOS +(with-upgradability () + (defun coerce-class (class &key (package :cl) (super t) (error 'error)) + "Coerce CLASS to a class that is subclass of SUPER if specified, +or invoke ERROR handler as per CALL-FUNCTION. + +A keyword designates the name a symbol, which when found in either PACKAGE, designates a class. +-- for backward compatibility, *PACKAGE* is also accepted for now, but this may go in the future. +A string is read as a symbol while in PACKAGE, the symbol designates a class. + +A class object designates itself. +NIL designates itself (no class). +A symbol otherwise designates a class by name." + (let* ((normalized + (typecase class + (keyword (or (find-symbol* class package nil) + (find-symbol* class *package* nil))) + (string (symbol-call :uiop :safe-read-from-string class :package package)) + (t class))) + (found + (etypecase normalized + ((or standard-class built-in-class) normalized) + ((or null keyword) nil) + (symbol (find-class normalized nil nil))))) + (or (and found + (or (eq super t) (#-cormanlisp subtypep #+cormanlisp cl::subclassp found super)) + found) + (call-function error "Can't coerce ~S to a ~@[class~;subclass of ~:*~S]" class super))))) + + ;;; Hash-tables (with-upgradability () (defun ensure-gethash (key table default) - "Lookup the TABLE for a KEY as by gethash, but if not present, + "Lookup the TABLE for a KEY as by GETHASH, but if not present, call the (possibly constant) function designated by DEFAULT as per CALL-FUNCTION, -set the corresponding entry to the result in the table, and return that result." +set the corresponding entry to the result in the table. +Return two values: the entry after its optional computation, and whether it was found" (multiple-value-bind (value foundp) (gethash key table) - (if foundp - value - (setf (gethash key table) (values (call-function default)))))) + (values + (if foundp + value + (setf (gethash key table) (call-function default))) + foundp))) (defun list-to-hash-set (list &aux (h (make-hash-table :test 'equal))) "Convert a LIST into hash-table that has the same elements when viewed as a set, @@ -1567,10 +1566,10 @@ with later being determined by a lexicographical comparison of minor numbers." #+clisp 'system::$format-control #+clozure 'ccl::format-control #+(or cmu scl) 'conditions::format-control - #+ecl 'si::format-control + #+(or ecl mkcl) 'si::format-control #+(or gcl lispworks) 'conditions::format-string #+sbcl 'sb-kernel:format-control - #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl) nil + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil "Name of the slot for FORMAT-CONTROL in simple-condition") (defun match-condition-p (x condition) @@ -1600,6 +1599,7 @@ or a string describing the format-control of a simple-condition." (funcall thunk))) (defmacro with-muffled-conditions ((conditions) &body body) + "Shorthand syntax for CALL-WITH-MUFFLED-CONDITIONS" `(call-with-muffled-conditions #'(lambda () ,@body) ,conditions))) ;;;; --------------------------------------------------------------------------- @@ -1653,7 +1653,7 @@ keywords explicitly." (defun os-windows-p () "Is the underlying operating system Microsoft Windows?" (or #+abcl (featurep :windows) - #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t)) + #+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32 mingw64)) t)) (defun os-genera-p () "Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?" @@ -1667,10 +1667,11 @@ keywords explicitly." "Detects the current operating system. Only needs be run at compile-time, except on ABCL where it might change between FASL compilation and runtime." (loop* :with o - :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-windows . os-windows-p) - (:os-macosx . os-macosx-p) + :for (feature . detect) :in '((:os-unix . os-unix-p) (:os-macosx . os-macosx-p) + (:os-windows . os-windows-p) (:genera . os-genera-p) (:os-oldmac . os-oldmac-p)) - :when (and (not o) (funcall detect)) :do (setf o feature) (pushnew o *features*) + :when (and (or (not o) (eq feature :os-macosx)) (funcall detect)) + :do (setf o feature) (pushnew feature *features*) :else :do (setf *features* (remove feature *features*)) :finally (return (or o (error "Congratulations for trying ASDF on an operating system~%~ @@ -1850,8 +1851,9 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie (defun getcwd () "Get the current working directory as per POSIX getcwd(3), as a pathname object" - (or #+abcl (parse-namestring - (java:jstatic "getProperty" "java.lang.System" "user.dir") :ensure-directory t) + (or #+abcl (truename (symbol-call :asdf/filesystem :parse-native-namestring + (java:jstatic "getProperty" "java.lang.System" "user.dir") + :ensure-directory t)) #+allegro (excl::current-directory) #+clisp (ext:default-directory) #+clozure (ccl:current-directory) @@ -1859,8 +1861,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie (strcat (nth-value 1 (unix:unix-current-directory)) "/")) #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? #+ecl (ext:getcwd) - #+gcl (parse-namestring ;; this is a joke. Isn't there a better way? - (first (symbol-call :uiop :run-program '("/bin/pwd") :output :lines))) + #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p"")) #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical! #+lispworks (system:current-directory) #+mkcl (mk-ext:getcwd) @@ -1882,7 +1883,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie #+genera (setf *default-pathname-defaults* x) #+lispworks (hcl:change-directory x) #+mkcl (mk-ext:chdir x) - #+sbcl (symbol-call :sb-posix :chdir (sb-ext:native-namestring x)) + #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) (error "chdir not supported on your implementation"))))) @@ -2018,33 +2019,22 @@ the number having BYTES octets (defaulting to 4)." "Convert the DIRECTORY component from a format usable by the underlying implementation's MAKE-PATHNAME and other primitives to a CLHS-standard format that is a list and not a string." - #+gcl2.6 (setf directory (substitute :back :parent directory)) (cond #-(or cmu sbcl scl) ;; these implementations already normalize directory components. ((stringp directory) `(:absolute ,directory)) - #+gcl2.6 - ((and (consp directory) (eq :root (first directory))) - `(:absolute ,@(rest directory))) ((or (null directory) (and (consp directory) (member (first directory) '(:absolute :relative)))) directory) - #+gcl2.6 + #+gcl ((consp directory) - `(:relative ,@directory)) + (cons :relative directory)) (t (error (compatfmt "~@<Unrecognized pathname directory component ~S~@:>") directory)))) (defun denormalize-pathname-directory-component (directory-component) "Convert the DIRECTORY-COMPONENT from a CLHS-standard format to a format usable by the underlying implementation's MAKE-PATHNAME and other primitives" - #-gcl2.6 directory-component - #+gcl2.6 - (let ((d (substitute-if :parent (lambda (x) (member x '(:up :back))) - directory-component))) - (cond - ((and (consp d) (eq :relative (first d))) (rest d)) - ((and (consp d) (eq :absolute (first d))) `(:root ,@(rest d))) - (t d)))) + directory-component) (defun merge-pathname-directory-components (specified defaults) "Helper for MERGE-PATHNAMES* that handles directory components" @@ -2073,11 +2063,11 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" ;; See CLHS make-pathname and 19.2.2.2.3. ;; This will be :unspecific if supported, or NIL if not. (defparameter *unspecific-pathname-type* - #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific - #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil + #+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific + #+(or clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") - (defun make-pathname* (&rest keys &key (directory nil #+gcl2.6 directoryp) + (defun make-pathname* (&rest keys &key (directory nil) host (device () #+allegro devicep) name type version defaults #+scl &allow-other-keys) "Takes arguments like CL:MAKE-PATHNAME in the CLHS, and @@ -2088,9 +2078,6 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" (apply 'make-pathname (append #+allegro (when (and devicep (null device)) `(:device :unspecific)) - #+gcl2.6 - (when directoryp - `(:directory ,(denormalize-pathname-directory-component directory))) keys))) (defun make-pathname-component-logical (x) @@ -2175,8 +2162,9 @@ when merging, making or parsing pathnames" ;; But CMUCL decides to die on NIL. ;; MCL has issues with make-pathname, nil and defaulting (declare (ignorable defaults)) - #.`(make-pathname* :directory nil :name nil :type nil :version nil :device nil - :host (or #+cmu lisp::*unix-host*) + #.`(make-pathname* :directory nil :name nil :type nil :version nil + :device (or #+(and mkcl unix) :unspecific) + :host (or #+cmu lisp::*unix-host* #+(and mkcl unix) "localhost") #+scl ,@'(:scheme nil :scheme-specific-part nil :username nil :password nil :parameters nil :query nil :fragment nil) ;; the default shouldn't matter, but we really want something physical @@ -2209,11 +2197,11 @@ when merging, making or parsing pathnames" (or (and (null p1) (null p2)) (and (pathnamep p1) (pathnamep p2) (and (=? pathname-host) - (=? pathname-device) + #-(and mkcl unix) (=? pathname-device) (=? normalize-pathname-directory-component pathname-directory) (=? pathname-name) (=? pathname-type) - (=? pathname-version))))))) + #-mkcl (=? pathname-version))))))) (defun absolute-pathname-p (pathspec) "If PATHSPEC is a pathname or namestring object that parses as a pathname @@ -2287,9 +2275,12 @@ ways that the filename components can be missing are for it to be NIL, Note that this does _not_ check to see that PATHNAME points to an actually-existing directory." (when pathname + ;; I tried using Allegro's excl:file-directory-p, but this cannot be done, + ;; because it rejects apparently legal pathnames as + ;; ill-formed. [2014/02/10:rpg] (let ((pathname (pathname pathname))) (flet ((check-one (x) - (member x '(nil :unspecific "") :test 'equal))) + (member x '(nil :unspecific) :test 'equal))) (and (not (wild-pathname-p pathname)) (check-one (pathname-name pathname)) (check-one (pathname-type pathname)) @@ -2465,13 +2456,14 @@ or if it is a PATHNAME but some of its components are not recognized." ((or null string) pathname) (pathname (with-output-to-string (s) - (flet ((err () (error "Not a valid unix-namestring ~S" pathname))) + (flet ((err () #+lispworks (describe pathname) (error "Not a valid unix-namestring ~S" pathname))) (let* ((dir (normalize-pathname-directory-component (pathname-directory pathname))) (name (pathname-name pathname)) + (name (and (not (eq name :unspecific)) name)) (type (pathname-type pathname)) (type (and (not (eq type :unspecific)) type))) (cond - ((eq dir ())) + ((member dir '(nil :unspecific))) ((eq dir '(:relative)) (princ "./" s)) ((consp dir) (destructuring-bind (relabs &rest dirs) dir @@ -2487,7 +2479,7 @@ or if it is a PATHNAME but some of its components are not recognized." (t (err))) (cond (name - (or (and (stringp name) (or (null type) (stringp type))) (err)) + (unless (and (stringp name) (or (null type) (stringp type))) (err)) (format s "~A~(a)[.~A~]" name type)) (t (or (null type) (err))))))))))) @@ -2526,6 +2518,25 @@ then it is merged with the PATHNAME-DIRECTORY-PATHNAME of PATHNAME." ;; scheme-specific parts: port username password, not others: . #.(or #+scl '(:parameters nil :query nil :fragment nil)))) + (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) + "Given a pathname designator PATH, return an absolute pathname as specified by PATH +considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior, +with a format control-string and other arguments as arguments" + (cond + ((absolute-pathname-p path)) + ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error)) + ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) + ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults)))) + (or (if (absolute-pathname-p default-pathname) + (absolute-pathname-p (merge-pathnames* path default-pathname)) + (call-function on-error "Default pathname ~S is not an absolute pathname" + default-pathname)) + (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" + path default-pathname)))) + (t (call-function on-error + "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" + path defaults)))) + (defun subpathp (maybe-subpath base-pathname) "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." @@ -2540,11 +2551,9 @@ when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPA (defun enough-pathname (maybe-subpath base-pathname) "if MAYBE-SUBPATH is a pathname that is under BASE-PATHNAME, return a pathname object that when used with MERGE-PATHNAMES* with defaults BASE-PATHNAME, returns MAYBE-SUBPATH." - (check-type maybe-subpath (or null pathname)) - (check-type base-pathname (or null pathname)) - (when (pathnamep base-pathname) (assert (absolute-pathname-p base-pathname))) - (or (and base-pathname (subpathp maybe-subpath base-pathname)) - maybe-subpath)) + (let ((sub (when maybe-subpath (pathname maybe-subpath))) + (base (when base-pathname (ensure-absolute-pathname (pathname base-pathname))))) + (or (and base (subpathp sub base)) sub))) (defun call-with-enough-pathname (maybe-subpath defaults-pathname thunk) "In a context where *DEFAULT-PATHNAME-DEFAULTS* is bound to DEFAULTS-PATHNAME (if not null, @@ -2558,35 +2567,16 @@ given DEFAULTS-PATHNAME as a base pathname." (defaults *default-pathname-defaults*)) &body body) "Shorthand syntax for CALL-WITH-ENOUGH-PATHNAME" - `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body))) - - (defun ensure-absolute-pathname (path &optional defaults (on-error 'error)) - "Given a pathname designator PATH, return an absolute pathname as specified by PATH -considering the DEFAULTS, or, if not possible, use CALL-FUNCTION on the specified ON-ERROR behavior, -with a format control-string and other arguments as arguments" - (cond - ((absolute-pathname-p path)) - ((stringp path) (ensure-absolute-pathname (pathname path) defaults on-error)) - ((not (pathnamep path)) (call-function on-error "not a valid pathname designator ~S" path)) - ((let ((default-pathname (if (pathnamep defaults) defaults (call-function defaults)))) - (or (if (absolute-pathname-p default-pathname) - (absolute-pathname-p (merge-pathnames* path default-pathname)) - (call-function on-error "Default pathname ~S is not an absolute pathname" - default-pathname)) - (call-function on-error "Failed to merge ~S with ~S into an absolute pathname" - path default-pathname)))) - (t (call-function on-error - "Cannot ensure ~S is evaluated as an absolute pathname with defaults ~S" - path defaults))))) + `(call-with-enough-pathname ,pathname ,defaults #'(lambda (,pathname-var) ,@body)))) ;;; Wildcard pathnames (with-upgradability () (defparameter *wild* (or #+cormanlisp "*" :wild) "Wild component for use with MAKE-PATHNAME") - (defparameter *wild-directory-component* (or #+gcl2.6 "*" :wild) + (defparameter *wild-directory-component* (or :wild) "Wild directory component for use with MAKE-PATHNAME") - (defparameter *wild-inferiors-component* (or #+gcl2.6 "**" :wild-inferiors) + (defparameter *wild-inferiors-component* (or :wild-inferiors) "Wild-inferiors directory component for use with MAKE-PATHNAME") (defparameter *wild-file* (make-pathname :directory nil :name *wild* :type *wild* @@ -2811,32 +2801,27 @@ or the original (parsed) pathname if it is false (the default)." (or #+allegro (probe-file p :follow-symlinks truename) - #-(or allegro clisp gcl2.6) + #+gcl (if truename - (probe-file p) - (ignore-errors - (let ((pp (physicalize-pathname p))) - (and - #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) - #+(and lispworks unix) (system:get-file-stat pp) - #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) - #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp) - p)))) - #+(or clisp gcl2.6) + (truename* p) + (let ((kind (car (si::stat p)))) + (when (eq kind :link) + (setf kind (ignore-errors (car (si::stat (truename* p)))))) + (ecase kind + ((nil) nil) + ((:file :link) + (cond + ((file-pathname-p p) p) + ((directory-pathname-p p) + (subpathname p (car (last (pathname-directory p))))))) + (:directory (ensure-directory-pathname p))))) + #+clisp #.(flet ((probe (probe) `(let ((foundtrue ,probe)) (cond (truename foundtrue) (foundtrue p))))) - #+gcl2.6 - (probe '(or (probe-file p) - (and (directory-pathname-p p) - (ignore-errors - (ensure-directory-pathname - (truename* (subpathname - (ensure-directory-pathname p) "."))))))) - #+clisp - (let* ((fs (find-symbol* '#:file-stat :posix nil)) + (let* ((fs (or #-os-windows (find-symbol* '#:file-stat :posix nil))) (pp (find-symbol* '#:probe-pathname :ext nil)) (resolve (if pp `(ignore-errors (,pp p)) @@ -2846,11 +2831,29 @@ or the original (parsed) pathname if it is false (the default)." `(if truename ,resolve (and (ignore-errors (,fs p)) p)) - (probe resolve))))) + (probe resolve)))) + #-(or allegro clisp gcl) + (if truename + (probe-file p) + (ignore-errors + (let ((pp (physicalize-pathname p))) + (and + #+(or cmu scl) (unix:unix-stat (ext:unix-namestring pp)) + #+(and lispworks unix) (system:get-file-stat pp) + #+sbcl (sb-unix:unix-stat (sb-ext:native-namestring pp)) + #-(or cmu (and lispworks unix) sbcl scl) (file-write-date pp) + p))))) (file-error () nil))))))) (defun directory-exists-p (x) "Is X the name of a directory that exists on the filesystem?" + #+allegro + (excl:probe-directory x) + #+clisp + (handler-case (ext:probe-directory x) + (sys::simple-file-error () + nil)) + #-(or allegro clisp) (let ((p (probe-file* x :truename t))) (and (directory-pathname-p p) p))) @@ -2875,26 +2878,33 @@ Try to override the defaults to not resolving symlinks, if implementation allows "Given ENTRIES in a DIRECTORY, remove if the directory is logical the entries which are physical yet when transformed by MERGER have a different TRUENAME. This function is used as a helper to DIRECTORY-FILES to avoid invalid entries when using logical-pathnames." - (if (logical-pathname-p directory) - ;; Try hard to not resolve logical-pathname into physical pathnames; - ;; otherwise logical-pathname users/lovers will be disappointed. - ;; If directory* could use some implementation-dependent magic, - ;; we will have logical pathnames already; otherwise, - ;; we only keep pathnames for which specifying the name and - ;; translating the LPN commute. - (loop :for f :in entries - :for p = (or (and (logical-pathname-p f) f) - (let* ((u (ignore-errors (call-function merger f)))) - ;; The first u avoids a cumbersome (truename u) error. - ;; At this point f should already be a truename, - ;; but isn't quite in CLISP, for it doesn't have :version :newest - (and u (equal (truename* u) (truename* f)) u))) - :when p :collect p) - entries)) + (remove-duplicates ;; on CLISP, querying ~/ will return duplicates + (if (logical-pathname-p directory) + ;; Try hard to not resolve logical-pathname into physical pathnames; + ;; otherwise logical-pathname users/lovers will be disappointed. + ;; If directory* could use some implementation-dependent magic, + ;; we will have logical pathnames already; otherwise, + ;; we only keep pathnames for which specifying the name and + ;; translating the LPN commute. + (loop :for f :in entries + :for p = (or (and (logical-pathname-p f) f) + (let* ((u (ignore-errors (call-function merger f)))) + ;; The first u avoids a cumbersome (truename u) error. + ;; At this point f should already be a truename, + ;; but isn't quite in CLISP, for it doesn't have :version :newest + (and u (equal (truename* u) (truename* f)) u))) + :when p :collect p) + entries) + :test 'pathname-equal)) + (defun directory-files (directory &optional (pattern *wild-file*)) - "Return a list of the files in a directory according to the PATTERN, -which is not very portable to override. Try not resolve symlinks if implementation allows." + "Return a list of the files in a directory according to the PATTERN. +Subdirectories should NOT be returned. + PATTERN defaults to a pattern carefully chosen based on the implementation; +override the default at your own risk. + DIRECTORY-FILES tries NOT to resolve symlinks if the implementation +permits this." (let ((dir (pathname directory))) (when (logical-pathname-p dir) ;; Because of the filtering we do below, @@ -2907,16 +2917,17 @@ which is not very portable to override. Try not resolve symlinks if implementati (setf pattern (make-pathname-logical pattern (pathname-host dir)))) (let* ((pat (merge-pathnames* pattern dir)) (entries (append (ignore-errors (directory* pat)) - #+clisp + #+(or clisp gcl) (when (equal :wild (pathname-type pattern)) (ignore-errors (directory* (make-pathname :type nil :defaults pat))))))) - (filter-logical-directory-results - directory entries - #'(lambda (f) - (make-pathname :defaults dir - :name (make-pathname-component-logical (pathname-name f)) - :type (make-pathname-component-logical (pathname-type f)) - :version (make-pathname-component-logical (pathname-version f)))))))) + (remove-if 'directory-pathname-p + (filter-logical-directory-results + directory entries + #'(lambda (f) + (make-pathname :defaults dir + :name (make-pathname-component-logical (pathname-name f)) + :type (make-pathname-component-logical (pathname-type f)) + :version (make-pathname-component-logical (pathname-version f))))))))) (defun subdirectories (directory) "Given a DIRECTORY pathname designator, return a list of the subdirectories under it." @@ -2984,13 +2995,19 @@ and recurse each of its subdirectories on which the RECURSEP returns true when C (down-components ())) (assert (eq :absolute (first directory))) (loop :while up-components :do - (if-let (parent (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components)) - :name nil :type nil :version nil :defaults p))) - (return (merge-pathnames* (make-pathname* :directory `(:relative ,@down-components) - :defaults p) - (ensure-directory-pathname parent))) - (push (pop up-components) down-components)) - :finally (return p)))))) + (if-let (parent + (ignore-errors + (probe-file* (make-pathname* :directory `(:absolute ,@(reverse up-components)) + :name nil :type nil :version nil :defaults p)))) + (if-let (simplified + (ignore-errors + (merge-pathnames* + (make-pathname* :directory `(:relative ,@down-components) + :defaults p) + (ensure-directory-pathname parent)))) + (return simplified))) + (push (pop up-components) down-components) + :finally (return p)))))) (defun resolve-symlinks (path) "Do a best effort at resolving symlinks in PATH, returning a partially or totally resolved PATH." @@ -3016,7 +3033,7 @@ Defaults to T.") (defun ensure-pathname (pathname &key on-error - defaults type dot-dot + defaults type dot-dot namestring want-pathname want-logical want-physical ensure-physical want-relative want-absolute ensure-absolute ensure-subpath @@ -3030,10 +3047,17 @@ optionally doing some transformations and checking specified constraints. If the argument is NIL, then NIL is returned unless the WANT-PATHNAME constraint is specified. -If the argument is a STRING, it is first converted to a pathname via PARSE-UNIX-NAMESTRING -reusing the keywords DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE; -then the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true, -and the all the checks and transformations are run. +If the argument is a STRING, it is first converted to a pathname via +PARSE-UNIX-NAMESTRING, PARSE-NAMESTRING or PARSE-NATIVE-NAMESTRING respectively +depending on the NAMESTRING argument being :UNIX, :LISP or :NATIVE respectively, +or else by using CALL-FUNCTION on the NAMESTRING argument; +if :UNIX is specified (or NIL, the default, which specifies the same thing), +then PARSE-UNIX-NAMESTRING it is called with the keywords +DEFAULTS TYPE DOT-DOT ENSURE-DIRECTORY WANT-RELATIVE, and +the result is optionally merged into the DEFAULTS if ENSURE-ABSOLUTE is true. + +The pathname passed or resulting from parsing the string +is then subjected to all the checks and transformations below are run. Each non-nil constraint argument can be one of the symbols T, ERROR, CERROR or IGNORE. The boolean T is an alias for ERROR. @@ -3092,11 +3116,22 @@ TRUENAMIZE uses TRUENAMIZE to resolve as many symlinks as possible." (etypecase p ((or null pathname)) (string - (setf p (parse-unix-namestring - p :defaults defaults :type type :dot-dot dot-dot - :ensure-directory ensure-directory :want-relative want-relative)))) - (check want-pathname (pathnamep p) "Expected a pathname, not NIL") - (unless (pathnamep p) (return nil)) + (setf p (case namestring + ((:unix nil) + (parse-unix-namestring + p :defaults defaults :type type :dot-dot dot-dot + :ensure-directory ensure-directory :want-relative want-relative)) + ((:native) + (parse-native-namestring p)) + ((:lisp) + (parse-namestring p)) + (t + (call-function namestring p)))))) + (etypecase p + (pathname) + (null + (check want-pathname (pathnamep p) "Expected a pathname, not NIL") + (return nil))) (check want-logical (logical-pathname-p p) "Expected a logical pathname") (check want-physical (physical-pathname-p p) "Expected a physical pathname") (transform ensure-physical () (physicalize-pathname p)) @@ -3241,7 +3276,7 @@ in an atomic way if the implementation allows." (symbol-call :posix :copy-file source target :method :rename)) #-clisp (rename-file source target - #+clozure :if-exists #+clozure :rename-and-delete)) + #+(or clozure ecl) :if-exists #+clozure :rename-and-delete #+ecl t)) (defun delete-file-if-exists (x) "Delete a file X if it already exists" @@ -3268,7 +3303,7 @@ in an atomic way if the implementation allows." `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) - #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl lispworks mkcl sbcl scl xcl) (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) @@ -3491,15 +3526,38 @@ It must never be modified, though only good implementations will even enforce th (with-safe-io-syntax (:package package) (read-from-string string eof-error-p eof-value :start start :end end :preserve-whitespace preserve-whitespace)))) -;;; Output to a stream or string, FORMAT-style +;;; Output helpers (with-upgradability () - (defun call-with-output (output function) + (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." + (with-open-file (s pathname :direction :output + :element-type element-type + :external-format 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)) + + (defun call-with-output (output function &key keys) "Calls FUNCTION with an actual stream argument, behaving like FORMAT with respect to how stream designators are interpreted: -If OUTPUT is a stream, use it as the stream. +If OUTPUT is a STREAM, use it as the stream. If OUTPUT is NIL, use a STRING-OUTPUT-STREAM as the stream, and return the resulting string. If OUTPUT is T, use *STANDARD-OUTPUT* as the stream. -If OUTPUT is a string with a fill-pointer, use it as a string-output-stream. +If OUTPUT is a STRING with a fill-pointer, use it as a string-output-stream. +If OUTPUT is a PATHNAME, open the file and write to it, passing KEYS to WITH-OUTPUT-FILE +-- this latter as an extension since ASDF 3.1. Otherwise, signal an error." (etypecase output (null @@ -3510,7 +3568,9 @@ Otherwise, signal an error." (funcall function output)) (string (assert (fill-pointer output)) - (with-output-to-string (stream output) (funcall function stream))))) + (with-output-to-string (stream output) (funcall function stream))) + (pathname + (apply 'call-with-output-file output function keys)))) (defmacro with-output ((output-var &optional (value output-var)) &body body) "Bind OUTPUT-VAR to an output stream, coercing VALUE (default: previous binding of OUTPUT-VAR) @@ -3526,25 +3586,6 @@ as per FORMAT, and evaluate BODY within the scope of this binding." ;;; Input helpers (with-upgradability () - (defun call-with-input (input function) - "Calls FUNCTION with an actual stream argument, interpreting -stream designators like READ, but also coercing strings to STRING-INPUT-STREAM. -If INPUT is a STREAM, use it as the stream. -If INPUT is NIL, use a *STANDARD-INPUT* as the stream. -If INPUT is T, use *TERMINAL-IO* as the stream. -As an extension, if INPUT is a string, use it as a string-input-stream. -Otherwise, signal an error." - (etypecase input - (null (funcall function *standard-input*)) - ((eql t) (funcall function *terminal-io*)) - (stream (funcall function input)) - (string (with-input-from-string (stream input) (funcall function stream))))) - - (defmacro with-input ((input-var &optional (value input-var)) &body body) - "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR) -as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding." - `(call-with-input ,value #'(lambda (,input-var) ,@body))) - (defun call-with-input-file (pathname thunk &key (element-type *default-stream-element-type*) @@ -3552,10 +3593,9 @@ as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding." (if-does-not-exist :error)) "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 :input :element-type element-type - #-gcl2.6 :external-format #-gcl2.6 external-format + :external-format external-format :if-does-not-exist if-does-not-exist) (funcall thunk s))) @@ -3565,27 +3605,29 @@ Other keys are accepted but discarded." (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))) + (defun call-with-input (input function &key keys) + "Calls FUNCTION with an actual stream argument, interpreting +stream designators like READ, but also coercing strings to STRING-INPUT-STREAM, +and PATHNAME to FILE-STREAM. +If INPUT is a STREAM, use it as the stream. +If INPUT is NIL, use a *STANDARD-INPUT* as the stream. +If INPUT is T, use *TERMINAL-IO* as the stream. +If INPUT is a STRING, use it as a string-input-stream. +If INPUT is a PATHNAME, open it, passing KEYS to WITH-INPUT-FILE +-- the latter is an extension since ASDF 3.1. +Otherwise, signal an error." + (etypecase input + (null (funcall function *standard-input*)) + ((eql t) (funcall function *terminal-io*)) + (stream (funcall function input)) + (string (with-input-from-string (stream input) (funcall function stream))) + (pathname (apply 'call-with-input-file input function keys)))) + + (defmacro with-input ((input-var &optional (value input-var)) &body body) + "Bind INPUT-VAR to an input stream, coercing VALUE (default: previous binding of INPUT-VAR) +as per CALL-WITH-INPUT, and evaluate BODY within the scope of this binding." + `(call-with-input ,value #'(lambda (,input-var) ,@body)))) - (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))) ;;; Null device (with-upgradability () @@ -3597,19 +3639,22 @@ and always returns EOF when read from" ((os-windows-p) #p"NUL") ;; Q: how many Lisps accept the #p"NUL:" syntax? (t (error "No /dev/null on your OS")))) (defun call-with-null-input (fun &rest keys &key element-type external-format if-does-not-exist) + "Call FUN with an input stream from the null device; pass keyword arguments to OPEN." (declare (ignore element-type external-format if-does-not-exist)) (apply 'call-with-input-file (null-device-pathname) fun keys)) (defmacro with-null-input ((var &rest keys &key element-type external-format if-does-not-exist) &body body) (declare (ignore element-type external-format if-does-not-exist)) - "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device." + "Evaluate BODY in a context when VAR is bound to an input stream accessing the null device. +Pass keyword arguments to OPEN." `(call-with-null-input #'(lambda (,var) ,@body) ,@keys)) (defun call-with-null-output (fun &key (element-type *default-stream-element-type*) (external-format *utf-8-external-format*) (if-exists :overwrite) (if-does-not-exist :error)) + "Call FUN with an output stream to the null device; pass keyword arguments to OPEN." (call-with-output-file (null-device-pathname) fun :element-type element-type :external-format external-format @@ -3617,7 +3662,8 @@ and always returns EOF when read from" (defmacro with-null-output ((var &rest keys &key element-type external-format if-does-not-exist if-exists) &body body) - "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device." + "Evaluate BODY in a context when VAR is bound to an output stream accessing the null device. +Pass keyword arguments to OPEN." (declare (ignore element-type external-format if-exists if-does-not-exist)) `(call-with-null-output #'(lambda (,var) ,@body) ,@keys))) @@ -3828,11 +3874,11 @@ If a string, repeatedly read and evaluate from it, returning the last values." (with-upgradability () (defun println (x &optional (stream *standard-output*)) "Variant of PRINC that also calls TERPRI afterwards" - (princ x stream) (terpri stream) (values)) + (princ x stream) (terpri stream) (finish-output stream) (values)) (defun writeln (x &rest keys &key (stream *standard-output*) &allow-other-keys) "Variant of WRITE that also calls TERPRI afterwards" - (apply 'write x keys) (terpri stream) (values))) + (apply 'write x keys) (terpri stream) (finish-output stream) (values))) ;;; Using temporary files @@ -3856,37 +3902,58 @@ If a string, repeatedly read and evaluate from it, returning the last values." (defun setup-temporary-directory () "Configure a default temporary directory to use." (setf *temporary-directory* (default-temporary-directory)) - ;; basic lack fixed after gcl 2.7.0-61, but ending / required still on 2.7.0-64.1 - #+(and gcl (not gcl2.6)) (setf system::*tmp-dir* *temporary-directory*)) + #+gcl (setf system::*tmp-dir* *temporary-directory*)) (defun call-with-temporary-file (thunk &key - (want-stream-p t) (want-pathname-p t) - prefix keep (direction :io) + (want-stream-p t) (want-pathname-p t) (direction :io) keep after + directory (type "tmp" typep) prefix (suffix (when typep "-tmp")) (element-type *default-stream-element-type*) (external-format *utf-8-external-format*)) - "Call a THUNK with STREAM and PATHNAME arguments identifying a temporary file. -The pathname will be based on appending a random suffix to PREFIX. -This utility will KEEP the file past its extent if and only if explicitly requested. -The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT." - #+gcl2.6 (declare (ignorable external-format)) + "Call a THUNK with stream and/or pathname arguments identifying a temporary file. + +The temporary file's pathname will be based on concatenating +PREFIX (defaults to \"uiop\"), a random alphanumeric string, +and optional SUFFIX (defaults to \"-tmp\" if a type was provided) +and TYPE (defaults to \"tmp\", using a dot as separator if not NIL), +within DIRECTORY (defaulting to the TEMPORARY-DIRECTORY) if the PREFIX isn't absolute. + +The file will be open with specified DIRECTION (defaults to :IO), +ELEMENT-TYPE (defaults to *DEFAULT-STREAM-ELEMENT-TYPE*) and +EXTERNAL-FORMAT (defaults to *UTF-8-EXTERNAL-FORMAT*). +If WANT-STREAM-P is true (the defaults to T), then THUNK will then be CALL-FUNCTION'ed +with the stream and the pathname (if WANT-PATHNAME-P is true, defaults to T), +and stream with be closed after the THUNK exits (either normally or abnormally). +If WANT-STREAM-P is false, then WANT-PATHAME-P must be true, and then +THUNK is only CALL-FUNCTION'ed after the stream is closed, with the pathname as argument. +Upon exit of THUNK, the AFTER thunk if defined is CALL-FUNCTION'ed with the pathname as argument. +If AFTER is defined, its results are returned, otherwise, the results of THUNK are returned. +Finally, the file will be deleted, unless the KEEP argument when CALL-FUNCTION'ed returns true." + #+xcl (declare (ignorable typep)) (check-type direction (member :output :io)) (assert (or want-stream-p want-pathname-p)) (loop - :with prefix = (namestring (ensure-absolute-pathname (or prefix "tmp") #'temporary-directory)) + :with prefix = (native-namestring + (ensure-absolute-pathname + (or prefix "tmp") + (or (ensure-pathname directory :namestring :native :ensure-directory t) + #'temporary-directory))) :with results = () - :for counter :from (random (ash 1 32)) - :for pathname = (pathname (format nil "~A~36R" prefix counter)) + :for counter :from (random (expt 36 #-gcl 8 #+gcl 5)) + :for pathname = (parse-native-namestring + (format nil "~A~36R~@[~A~]~@[.~A~]" prefix counter suffix type)) :for okp = nil :do ;; TODO: on Unix, do something about umask ;; TODO: on Unix, audit the code so we make sure it uses O_CREAT|O_EXCL - ;; TODO: on Unix, use CFFI and mkstemp -- but UIOP is precisely meant to not depend on CFFI or on anything! Grrrr. + ;; TODO: on Unix, use CFFI and mkstemp -- + ;; except UIOP is precisely meant to not depend on CFFI or on anything! Grrrr. + ;; Can we at least design some hook? (unwind-protect (progn (with-open-file (stream pathname :direction direction :element-type element-type - #-gcl2.6 :external-format #-gcl2.6 external-format + :external-format external-format :if-exists nil :if-does-not-exist :create) (when stream (setf okp pathname) @@ -3897,57 +3964,77 @@ The file will be open with specified DIRECTION, ELEMENT-TYPE and EXTERNAL-FORMAT (funcall thunk stream pathname) (funcall thunk stream))))))) (when okp - (if want-stream-p - (return (apply 'values results)) - (return (funcall thunk pathname))))) - (when (and okp (not keep)) + (unless want-stream-p + (setf results (multiple-value-list (call-function thunk pathname)))) + (when after + (setf results (multiple-value-list (call-function after pathname)))) + (return (apply 'values results)))) + (when (and okp (not (call-function keep))) (ignore-errors (delete-file-if-exists okp)))))) (defmacro with-temporary-file ((&key (stream (gensym "STREAM") streamp) (pathname (gensym "PATHNAME") pathnamep) - prefix keep direction element-type external-format) + directory prefix suffix type + keep direction element-type external-format) &body body) "Evaluate BODY where the symbols specified by keyword arguments STREAM and PATHNAME (if respectively specified) are bound corresponding to a newly created temporary file ready for I/O, as per CALL-WITH-TEMPORARY-FILE. -The STREAM will be closed if no binding is specified. -Unless KEEP is specified, delete the file afterwards." +At least one of STREAM or PATHNAME must be specified. +If the STREAM is not specified, it will be closed before the BODY is evaluated. +If STREAM is specified, then the :CLOSE-STREAM label if it appears in the BODY, +separates forms run before and after the stream is closed. +The values of the last form of the BODY (not counting the separating :CLOSE-STREAM) are returned. +Upon success, the KEEP form is evaluated and the file is is deleted unless it evaluates to TRUE." (check-type stream symbol) (check-type pathname symbol) (assert (or streamp pathnamep)) - `(flet ((think (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) - ,@body)) - #-gcl (declare (dynamic-extent #'think)) - (call-with-temporary-file - #'think - :want-stream-p ,streamp - :want-pathname-p ,pathnamep - ,@(when direction `(:direction ,direction)) - ,@(when prefix `(:prefix ,prefix)) - ,@(when keep `(:keep ,keep)) - ,@(when element-type `(:element-type ,element-type)) - ,@(when external-format `(:external-format ,external-format))))) - - (defun get-temporary-file (&key prefix) - (with-temporary-file (:pathname pn :keep t :prefix prefix) + (let* ((afterp (position :close-stream body)) + (before (if afterp (subseq body 0 afterp) body)) + (after (when afterp (subseq body (1+ afterp)))) + (beforef (gensym "BEFORE")) + (afterf (gensym "AFTER"))) + `(flet (,@(when before + `((,beforef (,@(when streamp `(,stream)) ,@(when pathnamep `(,pathname))) ,@before))) + ,@(when after + (assert pathnamep) + `((,afterf (,pathname) ,@after)))) + #-gcl (declare (dynamic-extent ,@(when before `(#',beforef)) ,@(when after `(#',afterf)))) + (call-with-temporary-file + ,(when before `#',beforef) + :want-stream-p ,streamp + :want-pathname-p ,pathnamep + ,@(when direction `(:direction ,direction)) + ,@(when directory `(:directory ,directory)) + ,@(when prefix `(:prefix ,prefix)) + ,@(when suffix `(:suffix ,suffix)) + ,@(when type `(:type ,type)) + ,@(when keep `(:keep ,keep)) + ,@(when after `(:after #',afterf)) + ,@(when element-type `(:element-type ,element-type)) + ,@(when external-format `(:external-format ,external-format)))))) + + (defun get-temporary-file (&key directory prefix suffix type) + (with-temporary-file (:pathname pn :keep t + :directory directory :prefix prefix :suffix suffix :type type) pn)) ;; Temporary pathnames in simple cases where no contention is assumed - (defun add-pathname-suffix (pathname suffix) - "Add a SUFFIX to the name of a PATHNAME, return a new pathname" - (make-pathname :name (strcat (pathname-name pathname) suffix) - :defaults pathname)) + (defun add-pathname-suffix (pathname suffix &rest keys) + "Add a SUFFIX to the name of a PATHNAME, return a new pathname. +Further KEYS can be passed to MAKE-PATHNAME." + (apply 'make-pathname :name (strcat (pathname-name pathname) suffix) + :defaults pathname keys)) (defun tmpize-pathname (x) "Return a new pathname modified from X by adding a trivial deterministic suffix" - (add-pathname-suffix x "-ASDF-TMP")) + (add-pathname-suffix x "-TMP")) (defun call-with-staging-pathname (pathname fun) - "Calls fun with a staging pathname, and atomically -renames the staging pathname to the pathname in the end. -Note: this protects only against failure of the program, -not against concurrent attempts. -For the latter case, we ought pick random suffix and atomically open it." + "Calls FUN with a staging pathname, and atomically +renames the staging pathname to the PATHNAME in the end. +NB: this protects only against failure of the program, not against concurrent attempts. +For the latter case, we ought pick a random suffix and atomically open it." (let* ((pathname (pathname pathname)) (staging (tmpize-pathname pathname))) (unwind-protect @@ -3957,6 +4044,7 @@ For the latter case, we ought pick random suffix and atomically open it." (delete-file-if-exists staging)))) (defmacro with-staging-pathname ((pathname-var &optional (pathname-value pathname-var)) &body body) + "Trivial syntax wrapper for CALL-WITH-STAGING-PATHNAME" `(call-with-staging-pathname ,pathname-value #'(lambda (,pathname-var) ,@body)))) ;;;; ------------------------------------------------------------------------- @@ -3968,7 +4056,7 @@ For the latter case, we ought pick random suffix and atomically open it." (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) (:export #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* - #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments + #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0 #:*lisp-interaction* #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition #:call-with-fatal-condition-handler #:with-fatal-condition-handler @@ -4031,7 +4119,7 @@ This is designed to abstract away the implementation specific quit forms." #+cormanlisp (win32:exitprocess code) #+(or cmu scl) (unix:unix-exit code) #+ecl (si:quit code) - #+gcl (lisp:quit code) + #+gcl (system:quit code) #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) #+mcl (progn code (ccl:quit)) ;; or should we use FFI to call libc's exit(3) ? @@ -4051,11 +4139,13 @@ This is designed to abstract away the implementation specific quit forms." (format! *stderr* "~&~?~&" format arguments))) (quit code)) - (defun raw-print-backtrace (&key (stream *debug-io*) count) + (defun raw-print-backtrace (&key (stream *debug-io*) count condition) "Print a backtrace, directly accessing the implementation" - (declare (ignorable stream count)) + (declare (ignorable stream count condition)) #+abcl - (let ((*debug-io* stream)) (top-level::backtrace-command count)) + (loop :for i :from 0 + :for frame :in (sys:backtrace (or count most-positive-fixnum)) :do + (safe-format! stream "~&~D: ~A~%" i frame)) #+allegro (let ((*terminal-io* stream) (*standard-output* stream) @@ -4064,7 +4154,7 @@ This is designed to abstract away the implementation specific quit forms." (tpl:*zoom-print-length* *print-length*)) (tpl:do-command "zoom" :from-read-eval-print-loop nil - :count t + :count (or count t) :all t)) #+clisp (system::print-backtrace :out stream :limit count) @@ -4076,9 +4166,23 @@ This is designed to abstract away the implementation specific quit forms." #+(or cmu scl) (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) - (debug:backtrace most-positive-fixnum stream)) - #+ecl - (si::tpl-backtrace) + (debug:backtrace (or count most-positive-fixnum) stream)) + #+(or ecl mkcl) + (let* ((top (si:ihs-top)) + (repeats (if count (min top count) top)) + (backtrace (loop :for ihs :from 0 :below top + :collect (list (si::ihs-fun ihs) + (si::ihs-env ihs))))) + (loop :for i :from 0 :below repeats + :for frame :in (nreverse backtrace) :do + (safe-format! stream "~&~D: ~S~%" i frame))) + #+gcl + (let ((*debug-io* stream)) + (ignore-errors + (with-safe-io-syntax () + (if condition + (conditions::condition-backtrace condition) + (system::simple-backtrace))))) #+lispworks (let ((dbg::*debugger-stack* (dbg::grab-stack nil :how-many (or count most-positive-fixnum))) @@ -4089,11 +4193,15 @@ This is designed to abstract away the implementation specific quit forms." #+sbcl (sb-debug:backtrace #.(if (find-symbol* "*VERBOSITY*" "SB-DEBUG" nil) :stream '(or count most-positive-fixnum)) - stream)) + stream) + #+xcl + (loop :for i :from 0 :below (or count most-positive-fixnum) + :for frame :in (extensions:backtrace-as-list) :do + (safe-format! stream "~&~D: ~S~%" i frame))) - (defun print-backtrace (&rest keys &key stream count) + (defun print-backtrace (&rest keys &key stream count condition) "Print a backtrace" - (declare (ignore stream count)) + (declare (ignore stream count condition)) (with-safe-io-syntax (:package :cl) (let ((*print-readably* nil) (*print-circle* t) @@ -4108,7 +4216,7 @@ This is designed to abstract away the implementation specific quit forms." ;; We print the condition *after* the backtrace, ;; for the sake of who sees the backtrace at a terminal. ;; It is up to the caller to print the condition *before*, with some context. - (print-backtrace :stream stream :count count) + (print-backtrace :stream stream :count count :condition condition) (when condition (safe-format! stream "~&Above backtrace due to this condition:~%~A~&" condition))) @@ -4174,49 +4282,96 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die" #+gcl si:*command-args* #+(or genera mcl) nil #+lispworks sys:*line-arguments-list* + #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i)) #+sbcl sb-ext:*posix-argv* #+xcl system:*argv* - #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "raw-command-line-arguments not implemented yet")) (defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) "Extract user arguments from command-line invocation of current process. Assume the calling conventions of a generated script that uses -- if we are not called from a directly executable image." - #+abcl arguments - #-abcl - (let* (#-(or sbcl allegro) - (arguments - (if (eq *image-dumped-p* :executable) - arguments - (member "--" arguments :test 'string-equal)))) + (block nil + #+abcl (return arguments) + ;; SBCL and Allegro already separate user arguments from implementation arguments. + #-(or sbcl allegro) + (unless (eq *image-dumped-p* :executable) + ;; LispWorks command-line processing isn't transparent to the user + ;; unless you create a standalone executable; in that case, + ;; we rely on cl-launch or some other script to set the arguments for us. + #+lispworks (return *command-line-arguments*) + ;; On other implementations, on non-standalone executables, + ;; we trust cl-launch or whichever script starts the program + ;; to use -- as a delimiter between implementation arguments and user arguments. + #-lispworks (setf arguments (member "--" arguments :test 'string-equal))) (rest arguments))) + (defun argv0 () + "On supported implementations (most that matter), or when invoked by a proper wrapper script, +return a string that for the name with which the program was invoked, i.e. argv[0] in C. +Otherwise, return NIL." + (cond + ((eq *image-dumped-p* :executable) ; yes, this ARGV0 is our argv0 ! + ;; NB: not currently available on ABCL, Corman, Genera, MCL + (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl) + (first (raw-command-line-arguments)) + #+ecl (si:argv 0) #+mkcl (mkcl:argv 0))) + (t ;; argv[0] is the name of the interpreter. + ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8. + (getenvp "__CL_ARGV0")))) + (defun setup-command-line-arguments () (setf *command-line-arguments* (command-line-arguments))) (defun restore-image (&key - ((: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*) + (lisp-interaction *lisp-interaction*) + (restore-hook *image-restore-hook*) + (prelude *image-prelude*) + (entry-point *image-entry-point*) (if-already-restored '(cerror "RUN RESTORE-IMAGE ANYWAY"))) "From a freshly restarted Lisp image, restore the saved Lisp environment -by setting appropriate variables, running various hooks, and calling any specified entry point." +by setting appropriate variables, running various hooks, and calling any specified entry point. + +If the image has already been restored or is already being restored, as per *IMAGE-RESTORED-P*, +call the IF-ALREADY-RESTORED error handler (by default, a continuable error), and do return +immediately to the surrounding restore process if allowed to continue. + +Then, comes the restore process itself: +First, call each function in the RESTORE-HOOK, +in the order they were registered with REGISTER-RESTORE-HOOK. +Second, evaluate the prelude, which is often Lisp text that is read, +as per EVAL-INPUT. +Third, call the ENTRY-POINT function, if any is specified, with no argument. + +The restore process happens in a WITH-FATAL-CONDITION-HANDLER, so that if LISP-INTERACTION is NIL, +any unhandled error leads to a backtrace and an exit with an error status. +If LISP-INTERACTION is NIL, the process also exits when no error occurs: +if neither restart nor entry function is provided, the program will exit with status 0 (success); +if a function was provided, the program will exit after the function returns (if it returns), +with status 0 if and only if the primary return value of result is generalized boolean true, +and with status 1 if this value is NIL. + +If LISP-INTERACTION is true, unhandled errors will take you to the debugger, and the result +of the function will be returned rather than interpreted as a boolean designating an exit code." (when *image-restored-p* (if if-already-restored - (call-function if-already-restored "Image already ~:[being ~;~]restored" (eq *image-restored-p* t)) + (call-function if-already-restored "Image already ~:[being ~;~]restored" + (eq *image-restored-p* t)) (return-from restore-image))) (with-fatal-condition-handler () + (setf *lisp-interaction* lisp-interaction) + (setf *image-restore-hook* restore-hook) + (setf *image-prelude* prelude) (setf *image-restored-p* :in-progress) (call-image-restore-hook) - (standard-eval-thunk *image-prelude*) + (standard-eval-thunk prelude) (setf *image-restored-p* t) (let ((results (multiple-value-list - (if *image-entry-point* - (call-function *image-entry-point*) + (if entry-point + (call-function entry-point) t)))) - (if *lisp-interaction* + (if lisp-interaction (apply 'values results) (shell-boolean-exit (first results))))))) @@ -4225,14 +4380,28 @@ by setting appropriate variables, running various hooks, and calling any specifi (with-upgradability () (defun dump-image (filename &key output-name executable - ((:postlude *image-postlude*) *image-postlude*) - ((:dump-hook *image-dump-hook*) *image-dump-hook*) - #+clozure prepend-symbols #+clozure (purify t)) - "Dump an image of the current Lisp environment at pathname FILENAME, with various options" + (postlude *image-postlude*) + (dump-hook *image-dump-hook*) + #+clozure prepend-symbols #+clozure (purify t) + #+sbcl compression + #+(and sbcl windows) application-type) + "Dump an image of the current Lisp environment at pathname FILENAME, with various options. + +First, finalize the image, by evaluating the POSTLUDE as per EVAL-INPUT, then calling each of + the functions in DUMP-HOOK, in reverse order of registration by REGISTER-DUMP-HOOK. + +If EXECUTABLE is true, create an standalone executable program that calls RESTORE-IMAGE on startup. + +Pass various implementation-defined options, such as PREPEND-SYMBOLS and PURITY on CCL, +or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." + ;; Note: at least SBCL saves only global values of variables in the heap image, + ;; so make sure things you want to dump are NOT just local bindings shadowing the global values. (declare (ignorable filename output-name executable)) (setf *image-dumped-p* (if executable :executable t)) (setf *image-restored-p* :in-regress) + (setf *image-postlude* postlude) (standard-eval-thunk *image-postlude*) + (setf *image-dump-hook* dump-hook) (call-image-dump-hook) (setf *image-restored-p* nil) #-(or clisp clozure cmu lispworks sbcl scl) @@ -4268,8 +4437,9 @@ by setting appropriate variables, running various hooks, and calling any specifi (ext:gc :full t) (setf ext:*batch-mode* nil) (setf ext::*gc-run-time* 0) - (apply 'ext:save-lisp filename #+cmu :executable #+cmu t - (when executable '(:init-function restore-image :process-command-line nil)))) + (apply 'ext:save-lisp filename + #+cmu :executable #+cmu t + (when executable '(:init-function restore-image :process-command-line nil)))) #+gcl (progn (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) @@ -4284,39 +4454,64 @@ by setting appropriate variables, running various hooks, and calling any specifi (setf sb-ext::*gc-run-time* 0) (apply 'sb-ext:save-lisp-and-die filename :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 + (append + (when compression (list :compression compression)) + ;;--- only save runtime-options for standalone executables + (when executable (list :toplevel #'restore-image :save-runtime-options t)) + #+(and sbcl windows) ;; passing :application-type :gui will disable the console window. + ;; the default is :console - only works with SBCL 1.1.15 or later. + (when application-type (list :application-type application-type))))) #-(or allegro clisp clozure cmu gcl lispworks sbcl scl) (error "Can't ~S ~S: UIOP doesn't support image dumping with ~A.~%" 'dump-image filename (nth-value 1 (implementation-type)))) - (defun create-image (destination object-files - &key kind output-name prologue-code epilogue-code + (defun create-image (destination lisp-object-files + &key kind output-name prologue-code epilogue-code extra-object-files (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)) + (entry-point () entry-point-p) build-args no-uiop) + (declare (ignorable destination lisp-object-files extra-object-files kind output-name + prologue-code epilogue-code prelude preludep postlude postludep + entry-point entry-point-p build-args no-uiop)) "On ECL, create an executable at pathname DESTINATION from the specified OBJECT-FILES and options" ;; 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. - #-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)))) + #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image) + #+(or ecl mkcl) + (let ((epilogue-code + (if no-uiop + epilogue-code + (let ((forms + (append + (when epilogue-code `(,epilogue-code)) + (when postludep `((setf *image-postlude* ',postlude))) + (when preludep `((setf *image-prelude* ',prelude))) + (when entry-point-p `((setf *image-entry-point* ',entry-point))) + (case kind + ((:image) + (setf kind :program) ;; to ECL, it's just another program. + `((setf *image-dumped-p* t) + (si::top-level #+ecl t) (quit))) + ((:program) + `((setf *image-dumped-p* :executable) + (shell-boolean-exit + (restore-image)))))))) + (when forms `(progn ,@forms)))))) + #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl)) + (apply #+ecl 'c::builder #+ecl kind + #+mkcl (ecase kind + ((:dll) 'compiler::build-shared-library) + ((:lib :static-library) 'compiler::build-static-library) + ((:fasl) 'compiler::build-bundle) + ((:program) 'compiler::build-program)) + (pathname destination) + #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files) + #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind) + (append + (when prologue-code `(:prologue-code ,prologue-code)) + (when epilogue-code `(:epilogue-code ,epilogue-code)) + #+mkcl (when extra-object-files `(:object-files ,extra-object-files)) + build-args))))) ;;; Some universal image restore hooks @@ -4331,7 +4526,8 @@ by setting appropriate variables, running various hooks, and calling any specifi (uiop/package:define-package :uiop/run-program (:nicknames :asdf/run-program) (:recycle :uiop/run-program :asdf/run-program :xcvb-driver) - (:use :uiop/common-lisp :uiop/utility :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream) + (:use :uiop/common-lisp :uiop/package :uiop/utility + :uiop/pathname :uiop/os :uiop/filesystem :uiop/stream) (:export ;;; Escaping the command invocation madness #:easy-sh-character-p #:escape-sh-token #:escape-sh-command @@ -4497,14 +4693,14 @@ Built-in methods include the following: Programmers are encouraged to define their own methods for this generic function.")) - #-(or gcl2.6 genera) + #-genera (defmethod slurp-input-stream ((function function) input-stream &key) (funcall function input-stream)) (defmethod slurp-input-stream ((list cons) input-stream &key) (apply (first list) input-stream (rest list))) - #-(or gcl2.6 genera) + #-genera (defmethod slurp-input-stream ((output-stream stream) input-stream &key linewise prefix (element-type 'character) buffer-size) (copy-stream-to-stream @@ -4512,35 +4708,27 @@ Programmers are encouraged to define their own methods for this generic function :linewise linewise :prefix prefix :element-type element-type :buffer-size buffer-size)) (defmethod slurp-input-stream ((x (eql 'string)) stream &key stripped) - (declare (ignorable x)) (slurp-stream-string stream :stripped stripped)) (defmethod slurp-input-stream ((x (eql :string)) stream &key stripped) - (declare (ignorable x)) (slurp-stream-string stream :stripped stripped)) (defmethod slurp-input-stream ((x (eql :lines)) stream &key count) - (declare (ignorable x)) (slurp-stream-lines stream :count count)) (defmethod slurp-input-stream ((x (eql :line)) stream &key (at 0)) - (declare (ignorable x)) (slurp-stream-line stream :at at)) (defmethod slurp-input-stream ((x (eql :forms)) stream &key count) - (declare (ignorable x)) (slurp-stream-forms stream :count count)) (defmethod slurp-input-stream ((x (eql :form)) stream &key (at 0)) - (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 ((x null) stream &key) - (declare (ignorable x stream)) + (defmethod slurp-input-stream ((x null) (stream t) &key) nil) (defmethod slurp-input-stream ((pathname pathname) input @@ -4564,9 +4752,9 @@ Programmers are encouraged to define their own methods for this generic function &key linewise prefix (element-type 'character) buffer-size) (declare (ignorable stream linewise prefix element-type buffer-size)) (cond - #+(or gcl2.6 genera) + #+genera ((functionp x) (funcall x stream)) - #+(or gcl2.6 genera) + #+genera ((output-stream-p x) (copy-stream-to-stream stream x @@ -4594,14 +4782,14 @@ Built-in methods include the following: Programmers are encouraged to define their own methods for this generic function.")) - #-(or gcl2.6 genera) + #-genera (defmethod vomit-output-stream ((function function) output-stream &key) (funcall function output-stream)) (defmethod vomit-output-stream ((list cons) output-stream &key) (apply (first list) output-stream (rest list))) - #-(or gcl2.6 genera) + #-genera (defmethod vomit-output-stream ((input-stream stream) output-stream &key linewise prefix (element-type 'character) buffer-size) (copy-stream-to-stream @@ -4615,11 +4803,9 @@ Programmers are encouraged to define their own methods for this generic function (values)) (defmethod vomit-output-stream ((x (eql t)) stream &rest keys &key &allow-other-keys) - (declare (ignorable x)) (apply 'vomit-output-stream *standard-input* stream keys)) - (defmethod vomit-output-stream ((x null) stream &key) - (declare (ignorable x stream)) + (defmethod vomit-output-stream ((x null) (stream t) &key) (values)) (defmethod vomit-output-stream ((pathname pathname) input @@ -4643,9 +4829,9 @@ Programmers are encouraged to define their own methods for this generic function &key linewise prefix (element-type 'character) buffer-size) (declare (ignorable stream linewise prefix element-type buffer-size)) (cond - #+(or gcl2.6 genera) + #+genera ((functionp x) (funcall x stream)) - #+(or gcl2.6 genera) + #+genera ((input-stream-p x) (copy-stream-to-stream x stream @@ -4677,6 +4863,7 @@ for the implementation's underlying run-program function" #+os-unix (list command) #+os-windows (string + #+mkcl (list "cmd" '#:/c command) ;; NB: We do NOT add cmd /c here. You might want to. #+(or allegro clisp) command ;; On ClozureCL for Windows, we assume you are using @@ -4686,7 +4873,7 @@ for the implementation's underlying run-program function" ;; NB: On other Windows implementations, this is utterly bogus ;; except in the most trivial cases where no quoting is needed. ;; Use at your own risk. - #-(or allegro clisp clozure) (list "cmd" "/c" command)) + #-(or allegro clisp clozure mkcl) (list "cmd" "/c" command)) #+os-windows (list #+allegro (escape-windows-command command) @@ -4706,15 +4893,15 @@ argument to pass to the internal RUN-PROGRAM" (declare (ignorable role)) (etypecase specifier (null (or #+(or allegro lispworks) (null-device-pathname))) - (string (pathname specifier)) + (string (parse-native-namestring specifier)) (pathname specifier) (stream specifier) ((eql :stream) :stream) ((eql :interactive) #+allegro nil #+clisp :terminal - #+(or clozure cmu ecl sbcl scl) t) - #+(or allegro clozure cmu ecl lispworks sbcl scl) + #+(or clozure cmu ecl mkcl sbcl scl) t) + #+(or allegro clozure cmu ecl lispworks mkcl sbcl scl) ((eql :output) (if (eq role :error-output) :output @@ -4745,12 +4932,12 @@ to be normalized by %NORMALIZE-IO-SPECIFIER. It returns a process-info plist with possible keys: PROCESS, EXIT-CODE, INPUT-STREAM, OUTPUT-STREAM, BIDIR-STREAM, ERROR-STREAM." ;; NB: these implementations have unix vs windows set at compile-time. - (declare (ignorable if-input-does-not-exist if-output-exists if-error-output-exists)) + (declare (ignorable directory if-input-does-not-exist if-output-exists if-error-output-exists)) (assert (not (and wait (member :stream (list input output error-output))))) - #-(or allegro clozure cmu (and lispworks os-unix) sbcl scl) + #-(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl) (progn command keys directory (error "run-program not available")) - #+(or allegro clisp clozure cmu (and lispworks os-unix) sbcl scl) + #+(or allegro clisp clozure cmu (and lispworks os-unix) mkcl sbcl scl) (let* ((%command (%normalize-command command)) (%input (%normalize-io-specifier input :input)) (%output (%normalize-io-specifier output :output)) @@ -4770,23 +4957,23 @@ It returns a process-info plist with possible keys: #+os-windows :show-window #+os-windows (if interactive nil :hide) :allow-other-keys t keys)) #-allegro - (with-current-directory (#-sbcl directory) + (with-current-directory (#-(or sbcl mkcl) directory) #+clisp - (flet ((run (f &rest args) + (flet ((run (f x &rest args) (multiple-value-list - (apply f :input %input :output %output - :allow-other-keys t `(,@args ,@keys))))) + (apply f x :input %input :output %output + :allow-other-keys t `(,@args ,@keys))))) (assert (eq %error-output :terminal)) ;;; since we now always return a code, we can't use this code path, anyway! (etypecase %command #+os-windows (string (run 'ext:run-shell-command %command)) (list (run 'ext:run-program (car %command) :arguments (cdr %command))))) - #+(or clozure cmu ecl sbcl scl) - (#-ecl progn #+ecl multiple-value-list + #+(or clozure cmu ecl mkcl sbcl scl) + (#-(or ecl mkcl) progn #+(or ecl mkcl) multiple-value-list (apply '#+(or cmu ecl scl) ext:run-program - #+clozure ccl:run-program #+sbcl sb-ext:run-program + #+clozure ccl:run-program #+sbcl sb-ext:run-program #+mkcl mk-ext:run-program (car %command) (cdr %command) :input %input :output %output @@ -4794,7 +4981,7 @@ It returns a process-info plist with possible keys: :wait wait :allow-other-keys t (append - #+(or clozure cmu sbcl scl) + #+(or clozure cmu mkcl sbcl scl) `(:if-input-does-not-exist ,if-input-does-not-exist :if-output-exists ,if-output-exists :if-error-exists ,if-error-output-exists) @@ -4861,8 +5048,8 @@ It returns a process-info plist with possible keys: #+clozure (ccl:external-process-error-stream process*) #+(or cmu scl) (ext:process-error process*) #+sbcl (sb-ext:process-error process*)))) - #+ecl - (destructuring-bind (stream code process) process* + #+(or ecl mkcl) + (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process* (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) (cond ((zerop mode)) @@ -4882,6 +5069,17 @@ It returns a process-info plist with possible keys: (when (eq error-output :stream) (prop :error-stream err)))))) (nreverse process-info-r)))) + (defun %process-info-pid (process-info) + (let ((process (getf process-info :process))) + (declare (ignorable process)) + #+(or allegro lispworks) process + #+clozure (ccl::external-process-pid process) + #+ecl (si:external-process-pid process) + #+(or cmu scl) (ext:process-pid process) + #+mkcl (mkcl:process-id process) + #+sbcl (sb-ext:process-pid process) + #-(or allegro cmu mkcl sbcl scl) (error "~S not implemented" '%process-info-pid))) + (defun %wait-process-result (process-info) (or (getf process-info :exit-code) (let ((process (getf process-info :process))) @@ -4896,8 +5094,16 @@ It returns a process-info plist with possible keys: #+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 (system:pid-exit-status process :wait t) - #+sbcl (sb-ext:process-exit-code process))))) + #+lispworks + (if-let ((stream (or (getf process-info :input-stream) + (getf process-info :output-stream) + (getf process-info :bidir-stream) + (getf process-info :error-stream)))) + (system:pipe-exit-status stream :wait t) + (if-let ((f (find-symbol* :pid-exit-status :system nil))) + (funcall f process :wait t))) + #+sbcl (sb-ext:process-exit-code process) + #+mkcl (mkcl:join-process process))))) (defun %check-result (exit-code &key command process ignore-error-status) (unless ignore-error-status @@ -4997,8 +5203,10 @@ It returns a process-info plist with possible keys: (defun %use-run-program (command &rest keys &key input output error-output ignore-error-status &allow-other-keys) ;; helper for RUN-PROGRAM when using %run-program - #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) - (error "Not implemented on this platform") + #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) + (progn + command keys input output error-output ignore-error-status ;; ignore + (error "Not implemented on this platform")) (assert (not (member :stream (list input output error-output)))) (let* ((active-input-p (%active-io-specifier-p input)) (active-output-p (%active-io-specifier-p output)) @@ -5060,13 +5268,13 @@ It returns a process-info plist with possible keys: (let ((pathname (typecase spec (null (null-device-pathname)) - (string (pathname spec)) + (string (parse-native-namestring spec)) (pathname spec) ((eql :output) - (assert (equal operator "2>")) + (assert (equal operator " 2>")) (return-from redirect '(" 2>&1")))))) (when pathname - (list " " operator " " + (list operator " " (escape-shell-token (native-namestring pathname))))))) (multiple-value-bind (before after) (let ((normalized (%normalize-system-command command))) @@ -5075,8 +5283,9 @@ It returns a process-info plist with possible keys: (values (list normalized) ()))) (reduce/strcat (append - before (redirect in "<") (redirect out ">") (redirect err "2>") - (when (and directory (os-unix-p)) `("cd " (escape-shell-token directory) " ; ")) + before (redirect in " <") (redirect out " >") (redirect err " 2>") + (when (and directory (os-unix-p)) ;; NB: unless on Unix, %system uses with-current-directory + `(" ; cd " ,(escape-shell-token (native-namestring directory)))) after))))) (defun %system (command &rest keys @@ -5086,26 +5295,26 @@ It returns a process-info plist with possible keys: #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl) (%wait-process-result (apply '%run-program (%normalize-system-command command) :wait t keys)) - #+(or abcl clisp cormanlisp ecl gcl (and lispworks os-windows) mkcl xcl) + #+(or abcl cormanlisp clisp ecl gcl (and lispworks os-windows) mkcl xcl) (let ((%command (%redirected-system-command command input output error-output directory))) #+(and lispworks os-windows) (system:call-system %command :current-directory directory :wait t) - #-(and lispworks os-windows) + #+clisp + (%wait-process-result + (apply '%run-program %command :wait t + :input :interactive :output :interactive :error-output :interactive keys)) + #-(or clisp (and lispworks os-windows)) (with-current-directory ((unless (os-unix-p) directory)) - #+(or abcl xcl) (ext:run-shell-command %command) - #+clisp (clisp-exit-code (ext:shell %command)) + #+abcl (ext:run-shell-command %command) #+cormanlisp (win32:system %command) #+ecl (let ((*standard-input* *stdin*) (*standard-output* *stdout*) (*error-output* *stderr*)) (ext:system %command)) - #+gcl (lisp:system %command) + #+gcl (system:system %command) #+mcl (ccl::with-cstrs ((%%command %command)) (_system %%command)) - #+mkcl ;; PROBABLY BOGUS -- ask jcb - (multiple-value-bind (io process exit-code) - (mkcl:run-program #+windows %command #+windows () - #-windows "/bin/sh" #-windows (list "-c" %command) - :input t :output t))))) + #+mkcl (mkcl:system %command) + #+xcl (system:%run-shell-command %command)))) (defun %use-system (command &rest keys &key input output error-output ignore-error-status &allow-other-keys) @@ -5144,30 +5353,38 @@ unless IGNORE-ERROR-STATUS is specified. If OUTPUT is a pathname, a string designating a pathname, or NIL designating the null device, the file at that path is used as output. -If it's :INTERACTIVE, output is inherited from the current process. +If it's :INTERACTIVE, output is inherited from the current process; +beware that this may be different from your *STANDARD-OUTPUT*, +and under SLIME will be on your *inferior-lisp* buffer. +If it's T, output goes to your current *STANDARD-OUTPUT* stream. Otherwise, OUTPUT should be a value that is a suitable first argument to SLURP-INPUT-STREAM (qv.), or a list of such a value and keyword arguments. -In this case, RUN-PROGRAM will create a temporary stream for the program output. -The program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM, +In this case, RUN-PROGRAM will create a temporary stream for the program output; +the program output, in that stream, will be processed by a call to SLURP-INPUT-STREAM, using OUTPUT as the first argument (or the first element of OUTPUT, and the rest as keywords). -T designates the *STANDARD-OUTPUT* to be provided to SLURP-INPUT-STREAM. The primary value resulting from that call (or NIL if no call was needed) will be the first value returned by RUN-PROGRAM. E.g., using :OUTPUT :STRING will have it return the entire output stream as a string. +And using :OUTPUT '(:STRING :STRIPPED T) will have it return the same string +stripped of any ending newline. ERROR-OUTPUT is similar to OUTPUT, except that the resulting value is returned as the second value of RUN-PROGRAM. T designates the *ERROR-OUTPUT*. -Also :OUTPUT means redirecting the error output to the output stream, and NIL is returned. +Also :OUTPUT means redirecting the error output to the output stream, +in which case NIL is returned. INPUT is similar to OUTPUT, except that VOMIT-OUTPUT-STREAM is used, no value is returned, and T designates the *STANDARD-INPUT*. -Use ELEMENT-TYPE and EXTERNAL-FORMAT to specify how streams are created. +Use ELEMENT-TYPE and EXTERNAL-FORMAT are passed on +to your Lisp implementation, when applicable, for creation of the output stream. One and only one of the stream slurping or vomiting may or may not happen -in parallel in parallel with the subprocess, depending on options and implementation. -Other streams are completely produced or consumed before or after the subprocess is spawned, -using temporary files. +in parallel in parallel with the subprocess, +depending on options and implementation, +and with priority being given to output processing. +Other streams are completely produced or consumed +before or after the subprocess is spawned, using temporary files. RUN-PROGRAM returns 3 values: 0- the result of the OUTPUT slurping if any, or NIL @@ -5175,7 +5392,7 @@ RUN-PROGRAM returns 3 values: 2- either 0 if the subprocess exited with success status, or an indication of failure via the EXIT-CODE of the process" (declare (ignorable ignore-error-status)) - #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl) (error "RUN-PROGRAM not implemented for this Lisp") (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive)))) (apply (if (or force-shell @@ -5183,7 +5400,7 @@ or an indication of failure via the EXIT-CODE of the process" #+clisp (eq error-output :interactive) #+(or abcl clisp) (eq :error-output :output) #+(and lispworks os-unix) (%interactivep input output error-output) - #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl mkcl xcl) t) + #+(or abcl cormanlisp gcl (and lispworks os-windows) mcl xcl) t) '%use-system '%use-run-program) command :input (default input inputp output) @@ -5210,11 +5427,12 @@ or an indication of failure via the EXIT-CODE of the 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-conditions* #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* + #:*uninteresting-conditions* #:*usual-uninteresting-conditions* + #:*uninteresting-compiler-conditions* #:*uninteresting-loader-conditions* ;; Types #+sbcl #:sb-grovel-unknown-constant-condition ;; Functions & Macros - #:get-optimization-settings #:proclaim-optimization-settings + #:get-optimization-settings #:proclaim-optimization-settings #:with-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 @@ -5224,7 +5442,7 @@ or an indication of failure via the EXIT-CODE of the process" #:enable-deferred-warnings-check #:disable-deferred-warnings-check #:current-lisp-file-pathname #:load-pathname #:lispize-pathname #:compile-file-type #:call-around-hook - #:compile-file* #:compile-file-pathname* + #:compile-file* #:compile-file-pathname* #:*compile-check* #:load* #:load-from-string #:combine-fasls) (:intern #:defaults #:failure-p #:warnings-p #:s #:y #:body)) (in-package :uiop/lisp-build) @@ -5254,19 +5472,37 @@ This can help you produce more deterministic output for FASLs.")) "Optimization settings to be used by PROCLAIM-OPTIMIZATION-SETTINGS") (defvar *previous-optimization-settings* nil "Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS") + (defparameter +optimization-variables+ + ;; TODO: allegro genera corman mcl + (or #+(or abcl xcl) '(system::*speed* system::*space* system::*safety* system::*debug*) + #+clisp '() ;; system::*optimize* is a constant hash-table! (with non-constant contents) + #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* + ccl::*nx-debug* ccl::*nx-cspeed*) + #+(or cmu scl) '(c::*default-cookie*) + #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*)) + #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*) + #+lispworks '(compiler::*optimization-level*) + #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*) + #+sbcl '(sb-c::*policy*))) (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) + #-(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) + (warn "~S does not support ~S. Please help me fix that." + 'get-optimization-settings (implementation-type)) + #+(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) - #.`(loop :for x :in settings - ,@(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 ecl) (symbol-value v) - #+(or cmu scl) (funcall f c::*default-cookie*) + #.`(loop #+(or allegro clozure) + ,@'(:with info = #+allegro (sys:declaration-information 'optimize) + #+clozure (ccl:declaration-information 'optimize nil)) + :for x :in settings + ,@(or #+(or abcl ecl gcl mkcl xcl) '(:for v :in +optimization-variables+)) + :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order + #+clisp (gethash x system::*optimize* 1) + #+(or abcl ecl mkcl xcl) (symbol-value v) + #+(or cmu scl) (slot-value c::*default-cookie* + (case x (compilation-speed 'c::cspeed) + (otherwise x))) + #+lispworks (slot-value compiler::*optimization-level* x) #+sbcl (cdr (assoc x sb-c::*policy*))) :when y :collect (list x y)))) (defun proclaim-optimization-settings () @@ -5274,7 +5510,18 @@ This can help you produce more deterministic output for FASLs.")) (proclaim `(optimize ,@*optimization-settings*)) (let ((settings (get-optimization-settings))) (unless (equal *previous-optimization-settings* settings) - (setf *previous-optimization-settings* settings))))) + (setf *previous-optimization-settings* settings)))) + (defmacro with-optimization-settings ((&optional (settings *optimization-settings*)) &body body) + #+(or allegro clisp) + (let ((previous-settings (gensym "PREVIOUS-SETTINGS"))) + `(let ((,previous-settings (get-optimization-settings))) + ,@(when settings `((proclaim `(optimize ,@,settings)))) + (unwind-protect (progn ,@body) + (proclaim `(optimize ,@,previous-settings))))) + #-(or allegro clisp) + `(let ,(loop :for v :in +optimization-variables+ :collect `(,v ,v)) + ,@(when settings `((proclaim `(optimize ,@,settings)))) + ,@body))) ;;; Condition control @@ -5696,7 +5943,7 @@ If that given type is NIL, use the currently configured *WARNINGS-FILE-TYPE* ins (equal (pathname-type file) type))) (defun check-deferred-warnings (files &optional context-format context-arguments) - "Given a list of FILES in which deferred warnings were saved by CALL-WITH-DEFERRED-WARNINGS, + "Given a list of FILES containing deferred warnings saved by CALL-WITH-SAVED-DEFERRED-WARNINGS, re-intern and raise any warnings that are still meaningful." (let ((file-errors nil) (failure-p nil) @@ -5737,12 +5984,13 @@ re-intern and raise any warnings that are still meaningful." (macroexpand-1 '(with-compilation-unit () foo)) |# - (defun call-with-saved-deferred-warnings (thunk warnings-file) + (defun call-with-saved-deferred-warnings (thunk warnings-file &key source-namestring) "If WARNINGS-FILE is not nil, record the deferred-warnings around a call to THUNK and save those warnings to the given file for latter use, possibly in a different process. Otherwise just call THUNK." + (declare (ignorable source-namestring)) (if warnings-file - (with-compilation-unit (:override t) + (with-compilation-unit (:override t #+sbcl :source-namestring #+sbcl source-namestring) (unwind-protect (let (#+sbcl (sb-c::*undefined-warnings* nil)) (multiple-value-prog1 @@ -5751,9 +5999,10 @@ possibly in a different process. Otherwise just call THUNK." (reset-deferred-warnings))) (funcall thunk))) - (defmacro with-saved-deferred-warnings ((warnings-file) &body body) + (defmacro with-saved-deferred-warnings ((warnings-file &key source-namestring) &body body) "Trivial syntax for CALL-WITH-SAVED-DEFERRED-WARNINGS" - `(call-with-saved-deferred-warnings #'(lambda () ,@body) ,warnings-file))) + `(call-with-saved-deferred-warnings + #'(lambda () ,@body) ,warnings-file :source-namestring ,source-namestring))) ;;; from ASDF @@ -5764,7 +6013,7 @@ possibly in a different process. Otherwise just call THUNK." (defun load-pathname () "Portably return the LOAD-PATHNAME of the current source file or fasl" - *load-pathname*) ;; see magic for GCL in uiop/common-lisp + *load-pathname*) ;; magic no longer needed for GCL. (defun lispize-pathname (input-file) "From a INPUT-FILE pathname, return a corresponding .lisp source pathname" @@ -5783,7 +6032,7 @@ possibly in a different process. Otherwise just call THUNK." (defun compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) "Variant of COMPILE-FILE-PATHNAME that works well with COMPILE-FILE*" (let* ((keys - (remove-plist-keys `(#+(and allegro (not (version>= 8 2))) :external-format + (remove-plist-keys `(#+(or (and allegro (not (version>= 8 2)))) :external-format ,@(unless output-file '(:output-file))) keys))) (if (absolute-pathname-p output-file) ;; what cfp should be doing, w/ mp* instead of mp @@ -5794,8 +6043,11 @@ possibly in a different process. Otherwise just call THUNK." (funcall *output-translation-function* (apply 'compile-file-pathname input-file keys))))) + (defvar *compile-check* nil + "A hook for user-defined compile-time invariants") + (defun* (compile-file*) (input-file &rest keys - &key compile-check output-file warnings-file + &key (compile-check *compile-check*) output-file warnings-file #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl &allow-other-keys) "This function provides a portable wrapper around COMPILE-FILE. @@ -5822,8 +6074,7 @@ it will filter them appropriately." (rotatef output-file object-file)) (let* ((keywords (remove-plist-keys `(:output-file :compile-check :warnings-file - #+clisp :lib-file #+(or ecl mkcl) :object-file - #+gcl2.6 ,@'(:external-format :print :verbose)) keys)) + #+clisp :lib-file #+(or ecl mkcl) :object-file) keys)) (output-file (or output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))) @@ -5848,9 +6099,9 @@ it will filter them appropriately." #+clisp (tmp-lib (make-pathname :type "lib" :defaults tmp-file))) (multiple-value-bind (output-truename warnings-p failure-p) - (with-saved-deferred-warnings (warnings-file) - (with-muffled-compiler-conditions () - (with-enough-pathname (input-file :defaults *base-build-directory*) + (with-enough-pathname (input-file :defaults *base-build-directory*) + (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file)) + (with-muffled-compiler-conditions () (or #-(or ecl mkcl) (apply 'compile-file input-file :output-file tmp-file #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) @@ -5892,20 +6143,20 @@ it will filter them appropriately." (defun load* (x &rest keys &key &allow-other-keys) "Portable wrapper around LOAD that properly handles loading from a stream." - (etypecase x - ((or pathname string #-(or allegro clozure gcl2.6 genera) stream) - (apply 'load x - #-gcl2.6 keys #+gcl2.6 (remove-plist-key :external-format keys))) - ;; GCL 2.6, Genera can't load from a string-input-stream - ;; ClozureCL 1.6 can only load from file input stream - ;; Allegro 5, I don't remember but it must have been broken when I tested. - #+(or allegro clozure gcl2.6 genera) - (stream ;; make do this way - (let ((*package* *package*) - (*readtable* *readtable*) - (*load-pathname* nil) - (*load-truename* nil)) - (eval-input x))))) + (with-muffled-loader-conditions () + (etypecase x + ((or pathname string #-(or allegro clozure genera) stream #+clozure file-stream) + (apply 'load x keys)) + ;; Genera can't load from a string-input-stream + ;; ClozureCL 1.6 can only load from file input stream + ;; Allegro 5, I don't remember but it must have been broken when I tested. + #+(or allegro clozure genera) + (stream ;; make do this way + (let ((*package* *package*) + (*readtable* *readtable*) + (*load-pathname* nil) + (*load-truename* nil)) + (eval-input x)))))) (defun load-from-string (string) "Portably read and evaluate forms from a STRING." @@ -6071,8 +6322,12 @@ this function tries to locate the Windows FOLDER for one of :finally (unless (= inherit 1) (report-invalid-form invalid-form-reporter - :arguments (list (compatfmt "~@<One and only one of ~S or ~S is required.~@:>") - :inherit-configuration :ignore-inherited-configuration))) + :form form :location location + ;; we throw away the form and location arguments, hence the ~2* + ;; this is necessary because of the report in INVALID-CONFIGURATION + :format (compatfmt "~@<Invalid source registry ~S~@[ in ~S~]. ~ + One and only one of ~S or ~S is required.~@:>") + :arguments '(:inherit-configuration :ignore-inherited-configuration))) (return (nreverse x)))) (defun validate-configuration-file (file validator &key description) @@ -6302,34 +6557,33 @@ directive.") (uiop/package:define-package :uiop/driver (:nicknames :uiop :asdf/driver :asdf-driver :asdf-utils) - (:use :uiop/common-lisp :uiop/package :uiop/utility - :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image - :uiop/run-program :uiop/lisp-build - :uiop/configuration :uiop/backward-driver) - (:reexport - ;; NB: excluding uiop/common-lisp + (:use :uiop/common-lisp) + ;; NB: not reexporting uiop/common-lisp ;; which include all of CL with compatibility modifications on select platforms, ;; that could cause potential conflicts for packages that would :use (cl uiop) ;; or :use (closer-common-lisp uiop), etc. + (:use-reexport :uiop/package :uiop/utility :uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image :uiop/run-program :uiop/lisp-build :uiop/configuration :uiop/backward-driver)) + +#+mkcl (provide :uiop) ;;;; ------------------------------------------------------------------------- ;;;; Handle upgrade as forward- and backward-compatibly as possible ;; See https://bugs.launchpad.net/asdf/+bug/485687 -(asdf/package:define-package :asdf/upgrade +(uiop/package:define-package :asdf/upgrade (:recycle :asdf/upgrade :asdf) (:use :uiop/common-lisp :uiop) (:export #:asdf-version #:*previous-asdf-versions* #:*asdf-version* #:asdf-message #:*verbose-out* - #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error + #:upgrading-p #:when-upgrading #:upgrade-asdf #:asdf-upgrade-error #:defparameter* #:*post-upgrade-cleanup-hook* #:*post-upgrade-restart-hook* #:cleanup-upgraded-asdf ;; There will be no symbol left behind! #:intern*) - (:import-from :asdf/package #:intern* #:find-symbol*)) + (:import-from :uiop/package #:intern* #:find-symbol*)) (in-package :asdf/upgrade) ;;; Special magic to detect if this is an upgrade @@ -6346,16 +6600,31 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO (string rev) (cons (format nil "~{~D~^.~}" rev)) (null "1.0")))))) + ;; Important: define *p-a-v* /before/ *a-v* so that it initializes correctly. + (defvar *previous-asdf-versions* (if-let (previous (asdf-version)) (list previous))) (defvar *asdf-version* nil) - (defvar *previous-asdf-versions* nil) + ;; We need to clear systems from versions yet older than the below: + (defparameter *oldest-forward-compatible-asdf-version* "2.33") ;; 2.32.13 renames a slot in component. (defvar *verbose-out* nil) (defun asdf-message (format-string &rest format-args) (when *verbose-out* (apply 'format *verbose-out* format-string format-args))) (defvar *post-upgrade-cleanup-hook* ()) (defvar *post-upgrade-restart-hook* ()) - (defun upgrading-p () - (and *previous-asdf-versions* (not (equal *asdf-version* (first *previous-asdf-versions*))))) - (defmacro when-upgrading ((&key (upgrading-p '(upgrading-p)) when) &body body) + (defun upgrading-p (&optional (oldest-compatible-version *oldest-forward-compatible-asdf-version*)) + (and *previous-asdf-versions* + (version< (first *previous-asdf-versions*) oldest-compatible-version))) + (defmacro defparameter* (var value &optional docstring (version *oldest-forward-compatible-asdf-version*)) + (let* ((name (string-trim "*" var)) + (valfun (intern (format nil "%~A-~A-~A" :compute name :value)))) + `(progn + (defun ,valfun () ,value) + (defvar ,var (,valfun) ,@(ensure-list docstring)) + (when (upgrading-p ,version) + (setf ,var (,valfun)))))) + (defmacro when-upgrading ((&key (version *oldest-forward-compatible-asdf-version*) + (upgrading-p `(upgrading-p ,version)) when) &body body) + "A wrapper macro for code that should only be run when upgrading a +previously-loaded version of ASDF." `(with-upgradability () (when (and ,upgrading-p ,@(when when `(,when))) (handler-bind ((style-warning #'muffle-warning)) @@ -6363,13 +6632,13 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO (let* (;; For bug reporting sanity, please always bump this version when you modify this file. ;; Please also modify asdf.asd to reflect this change. make bump-version v=3.4.5.67.8 ;; can help you do these changes in synch (look at the source for documentation). - ;; Relying on its automation, the version is now redundantly present on top of this file. + ;; Relying on its automation, the version is now redundantly present on top of asdf.lisp. ;; "3.4" would be the general branch for major version 3, minor version 4. ;; "3.4.5" would be an official release in the 3.4 branch. - ;; "3.4.5.67" would be a development version in the official upstream of 3.4.5. + ;; "3.4.5.67" would be a development version in the official branch, on top 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 "3.0.3") + (asdf-version "3.1.2") (existing-version (asdf-version))) (setf *asdf-version* asdf-version) (when (and existing-version (not (equal asdf-version existing-version))) @@ -6381,47 +6650,39 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO (when-upgrading () (let ((redefined-functions ;; gf signature and/or semantics changed incompatibly. Oops. + ;; NB: it's too late to do anything about functions in UIOP! + ;; If you introduce some critically incompatibility there, you must change name. '(#:component-relative-pathname #:component-parent-pathname ;; component #:source-file-type #: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 #:operation-done-p #:component-depends-on - #:traverse ;; backward-interface - #:operate ;; operate - #:parse-component-form ;; defsystem - #:apply-output-translations ;; output-translations - #:process-output-translations-directive - #:inherit-source-registry #:process-source-registry ;; source-registry - #:process-source-registry-directive - #:trivial-system-p ;; bundle - ;; NB: it's too late to do anything about uiop functions! - )) - (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 redefined-functions) + #:find-component ;; find-component + #:explain #:perform #:perform-with-restarts #:input-files #:output-files ;; action + #:component-depends-on #:operation-done-p #:component-depends-on + #:traverse ;; backward-interface + #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies ;; plan + #:operate ;; operate + #:parse-component-form ;; defsystem + #:apply-output-translations ;; output-translations + #:process-output-translations-directive + #:inherit-source-registry #:process-source-registry ;; source-registry + #:process-source-registry-directive + #:trivial-system-p)) ;; bundle + (redefined-classes + ;; redefining the classes causes interim circularities + ;; with the old ASDF during upgrade, and many implementations bork + '((#:compile-concatenated-source-op (#:operation) ())))) + (loop :for name :in redefined-functions :for sym = (find-symbol* name :asdf nil) :do (when 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 uninterned-symbols - :for sym = (find-symbol* name :asdf nil) - :for base-pkg = (and sym (symbol-package sym)) :do - (when sym - (cond - ((or (eq base-pkg asdf) (not base-pkg)) - (unintern* sym asdf) - (intern* sym asdf)) - (t - (unintern* sym base-pkg) - (let ((new (intern* sym base-pkg))) - (shadowing-import new asdf)))))))) + (labels ((asym (x) (multiple-value-bind (s p) (if (consp x) (values (car x) (cadr x)) (values x :asdf)) + (find-symbol* s p nil))) + (asyms (l) (mapcar #'asym l))) + (loop* :for (name superclasses slots) :in redefined-classes + :for sym = (find-symbol* name :asdf nil) + :when (and sym (find-class sym)) + :do (eval `(defclass ,sym ,(asyms superclasses) ,(asyms slots))))))) ;;; Self-upgrade functions @@ -6443,7 +6704,12 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO old-version new-version) (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") old-version new-version)) - (call-functions (reverse *post-upgrade-cleanup-hook*)) + ;; In case the previous version was too old to be forward-compatible, clear systems. + ;; TODO: if needed, we may have to define a separate hook to run + ;; in case of forward-compatible upgrade. + ;; Or to move the tests forward-compatibility test inside each hook function? + (unless (version<= *oldest-forward-compatible-asdf-version* old-version) + (call-functions (reverse *post-upgrade-cleanup-hook*))) t)))) (defun upgrade-asdf () @@ -6459,7 +6725,7 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ;;;; ------------------------------------------------------------------------- ;;;; Components -(asdf/package:define-package :asdf/component +(uiop/package:define-package :asdf/component (:recycle :asdf/component :asdf/defsystem :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export @@ -6492,9 +6758,9 @@ You can compare this string with e.g.: (ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSIO ;; Internals we'd like to share with the ASDF package, especially for upgrade purposes #:name #:version #:description #:long-description #:author #:maintainer #:licence - #:components-by-name #:components - #:children #:children-by-name #:default-component-class - #:author #:maintainer #:licence #:source-file #:defsystem-depends-on + #:components-by-name #:components #:children #:children-by-name + #:default-component-class #:source-file + #:defsystem-depends-on ; This symbol retained for backward compatibility. #:sideway-dependencies #:if-feature #:in-order-to #:inline-methods #:relative-pathname #:absolute-pathname #:operation-times #:around-compile #:%encoding #:properties #:component-properties #:parent)) @@ -6519,7 +6785,7 @@ another pathname in a degenerate way.")) (defgeneric component-version (component)) (defgeneric (setf component-version) (new-version component)) (defgeneric component-parent (component)) - (defmethod component-parent ((component null)) (declare (ignorable component)) nil) + (defmethod component-parent ((component null)) nil) ;; Backward compatible way of computing the FILE-TYPE of a component. ;; TODO: find users, have them stop using that, remove it for ASDF4. @@ -6541,11 +6807,6 @@ another pathname in a degenerate way.")) (duplicate-names-name c)))))) - -(when-upgrading (:when (find-class 'component nil)) - (defmethod reinitialize-instance :after ((c component) &rest initargs &key) - (declare (ignorable c initargs)) (values))) - (with-upgradability () (defclass component () ((name :accessor component-name :initarg :name :type string :documentation @@ -6600,6 +6861,8 @@ another pathname in a degenerate way.")) :initarg :build-operation :initform nil :reader component-build-operation))) (defun component-find-path (component) + "Return a path from a root system to the COMPONENT. +The return value is a list of component NAMES; a list of strings." (check-type component (or null component)) (reverse (loop :for c = component :then (component-parent c) @@ -6618,7 +6881,9 @@ another pathname in a degenerate way.")) ;;;; Component hierarchy within a system ;; The tree typically but not necessarily follows the filesystem hierarchy. (with-upgradability () - (defclass child-component (component) ()) + (defclass child-component (component) () + (:documentation "A CHILD-COMPONENT is a component that may be part of +a PARENT-COMPONENT.")) (defclass file-component (child-component) ((type :accessor file-type :initarg :type))) ; no default @@ -6647,7 +6912,9 @@ another pathname in a degenerate way.")) (default-component-class :initform nil :initarg :default-component-class - :accessor module-default-component-class)))) + :accessor module-default-component-class)) + (:documentation "A PARENT-COMPONENT is a component that may have +children."))) (with-upgradability () (defun compute-children-by-name (parent &key only-if-needed-p) @@ -6661,19 +6928,6 @@ another pathname in a degenerate way.")) (setf (gethash name hash) c)) hash)))) -(when-upgrading (:when (find-class 'module nil)) - (defmethod reinitialize-instance :after ((m module) &rest initargs &key) - (declare (ignorable m initargs)) (values)) - (defmethod update-instance-for-redefined-class :after - ((m module) added deleted plist &key) - (declare (ignorable m added deleted plist)) - (when (and (member 'children added) (member 'components deleted)) - (setf (slot-value m 'children) - ;; old ECLs provide an alist instead of a plist(!) - (if (or #+ecl (consp (first plist))) (or #+ecl (cdr (assoc 'components plist))) - (getf plist 'components))) - (compute-children-by-name m)))) - (with-upgradability () (defclass module (child-component parent-component) (#+clisp (components)))) ;; backward compatibility during upgrade only @@ -6699,9 +6953,10 @@ another pathname in a degenerate way.")) pathname))) (defmethod component-relative-pathname ((component component)) - ;; source-file-type is backward-compatibility with ASDF1; - ;; we ought to be able to extract this from the component alone with COMPONENT-TYPE. - ;; TODO: track who uses it, and have them not use it anymore. + ;; SOURCE-FILE-TYPE below is strictly for backward-compatibility with ASDF1. + ;; We ought to be able to extract this from the component alone with COMPONENT-TYPE. + ;; TODO: track who uses it, and have them not use it anymore; + ;; maybe issue a WARNING (then eventually CERROR) if the two methods diverge? (parse-unix-namestring (or (and (slot-boundp component 'relative-pathname) (slot-value component 'relative-pathname)) @@ -6710,12 +6965,10 @@ another pathname in a degenerate way.")) :type (source-file-type component (component-system component)) :defaults (component-parent-pathname component))) - (defmethod source-file-type ((component parent-component) system) - (declare (ignorable component system)) + (defmethod source-file-type ((component parent-component) (system parent-component)) :directory) - (defmethod source-file-type ((component file-component) system) - (declare (ignorable system)) + (defmethod source-file-type ((component file-component) (system parent-component)) (file-type component))) @@ -6743,11 +6996,15 @@ another pathname in a degenerate way.")) ;;;; version-satisfies (with-upgradability () + ;; short-circuit testing of null version specifications. + ;; this is an all-pass, without warning + (defmethod version-satisfies :around ((c t) (version null)) + t) (defmethod version-satisfies ((c component) version) - (unless (and version (slot-boundp c 'version)) + (unless (and version (slot-boundp c 'version) (component-version c)) (when version - (warn "Requested version ~S but component ~S has no version" version c)) - (return-from version-satisfies t)) + (warn "Requested version ~S but ~S has no version" version c)) + (return-from version-satisfies nil)) (version-satisfies (component-version c) version)) (defmethod version-satisfies ((cver string) version) @@ -6769,7 +7026,7 @@ another pathname in a degenerate way.")) ;;;; ------------------------------------------------------------------------- ;;;; Systems -(asdf/package:define-package :asdf/system +(uiop/package:define-package :asdf/system (:recycle :asdf :asdf/system) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component) (:export @@ -6778,7 +7035,7 @@ another pathname in a degenerate way.")) #:reset-system #:system-description #:system-long-description #:system-author #:system-maintainer #:system-licence #:system-license - #:system-defsystem-depends-on + #:system-defsystem-depends-on #:system-depends-on #:system-weakly-depends-on #:component-build-pathname #:build-pathname #:component-entry-point #:entry-point #:homepage #:system-homepage @@ -6791,13 +7048,12 @@ another pathname in a degenerate way.")) (with-upgradability () (defgeneric* (find-system) (system &optional error-p)) - (defgeneric* (system-source-file) (system) + (defgeneric* (system-source-file :supersede #-clisp t #+clisp nil) (system) (:documentation "Return the source file in which system is defined.")) (defgeneric component-build-pathname (component)) (defgeneric component-entry-point (component)) (defmethod component-entry-point ((c component)) - (declare (ignorable c)) nil)) @@ -6831,7 +7087,11 @@ another pathname in a degenerate way.")) (entry-point :initform nil :initarg :entry-point :accessor component-entry-point) (source-file :initform nil :initarg :source-file :accessor system-source-file) - (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) + (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on + :initform nil) + ;; these two are specially set in parse-component-form, so have no :INITARGs. + (depends-on :reader system-depends-on :initform nil) + (weakly-depends-on :reader system-weakly-depends-on :initform nil))) (defun reset-system (system &rest keys &key &allow-other-keys) (change-class (change-class system 'proto-system) 'system) @@ -6874,16 +7134,16 @@ in which the system specification (.asd file) is located." (system-source-directory system)) (defmethod component-build-pathname ((c component)) - (declare (ignorable c)) nil)) ;;;; ------------------------------------------------------------------------- ;;;; Stamp cache -(asdf/package:define-package :asdf/cache +(uiop/package:define-package :asdf/cache (:use :uiop/common-lisp :uiop :asdf/upgrade) (:export #:get-file-stamp #:compute-file-stamp #:register-file-stamp - #:consult-asdf-cache #:do-asdf-cache #:normalize-namestring + #:set-asdf-cache-entry #:unset-asdf-cache-entry #:consult-asdf-cache + #:do-asdf-cache #:normalize-namestring #:call-with-asdf-cache #:with-asdf-cache #:*asdf-cache*)) (in-package :asdf/cache) @@ -6901,6 +7161,10 @@ in which the system specification (.asd file) is located." (setf (gethash key *asdf-cache*) value-list) value-list))) + (defun unset-asdf-cache-entry (key) + (when *asdf-cache* + (remhash key *asdf-cache*))) + (defun consult-asdf-cache (key &optional thunk) (if *asdf-cache* (multiple-value-bind (results foundp) (gethash key *asdf-cache*) @@ -6912,14 +7176,15 @@ in which the system specification (.asd file) is located." (defmacro do-asdf-cache (key &body body) `(consult-asdf-cache ,key #'(lambda () ,@body))) - (defun call-with-asdf-cache (thunk &key override) - (if (and *asdf-cache* (not override)) - (funcall thunk) - (let ((*asdf-cache* (make-hash-table :test 'equal))) - (funcall thunk)))) + (defun call-with-asdf-cache (thunk &key override key) + (let ((fun (if key #'(lambda () (consult-asdf-cache key thunk)) thunk))) + (if (and *asdf-cache* (not override)) + (funcall fun) + (let ((*asdf-cache* (make-hash-table :test 'equal))) + (funcall fun))))) - (defmacro with-asdf-cache ((&key override) &body body) - `(call-with-asdf-cache #'(lambda () ,@body) :override ,override)) + (defmacro with-asdf-cache ((&key key override) &body body) + `(call-with-asdf-cache #'(lambda () ,@body) :override ,override :key ,key)) (defun normalize-namestring (pathname) (let ((resolved (resolve-symlinks* @@ -6938,30 +7203,32 @@ in which the system specification (.asd file) is located." (set-asdf-cache-entry `(get-file-stamp ,namestring) (list stamp)))) (defun get-file-stamp (file) - (let ((namestring (normalize-namestring file))) - (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring))))) + (when file + (let ((namestring (normalize-namestring file))) + (do-asdf-cache `(get-file-stamp ,namestring) (compute-file-stamp namestring)))))) ;;;; ------------------------------------------------------------------------- ;;;; Finding systems -(asdf/package:define-package :asdf/find-system +(uiop/package:define-package :asdf/find-system (:recycle :asdf/find-system :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/component :asdf/system :asdf/cache) + :asdf/cache :asdf/component :asdf/system) (:export #:remove-entry-from-registry #:coerce-entry-to-directory #:coerce-name #:primary-system-name #:coerce-filename - #:find-system #:locate-system #:load-asd #:with-system-definitions + #:find-system #:locate-system #:load-asd #:system-registered-p #:register-system #:registered-systems #:clear-system #:map-systems #:missing-component #:missing-requires #:missing-parent #:formatted-system-definition-error #:format-control #:format-arguments #:sysdef-error #:load-system-definition-error #:error-name #:error-pathname #:error-condition #:*system-definition-search-functions* #:search-for-system-definition #:*central-registry* #:probe-asd #:sysdef-central-registry-search - #:find-system-if-being-defined #:*systems-being-defined* + #:find-system-if-being-defined #:contrib-sysdef-search #:sysdef-find-asdf ;; backward compatibility symbols, functions removed #:sysdef-preloaded-system-search #:register-preloaded-system #:*preloaded-systems* - #:clear-defined-systems #:*defined-systems* + #:clear-defined-system #:clear-defined-systems #:*defined-systems* + #:*immutable-systems* ;; defined in source-registry, but specially mentioned here: #:initialize-source-registry #:sysdef-source-registry-search)) (in-package :asdf/find-system) @@ -7031,15 +7298,18 @@ of which is a system object.") (get-file-stamp file)) system))))) + (defun clear-defined-system (system) + (let ((name (coerce-name system))) + (remhash name *defined-systems*) + (unset-asdf-cache-entry `(locate-system ,name)) + (unset-asdf-cache-entry `(find-system ,name)) + nil)) + (defun clear-defined-systems () ;; Invalidate all systems but ASDF itself, if registered. - (let ((asdf (cdr (system-registered-p :asdf)))) - (setf *defined-systems* (make-hash-table :test 'equal)) - (when asdf - (setf (component-version asdf) *asdf-version*) - (setf (builtin-system-p asdf) t) - (register-system asdf))) - (values)) + (loop :for name :being :the :hash-keys :of *defined-systems* + :unless (equal name "asdf") + :do (clear-defined-system name))) (register-hook-function '*post-upgrade-cleanup-hook* 'clear-defined-systems nil) @@ -7080,12 +7350,12 @@ called with an object of type asdf:system." (cleanup-system-definition-search-functions) (defun search-for-system-definition (system) - (block () - (let ((name (coerce-name system))) - (flet ((try (f) (if-let ((x (funcall f name))) (return x)))) - (try 'find-system-if-being-defined) - (map () #'try *system-definition-search-functions*) - (try 'sysdef-preloaded-system-search))))) + (let ((name (coerce-name system))) + (flet ((try (f) (if-let ((x (funcall f name))) (return-from search-for-system-definition x)))) + (try 'find-system-if-being-defined) + (try 'sysdef-immutable-system-search) + (map () #'try *system-definition-search-functions*) + (try 'sysdef-preloaded-system-search)))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -7120,9 +7390,7 @@ Going forward, we recommend new users should be using the source-registry. :name (strcat name ".asd") :type "lnk"))) (when (probe-file* shortcut) - (let ((target (parse-windows-shortcut shortcut))) - (when target - (return (pathname target)))))))))) + (ensure-pathname (parse-windows-shortcut shortcut) :namestring :native))))))) (defun sysdef-central-registry-search (system) (let ((name (primary-system-name system)) @@ -7187,45 +7455,24 @@ Going forward, we recommend new users should be using the source-registry. (defun register-preloaded-system (system-name &rest keys) (setf (gethash (coerce-name system-name) *preloaded-systems*) keys)) - (register-preloaded-system "asdf" :version *asdf-version*) - (register-preloaded-system "uiop" :version *asdf-version*) - (register-preloaded-system "asdf-driver" :version *asdf-version*) - (register-preloaded-system "asdf-defsystem" :version *asdf-version*) + (dolist (s '("asdf" "uiop" "asdf-driver" "asdf-defsystem" "asdf-package-system")) + ;; don't bother with these, no one relies on them: "asdf-utils" "asdf-bundle" + (register-preloaded-system s :version *asdf-version*)) (defmethod find-system ((name null) &optional (error-p t)) - (declare (ignorable name)) (when error-p (sysdef-error (compatfmt "~@<NIL is not a valid system name~@:>")))) (defmethod find-system (name &optional (error-p t)) (find-system (coerce-name name) error-p)) - (defvar *systems-being-defined* nil - "A hash-table of systems currently being defined keyed by name, or NIL") - (defun find-system-if-being-defined (name) - (when *systems-being-defined* - ;; notable side effect: mark the system as being defined, to avoid infinite loops - (ensure-gethash (coerce-name name) *systems-being-defined* nil))) - - (defun call-with-system-definitions (thunk) - (if *systems-being-defined* - (call-with-asdf-cache thunk) - (let ((*systems-being-defined* (make-hash-table :test 'equal))) - (call-with-asdf-cache thunk)))) - - (defun clear-systems-being-defined () - (when *systems-being-defined* - (clrhash *systems-being-defined*))) - - (register-hook-function '*post-upgrade-cleanup-hook* 'clear-systems-being-defined) - - (defmacro with-system-definitions ((&optional) &body body) - `(call-with-system-definitions #'(lambda () ,@body))) + ;; notable side effect: mark the system as being defined, to avoid infinite loops + (first (gethash `(find-system ,(coerce-name name)) *asdf-cache*))) (defun load-asd (pathname &key name (external-format (encoding-external-format (detect-encoding pathname))) &aux (readtable *readtable*) (print-pprint-dispatch *print-pprint-dispatch*)) ;; Tries to load system definition with canonical NAME from PATHNAME. - (with-system-definitions () + (with-asdf-cache () (with-standard-io-syntax (let ((*package* (find-package :asdf-user)) ;; Note that our backward-compatible *readtable* is @@ -7245,8 +7492,7 @@ Going forward, we recommend new users should be using the source-registry. :condition condition)))) (asdf-message (compatfmt "~&~@<; ~@;Loading system definition~@[ for ~A~] from ~A~@:>~%") name pathname) - (with-muffled-loader-conditions () - (load* pathname :external-format external-format))))))) + (load* pathname :external-format external-format)))))) (defvar *old-asdf-systems* (make-hash-table :test 'equal)) @@ -7257,14 +7503,17 @@ Going forward, we recommend new users should be using the source-registry. (version (and (probe-file* version-pathname :truename nil) (read-file-form version-pathname))) (old-version (asdf-version))) - (or (version<= old-version version) - (ensure-gethash - (list pathname old-version) *old-asdf-systems* - #'(lambda () - (let ((old-pathname - (if-let (pair (system-registered-p "asdf")) - (system-source-file (cdr pair))))) - (warn "~@<~ + (cond + ((version< old-version version) t) ;; newer version: good! + ((equal old-version version) nil) ;; same version: don't load, but don't warn + (t ;; old version: bad + (ensure-gethash + (list (namestring pathname) version) *old-asdf-systems* + #'(lambda () + (let ((old-pathname + (if-let (pair (system-registered-p "asdf")) + (system-source-file (cdr pair))))) + (warn "~@<~ You are using ASDF version ~A ~:[(probably from (require \"asdf\") ~ or loaded by quicklisp)~;from ~:*~S~] and have an older version of ASDF ~ ~:[(and older than 2.27 at that)~;~:*~A~] registered at ~S. ~ @@ -7286,8 +7535,27 @@ Going forward, we recommend new users should be using the source-registry. then you might indeed want to either install and register a more recent version, ~ or use :ignore-inherited-configuration to avoid registering the old one. ~ Please consult ASDF documentation and/or experts.~@:>~%" - old-version old-pathname version pathname) - t))))))) + old-version old-pathname version pathname)))) + nil))))) ;; only issue the warning the first time, but always return nil + + (defvar *immutable-systems* nil + "An hash-set (equal hash-table mapping keys to T) of systems that are immutable, +i.e. already loaded in memory and not to be refreshed from the filesystem. +They will be treated specially by find-system, and passed as :force-not argument to make-plan. + +If you deliver an image with many systems precompiled, *and* do not want to check the filesystem +for them every time a user loads an extension, what more risk a problematic upgrade or catastrophic +downgrade, before you dump an image, use: + (setf asdf::*immutable-systems* (uiop:list-to-hash-set (asdf:already-loaded-systems)))") + + (defun sysdef-immutable-system-search (requested) + (let ((name (coerce-name requested))) + (when (and *immutable-systems* (gethash name *immutable-systems*)) + (or (cdr (system-registered-p requested)) + (error 'formatted-system-definition-error + :format-control "Requested system ~A is in the *immutable-systems* set, ~ +but not loaded in memory" + :format-arguments (list name)))))) (defun locate-system (name) "Given a system NAME designator, try to locate where to load the system from. @@ -7299,39 +7567,43 @@ PATHNAME when not null is a path from where to load the system, either associated with FOUND-SYSTEM, or with the PREVIOUS system. PREVIOUS when not null is a previously loaded SYSTEM object of same name. PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded." - (let* ((name (coerce-name name)) - (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk - (previous (cdr in-memory)) - (previous (and (typep previous 'system) previous)) - (previous-time (car in-memory)) - (found (search-for-system-definition name)) - (found-system (and (typep found 'system) found)) - (pathname (ensure-pathname - (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))) - :want-absolute t :resolve-symlinks *resolve-symlinks*)) - (foundp (and (or found-system pathname previous) t))) - (check-type found (or null pathname system)) - (unless (check-not-old-asdf-system name pathname) - (cond - (previous (setf found nil pathname nil)) - (t - (setf found (sysdef-preloaded-system-search "asdf")) - (assert (typep found 'system)) - (setf found-system found pathname nil)))) - (values foundp found-system pathname previous previous-time))) + (with-asdf-cache (:key `(locate-system ,name)) + (let* ((name (coerce-name name)) + (in-memory (system-registered-p name)) ; load from disk if absent or newer on disk + (previous (cdr in-memory)) + (previous (and (typep previous 'system) previous)) + (previous-time (car in-memory)) + (found (search-for-system-definition name)) + (found-system (and (typep found 'system) found)) + (pathname (ensure-pathname + (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous))) + :want-absolute t :resolve-symlinks *resolve-symlinks*)) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (unless (check-not-old-asdf-system name pathname) + (cond + (previous (setf found nil pathname nil)) + (t + (setf found (sysdef-preloaded-system-search "asdf")) + (assert (typep found 'system)) + (setf found-system found pathname nil)))) + (values foundp found-system pathname previous previous-time)))) (defmethod find-system ((name string) &optional (error-p t)) - (with-system-definitions () + (with-asdf-cache (:key `(find-system ,name)) (let ((primary-name (primary-system-name name))) - (unless (or (equal name primary-name) - (nth-value 1 (gethash primary-name *systems-being-defined*))) + (unless (equal name primary-name) (find-system primary-name nil))) (loop (restart-case (multiple-value-bind (foundp found-system pathname previous previous-time) (locate-system name) + (when (and found-system (eq found-system previous) + (or (first (gethash `(find-system ,name) *asdf-cache*)) + (and *immutable-systems* (gethash name *immutable-systems*)))) + (return found-system)) (assert (eq foundp (and (or found-system pathname previous) t))) (let ((previous-pathname (and previous (system-source-file previous))) (system (or previous found-system))) @@ -7363,14 +7635,15 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (reinitialize-source-registry-and-retry () :report (lambda (s) (format s (compatfmt "~@<Retry finding system ~A after reinitializing the source-registry.~@:>") name)) + (unset-asdf-cache-entry `(locate-system ,name)) (initialize-source-registry))))))) ;;;; ------------------------------------------------------------------------- ;;;; Finding components -(asdf/package:define-package :asdf/find-component +(uiop/package:define-package :asdf/find-component (:recycle :asdf/find-component :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache :asdf/component :asdf/system :asdf/find-system) (:export #:find-component @@ -7446,8 +7719,7 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (defmethod find-component ((c component) (name cons)) (find-component (find-component c (car name)) (cdr name))) - (defmethod find-component (base (actual component)) - (declare (ignorable base)) + (defmethod find-component ((base t) (actual component)) actual) (defun resolve-dependency-name (component name &optional version) @@ -7474,7 +7746,12 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (or (null c) (and (typep c 'missing-dependency) (eq (missing-required-by c) component) - (equal (missing-requires c) name)))))))) + (equal (missing-requires c) name)))) + (unless (component-parent component) + (let ((name (coerce-name name))) + (unset-asdf-cache-entry `(find-system ,name)) + (unset-asdf-cache-entry `(locate-system ,name)))))))) + (defun resolve-dependency-spec (component dep-spec) (let ((component (find-component () component))) @@ -7487,41 +7764,42 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. (cons combinator arguments) component)) (defmethod resolve-dependency-combination (component (combinator (eql :feature)) arguments) - (declare (ignorable combinator)) (when (featurep (first arguments)) (resolve-dependency-spec component (second arguments)))) (defmethod resolve-dependency-combination (component (combinator (eql :version)) arguments) - (declare (ignorable combinator)) ;; See https://bugs.launchpad.net/asdf/+bug/527788 - (resolve-dependency-name component (first arguments) (second arguments)))) + (resolve-dependency-name component (first arguments) (second arguments)))) ;; See lp#527788 ;;;; ------------------------------------------------------------------------- ;;;; Operations -(asdf/package:define-package :asdf/operation +(uiop/package:define-package :asdf/operation (:recycle :asdf/operation :asdf/action :asdf) ;; asdf/action for FEATURE pre 2.31.5. - (:use :uiop/common-lisp :uiop :asdf/upgrade) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/find-system) (:export #:operation #:operation-original-initargs #:original-initargs ;; backward-compatibility only. DO NOT USE. - #:build-op ;; THE generic operation - #:*operations* #:make-operation #:find-operation #:feature)) + #:*operations* #:make-operation #:find-operation + #:feature)) ;; TODO: stop exporting the deprecated FEATURE feature. (in-package :asdf/operation) ;;; Operation Classes (when-upgrading (:when (find-class 'operation nil)) - (defmethod shared-initialize :after ((o operation) slot-names &rest initargs &key) - (declare (ignorable o slot-names initargs)) (values))) + ;; override any obsolete shared-initialize method when upgrading from ASDF2. + (defmethod shared-initialize :after ((o operation) (slot-names t) &key) + (values))) (with-upgradability () (defclass operation () ((original-initargs ;; for backward-compat -- used by GBBopen and swank (via operation-forced) :initform nil :initarg :original-initargs :accessor operation-original-initargs))) + ;; Cache a copy of the INITARGS in the ORIGINAL-INITARGS slot, if that slot is not + ;; already bound. (defmethod initialize-instance :after ((o operation) &rest initargs &key force force-not system verbose &allow-other-keys) - (declare (ignorable force force-not system verbose)) + (declare (ignore force force-not system verbose)) (unless (slot-boundp o 'original-initargs) (setf (operation-original-initargs o) initargs))) @@ -7533,32 +7811,31 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. ;;; make-operation, find-operation (with-upgradability () - (defparameter *operations* (make-hash-table :test 'equal)) + (defparameter* *operations* (make-hash-table :test 'equal)) + (defun make-operation (operation-class &rest initargs) - (ensure-gethash (cons operation-class initargs) *operations* - (list* 'make-instance operation-class initargs))) + (let ((class (coerce-class operation-class + :package :asdf/interface :super 'operation :error 'sysdef-error))) + (ensure-gethash (cons class initargs) *operations* + (list* 'make-instance class initargs)))) (defgeneric find-operation (context spec) (:documentation "Find an operation by resolving the SPEC in the CONTEXT")) - (defmethod find-operation (context (spec operation)) - (declare (ignorable context)) + (defmethod find-operation ((context t) (spec operation)) spec) (defmethod find-operation (context (spec symbol)) - (unless (member spec '(nil feature)) - ;; NIL designates itself, i.e. absence of operation - ;; FEATURE is the ASDF1 misfeature that comes with IF-COMPONENT-DEP-FAILS + (when spec ;; NIL designates itself, i.e. absence of operation (apply 'make-operation spec (operation-original-initargs context)))) + (defmethod find-operation (context (spec string)) + (apply 'make-operation spec (operation-original-initargs context))) (defmethod operation-original-initargs ((context symbol)) (declare (ignorable context)) - nil) - - (defclass build-op (operation) ())) - + nil)) ;;;; ------------------------------------------------------------------------- ;;;; Actions -(asdf/package:define-package :asdf/action +(uiop/package:define-package :asdf/action (:nicknames :asdf-action) (:recycle :asdf/action :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade @@ -7566,18 +7843,26 @@ 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 #:sideway-operation #:selfward-operation + #:downward-operation #:upward-operation #:sideway-operation #:selfward-operation #:non-propagating-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 #:perform #:perform-with-restarts #:retry #:accept #:traverse-actions #:traverse-sub-actions #:required-components ;; in plan - #:action-path #:find-action #:stamp #:done-p)) + #:action-path #:find-action #:stamp #:done-p + #:operation-definition-warning #:operation-definition-error ;; condition + )) (in-package :asdf/action) -(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) - (deftype action () '(cons operation component))) ;; a step to be performed while building +(eval-when (#-lispworks :compile-toplevel :load-toplevel :execute) ;; LispWorks issues spurious warning + (deftype action () '(cons operation component)) ;; a step to be performed while building + + (deftype operation-designator () + ;; an operation designates itself, + ;; nil designates a context-dependent current operation, and + ;; class-name or class designates an instance of the designated class. + '(or operation null symbol class))) (with-upgradability () (defgeneric traverse-actions (actions &key &allow-other-keys)) @@ -7614,7 +7899,10 @@ PREVIOUS-TIME when not null is the time at which the PREVIOUS system was loaded. `(apply ',function ,@prefix ,o ,c ,@suffix ,rest) `(,function ,@prefix ,o ,c ,@suffix)))) `(progn - (defmethod ,function (,@prefix (,operation symbol) component ,@suffix ,@more-args) + (defmethod ,function (,@prefix (,operation string) ,component ,@suffix ,@more-args) + (let ((,component (find-component () ,component))) ;; do it first, for defsystem-depends-on + ,(next-method `(safe-read-from-string ,operation :package :asdf/interface) component))) + (defmethod ,function (,@prefix (,operation symbol) ,component ,@suffix ,@more-args) (if ,operation ,(next-method (if operation-initargs ;backward-compatibility with ASDF1's operate. Yuck. @@ -7663,11 +7951,12 @@ You can put together sentences using this phrase.")) and each <component> is a component designator with respect to FIND-COMPONENT in the context of the COMPONENT argument, and means that the component depends on - <operation> having been performed on each <component>; or + <operation> having been performed on each <component>; - (FEATURE <feature>), which means that the component depends - on the <feature> expression satisfying FEATUREP. - (This is DEPRECATED -- use :IF-FEATURE instead.) + [Note: an <operation> is an operation designator -- it can be either an + operation name or an operation object. Similarly, a <component> may be + a component name or a component object. Also note that, the degenerate + case of (<operation>) is a no-op.] Methods specialized on subclasses of existing component types should usually append the results of CALL-NEXT-METHOD to the list.")) @@ -7675,54 +7964,132 @@ You can put together sentences using this phrase.")) (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 + (call-next-method)))) -;;;; upward-operation, downward-operation -;; These together handle actions that propagate along the component hierarchy. -;; Downward operations like load-op or compile-op propagate down the hierarchy: -;; operation on a parent depends-on operation on its children. -;; By default, an operation propagates itself, but it may propagate another one instead. +;;;; upward-operation, downward-operation, sideway-operation, selfward-operation +;; These together handle actions that propagate along the component hierarchy or operation universe. (with-upgradability () (defclass downward-operation (operation) ((downward-operation - :initform nil :initarg :downward-operation :reader downward-operation :allocation :class))) + :initform nil :reader downward-operation + :type operation-designator :allocation :class)) + (:documentation "A DOWNWARD-OPERATION's dependencies propagate down the component hierarchy. +I.e., if O is a DOWNWARD-OPERATION and its DOWNWARD-OPERATION slot designates operation D, then +the action (O . M) of O on module M will depends on each of (D . C) for each child C of module M. +The default value for slot DOWNWARD-OPERATION is NIL, which designates the operation O itself. +E.g. in order for a MODULE to be loaded with LOAD-OP (resp. compiled with COMPILE-OP), all the +children of the MODULE must have been loaded with LOAD-OP (resp. compiled with COMPILE-OP.")) + (defun downward-operation-depends-on (o c) + `((,(or (downward-operation o) o) ,@(component-children c)))) (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: - ;; operation on a child depends-on operation on its parent. - ;; By default, an operation propagates itself, but it may propagate another one instead. + `(,@(downward-operation-depends-on o c) ,@(call-next-method))) + (defclass upward-operation (operation) ((upward-operation - :initform nil :initarg :downward-operation :reader upward-operation :allocation :class))) + :initform nil :reader upward-operation + :type operation-designator :allocation :class)) + (:documentation "An UPWARD-OPERATION has dependencies that propagate up the component hierarchy. +I.e., if O is an instance of UPWARD-OPERATION, and its UPWARD-OPERATION slot designates operation U, +then the action (O . C) of O on a component C that has the parent P will depends on (U . P). +The default value for slot UPWARD-OPERATION is NIL, which designates the operation O itself. +E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, its PARENT +must first be prepared for loading or compiling with PREPARE-OP.")) ;; For backward-compatibility reasons, a system inherits from module and is a child-component ;; so we must guard against this case. ASDF4: remove that. + (defun upward-operation-depends-on (o c) + (if-let (p (component-parent c)) `((,(or (upward-operation o) o) ,p)))) (defmethod component-depends-on ((o upward-operation) (c child-component)) - `(,@(if-let (p (component-parent c)) - `((,(or (upward-operation o) o) ,p))) ,@(call-next-method))) - ;; 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. + `(,@(upward-operation-depends-on o c) ,@(call-next-method))) + (defclass sideway-operation (operation) ((sideway-operation - :initform nil :initarg :sideway-operation :reader sideway-operation :allocation :class))) + :initform nil :reader sideway-operation + :type operation-designator :allocation :class)) + (:documentation "A SIDEWAY-OPERATION has dependencies that propagate \"sideway\" to siblings +that a component depends on. I.e. if O is a SIDEWAY-OPERATION, and its SIDEWAY-OPERATION slot +designates operation S (where NIL designates O itself), then the action (O . C) of O on component C +depends on each of (S . D) where D is a declared dependency of C. +E.g. in order for a COMPONENT to be prepared for loading or compiling with PREPARE-OP, +each of its declared dependencies must first be loaded as by LOAD-OP.")) + (defun sideway-operation-depends-on (o c) + `((,(or (sideway-operation o) o) ,@(component-sideway-dependencies c)))) (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. + `(,@(sideway-operation-depends-on o c) ,@(call-next-method))) + (defclass selfward-operation (operation) ((selfward-operation - :initform nil :initarg :selfward-operation :reader selfward-operation :allocation :class))) + ;; NB: no :initform -- if an operation depends on others, it must explicitly specify which + :type (or operation-designator list) :reader selfward-operation :allocation :class)) + (:documentation "A SELFWARD-OPERATION depends on another operation on the same component. +I.e., if O is a SELFWARD-OPERATION, and its SELFWARD-OPERATION designates a list of operations L, +then the action (O . C) of O on component C depends on each (S . C) for S in L. +E.g. before a component may be loaded by LOAD-OP, it must have been compiled by COMPILE-OP. +A operation-designator designates a singleton list of the designated operation; +a list of operation-designators designates the list of designated operations; +NIL is not a valid operation designator in that context. Note that any dependency +ordering between the operations in a list of SELFWARD-OPERATION should be specified separately +in the respective operation's COMPONENT-DEPENDS-ON methods so that they be scheduled properly.")) + (defun selfward-operation-depends-on (o c) + (loop :for op :in (ensure-list (selfward-operation o)) :collect `(,op ,c))) (defmethod component-depends-on ((o selfward-operation) (c component)) - `(,@(loop :for op :in (ensure-list (selfward-operation o)) - :collect `(,op ,c)) - ,@(call-next-method)))) + `(,@(selfward-operation-depends-on o c) ,@(call-next-method))) + + (defclass non-propagating-operation (operation) + () + (:documentation "A NON-PROPAGATING-OPERATION is an operation that propagates +no dependencies whatsoever. It is supplied in order that the programmer be able +to specify that s/he is intentionally specifying an operation which invokes no +dependencies."))) + + +;;;--------------------------------------------------------------------------- +;;; Help programmers catch obsolete OPERATION subclasses +;;;--------------------------------------------------------------------------- +(with-upgradability () + (define-condition operation-definition-warning (simple-warning) + () + (:documentation "Warning condition related to definition of obsolete OPERATION objects.")) + + (define-condition operation-definition-error (simple-error) + () + (:documentation "Error condition related to definition of incorrect OPERATION objects.")) + + (defmethod initialize-instance :before ((o operation) &key) + (unless (typep o '(or downward-operation upward-operation sideway-operation + selfward-operation non-propagating-operation)) + (warn 'operation-definition-warning + :format-control + "No dependency propagating scheme specified for operation class ~S. +The class needs to be updated for ASDF 3.1 and specify appropriate propagation mixins." + :format-arguments (list (type-of o))))) + + (defmethod initialize-instance :before ((o non-propagating-operation) &key) + (when (typep o '(or downward-operation upward-operation sideway-operation selfward-operation)) + (error 'operation-definition-error + :format-control + "Inconsistent class: ~S + NON-PROPAGATING-OPERATION is incompatible with propagating operation classes as superclasses." + :format-arguments + (list (type-of o))))) + + (defmethod component-depends-on ((o operation) (c component)) + `(;; Normal behavior, to allow user-specified in-order-to dependencies + ,@(cdr (assoc (type-of o) (component-in-order-to c))) + ;; For backward-compatibility with ASDF2, any operation that doesn't specify propagation + ;; or non-propagation through an appropriate mixin will be downward and sideway. + ,@(unless (typep o '(or downward-operation upward-operation sideway-operation + selfward-operation non-propagating-operation)) + `(,@(sideway-operation-depends-on o c) + ,@(when (typep c 'parent-component) (downward-operation-depends-on o c)))))) + + (defmethod downward-operation ((o operation)) nil) + (defmethod sideway-operation ((o operation)) nil)) + + +;;;--------------------------------------------------------------------------- +;;; End of OPERATION class checking +;;;--------------------------------------------------------------------------- ;;;; Inputs, Outputs, and invisible dependencies @@ -7736,7 +8103,6 @@ You can put together sentences using this phrase.")) (define-convenience-action-methods operation-done-p (operation component)) (defmethod operation-done-p ((o operation) (c component)) - (declare (ignorable o c)) t) (defmethod output-files :around (operation component) @@ -7758,7 +8124,6 @@ You can put together sentences using this phrase.")) (mapcar *output-translation-function* absolute-pathnames)))) t))) (defmethod output-files ((o operation) (c component)) - (declare (ignorable o c)) nil) (defun output-file (operation component) "The unique output file of performing OPERATION on COMPONENT" @@ -7772,7 +8137,6 @@ You can put together sentences using this phrase.")) (call-next-method))) (defmethod input-files ((o operation) (c component)) - (declare (ignorable o c)) nil) (defmethod input-files ((o selfward-operation) (c component)) @@ -7838,12 +8202,14 @@ in some previous image, or T if it needs to be done.") (defmethod perform :after ((o operation) (c component)) (mark-operation-done o c)) (defmethod perform ((o operation) (c parent-component)) - (declare (ignorable o c)) nil) (defmethod perform ((o operation) (c source-file)) - (sysdef-error - (compatfmt "~@<Required method PERFORM not implemented for operation ~A, component ~A~@:>") - (class-of o) (class-of c))) + ;; For backward compatibility, don't error on operations that don't specify propagation. + (when (typep o '(or downward-operation upward-operation sideway-operation + selfward-operation non-propagating-operation)) + (sysdef-error + (compatfmt "~@<Required method ~S not implemented for ~/asdf-action:format-action/~@:>") + 'perform (cons o c)))) (defmethod perform-with-restarts (operation component) ;; TOO verbose, especially as the default. Add your own :before method @@ -7866,16 +8232,10 @@ in some previous image, or T if it needs to be done.") (action-description operation component))) (mark-operation-done operation component) (return)))))) - -;;; Generic build operation -(with-upgradability () - (defmethod component-depends-on ((o build-op) (c component)) - `((,(or (component-build-operation c) 'load-op) ,c)))) - ;;;; ------------------------------------------------------------------------- ;;;; Actions to build Common Lisp software -(asdf/package:define-package :asdf/lisp-action +(uiop/package:define-package :asdf/lisp-action (:recycle :asdf/lisp-action :asdf) (:intern #:proclamations #:flags) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache @@ -7912,22 +8272,22 @@ in some previous image, or T if it needs to be done.") ;;; Our default operations: loading into the current lisp image (with-upgradability () (defclass prepare-op (upward-operation sideway-operation) - ((sideway-operation :initform 'load-op))) - (defclass load-op (basic-load-op downward-operation sideway-operation selfward-operation) + ((sideway-operation :initform 'load-op :allocation :class)) + (:documentation "Load dependencies necessary for COMPILE-OP or LOAD-OP of a given COMPONENT.")) + (defclass load-op (basic-load-op downward-operation selfward-operation) ;; NB: even though compile-op depends 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)))) + ((selfward-operation :initform '(prepare-op compile-op) :allocation :class))) (defclass compile-op (basic-compile-op downward-operation selfward-operation) - ((selfward-operation :initform 'prepare-op) - (downward-operation :initform 'load-op))) + ((selfward-operation :initform 'prepare-op :allocation :class))) (defclass prepare-source-op (upward-operation sideway-operation) - ((sideway-operation :initform 'load-source-op))) + ((sideway-operation :initform 'load-source-op :allocation :class))) (defclass load-source-op (basic-load-op downward-operation selfward-operation) - ((selfward-operation :initform 'prepare-source-op))) + ((selfward-operation :initform 'prepare-source-op :allocation :class))) (defclass test-op (selfward-operation) - ((selfward-operation :initform 'load-op)))) + ((selfward-operation :initform 'load-op :allocation :class)))) ;;;; prepare-op, compile-op and load-op @@ -7935,25 +8295,17 @@ in some previous image, or T if it needs to be done.") ;;; prepare-op (with-upgradability () (defmethod action-description ((o prepare-op) (c component)) - (declare (ignorable o)) (format nil (compatfmt "~@<loading dependencies of ~3i~_~A~@:>") c)) (defmethod perform ((o prepare-op) (c component)) - (declare (ignorable o c)) - nil) - (defmethod input-files ((o prepare-op) (c component)) - (declare (ignorable o c)) nil) (defmethod input-files ((o prepare-op) (s system)) - (declare (ignorable o)) (if-let (it (system-source-file s)) (list it)))) ;;; compile-op (with-upgradability () (defmethod action-description ((o compile-op) (c component)) - (declare (ignorable o)) (format nil (compatfmt "~@<compiling ~3i~_~A~@:>") c)) (defmethod action-description ((o compile-op) (c parent-component)) - (declare (ignorable o)) (format nil (compatfmt "~@<completing compilation for ~3i~_~A~@:>") c)) (defgeneric call-with-around-compile-hook (component thunk)) (defmethod call-with-around-compile-hook ((c component) function) @@ -7974,15 +8326,14 @@ in some previous image, or T if it needs to be done.") warnings-file) outputs (call-with-around-compile-hook c #'(lambda (&rest flags) - (with-muffled-compiler-conditions () - (apply 'compile-file* input-file - :output-file output-file - :external-format (component-external-format c) - :warnings-file warnings-file - (append - #+clisp (list :lib-file lib-file) - #+(or ecl mkcl) (list :object-file object-file) - flags (compile-op-flags o))))))) + (apply 'compile-file* input-file + :output-file output-file + :external-format (component-external-format c) + :warnings-file warnings-file + (append + #+clisp (list :lib-file lib-file) + #+(or ecl mkcl) (list :object-file object-file) + flags (compile-op-flags o)))))) (check-lisp-compile-results output warnings-p failure-p "~/asdf-action::format-action/" (list (cons o c)))))) @@ -8020,10 +8371,6 @@ in some previous image, or T if it needs to be done.") (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) - (defmethod output-files ((o compile-op) (c static-file)) - (declare (ignorable o c)) nil) (defmethod perform ((o compile-op) (c system)) (when (and *warnings-file-type* (not (builtin-system-p c))) @@ -8043,15 +8390,11 @@ in some previous image, or T if it needs to be done.") ;;; load-op (with-upgradability () (defmethod action-description ((o load-op) (c cl-source-file)) - (declare (ignorable o)) (format nil (compatfmt "~@<loading FASL for ~3i~_~A~@:>") c)) (defmethod action-description ((o load-op) (c parent-component)) - (declare (ignorable o)) (format nil (compatfmt "~@<completing load for ~3i~_~A~@:>") c)) - (defmethod action-description ((o load-op) component) - (declare (ignorable o)) - (format nil (compatfmt "~@<loading ~3i~_~A~@:>") - component)) + (defmethod action-description ((o load-op) (c component)) + (format nil (compatfmt "~@<loading ~3i~_~A~@:>") c)) (defmethod perform-with-restarts ((o load-op) (c cl-source-file)) (loop (restart-case @@ -8063,11 +8406,10 @@ in some previous image, or T if it needs to be done.") (perform (find-operation o 'compile-op) c))))) (defun perform-lisp-load-fasl (o c) (if-let (fasl (first (input-files o c))) - (with-muffled-loader-conditions () (load* fasl)))) + (load* fasl))) (defmethod perform ((o load-op) (c cl-source-file)) (perform-lisp-load-fasl o c)) (defmethod perform ((o load-op) (c static-file)) - (declare (ignorable o c)) nil)) @@ -8076,57 +8418,42 @@ in some previous image, or T if it needs to be done.") ;;; prepare-source-op (with-upgradability () (defmethod action-description ((o prepare-source-op) (c component)) - (declare (ignorable o)) (format nil (compatfmt "~@<loading source for dependencies of ~3i~_~A~@:>") c)) - (defmethod input-files ((o prepare-source-op) (c component)) - (declare (ignorable o c)) - nil) (defmethod input-files ((o prepare-source-op) (s system)) - (declare (ignorable o)) (if-let (it (system-source-file s)) (list it))) (defmethod perform ((o prepare-source-op) (c component)) - (declare (ignorable o c)) nil)) ;;; load-source-op (with-upgradability () - (defmethod action-description ((o load-source-op) c) - (declare (ignorable o)) + (defmethod action-description ((o load-source-op) (c component)) (format nil (compatfmt "~@<Loading source of ~3i~_~A~@:>") c)) (defmethod action-description ((o load-source-op) (c parent-component)) - (declare (ignorable o)) (format nil (compatfmt "~@<Loaded source of ~3i~_~A~@:>") c)) (defun perform-lisp-load-source (o c) (call-with-around-compile-hook c #'(lambda () - (with-muffled-loader-conditions () - (load* (first (input-files o c)) - :external-format (component-external-format c)))))) + (load* (first (input-files o c)) + :external-format (component-external-format c))))) (defmethod perform ((o load-source-op) (c cl-source-file)) (perform-lisp-load-source o c)) (defmethod perform ((o load-source-op) (c static-file)) - (declare (ignorable o c)) - nil) - (defmethod output-files ((o load-source-op) (c component)) - (declare (ignorable o c)) nil)) ;;;; test-op (with-upgradability () (defmethod perform ((o test-op) (c component)) - (declare (ignorable o c)) nil) (defmethod operation-done-p ((o test-op) (c system)) "Testing a system is _never_ done." - (declare (ignorable o c)) nil)) ;;;; ------------------------------------------------------------------------- ;;;; Plan -(asdf/package:define-package :asdf/plan +(uiop/package:define-package :asdf/plan (:recycle :asdf/plan :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/operation :asdf/system @@ -8134,7 +8461,7 @@ in some previous image, or T if it needs to be done.") :asdf/operation :asdf/action :asdf/lisp-action) (:export #:component-operation-time #:mark-operation-done - #:plan-traversal #:sequential-plan #:*default-plan-class* + #:plan #:plan-traversal #:sequential-plan #:*default-plan-class* #:planned-action-status #:plan-action-status #:action-already-done-p #:circular-dependency #:circular-dependency-actions #:node-for #:needed-in-image-p @@ -8142,7 +8469,7 @@ in some previous image, or T if it needs to be done.") #:plan-record-dependency #:normalize-forced-systems #:action-forced-p #:action-forced-not-p #:map-direct-dependencies #:reduce-direct-dependencies #:direct-dependencies - #:visit-dependencies #:compute-action-stamp #:traverse-action + #:compute-action-stamp #:traverse-action #:circular-dependency #:circular-dependency-actions #:call-while-visiting-action #:while-visiting-action #:make-plan #:plan-actions #:perform-plan #:plan-operates-on-p @@ -8157,7 +8484,8 @@ in some previous image, or T if it needs to be done.") ;;;; Generic plan traversal class (with-upgradability () - (defclass plan-traversal () + (defclass plan () ()) + (defclass plan-traversal (plan) ((system :initform nil :initarg :system :accessor plan-system) (forced :initform nil :initarg :force :accessor plan-forced) (forced-not :initform nil :initarg :force-not :accessor plan-forced-not) @@ -8193,9 +8521,8 @@ the action of OPERATION on COMPONENT in the PLAN")) (with-slots (stamp done-p planned-p index) status (format stream "~@{~S~^ ~}" :stamp stamp :done-p done-p :planned-p planned-p :index index)))) - (defmethod action-planned-p (action-status) - (declare (ignorable action-status)) ; default method for non planned-action-status objects - t) + (defmethod action-planned-p ((action-status t)) + t) ; default method for non planned-action-status objects ;; TODO: eliminate NODE-FOR, use CONS. ;; Supposes cleaner protocol for operation initargs passed to MAKE-OPERATION. @@ -8206,12 +8533,10 @@ the action of OPERATION on COMPONENT in the PLAN")) (action-done-p (plan-action-status plan operation component))) (defmethod plan-action-status ((plan null) (o operation) (c component)) - (declare (ignorable plan)) (multiple-value-bind (stamp done-p) (component-operation-time o c) (make-instance 'action-status :stamp stamp :done-p done-p))) (defmethod (setf plan-action-status) (new-status (plan null) (o operation) (c component)) - (declare (ignorable plan)) (let ((to (type-of o)) (times (component-operation-times c))) (if (action-done-p new-status) @@ -8227,17 +8552,26 @@ the action of OPERATION on COMPONENT in the PLAN")) (defun normalize-forced-systems (x system) (etypecase x - ((member nil :all) x) + ((or (member nil :all) hash-table function) x) (cons (list-to-hash-set (mapcar #'coerce-name x))) ((eql t) (when system (list-to-hash-set (list (coerce-name system))))))) + (defun normalize-forced-not-systems (x system) + (let ((requested + (etypecase x + ((or (member nil :all) hash-table function) x) + (cons (list-to-hash-set (mapcar #'coerce-name x))) + ((eql t) (if system (let ((name (coerce-name system))) + #'(lambda (x) (not (equal x name)))) + t))))) + (if (and *immutable-systems* requested) + #'(lambda (x) (or (call-function requested x) (call-function *immutable-systems* x))) + (or *immutable-systems* requested)))) + (defun action-override-p (plan operation component override-accessor) - (declare (ignorable operation)) - (let* ((override (funcall override-accessor plan))) - (and override - (if (typep override 'hash-table) - (gethash (coerce-name (component-system (find-component () component))) override) - t)))) + (declare (ignore operation)) + (call-function (funcall override-accessor plan) + (coerce-name (component-system (find-component () component))))) (defmethod action-forced-p (plan operation component) (and @@ -8250,18 +8584,14 @@ the action of OPERATION on COMPONENT in the PLAN")) (not (eq system (plan-system plan)))))))) (defmethod action-forced-not-p (plan operation component) - (and - ;; Did the user ask us to not re-perform the action? - (action-override-p plan operation component 'plan-forced-not) - ;; Force takes precedence over force-not - (not (action-forced-p plan operation component)))) + ;; Did the user ask us to not re-perform the action? + ;; NB: force-not takes precedence over force, as it should + (action-override-p plan operation component 'plan-forced-not)) - (defmethod action-forced-p ((plan null) operation component) - (declare (ignorable plan operation component)) + (defmethod action-forced-p ((plan null) (operation operation) (component component)) nil) - (defmethod action-forced-not-p ((plan null) operation component) - (declare (ignorable plan operation component)) + (defmethod action-forced-not-p ((plan null) (operation operation) (component component)) nil)) @@ -8269,15 +8599,11 @@ the action of OPERATION on COMPONENT in the PLAN")) (with-upgradability () (defgeneric action-valid-p (plan operation component) (:documentation "Is this action valid to include amongst dependencies?")) - (defmethod action-valid-p (plan operation (c component)) - (declare (ignorable plan operation)) + (defmethod action-valid-p ((plan t) (o operation) (c component)) (if-let (it (component-if-feature c)) (featurep it) t)) - (defmethod action-valid-p (plan (o null) c) (declare (ignorable plan o c)) nil) - (defmethod action-valid-p (plan o (c null)) (declare (ignorable plan o c)) nil) - (defmethod action-valid-p ((plan null) operation component) - (declare (ignorable plan operation component)) - (and operation component t))) - + (defmethod action-valid-p ((plan t) (o null) (c t)) nil) + (defmethod action-valid-p ((plan t) (o t) (c null)) nil) + (defmethod action-valid-p ((plan null) (o operation) (c component)) t)) ;;;; Is the action needed in this image? (with-upgradability () @@ -8295,82 +8621,98 @@ the action of OPERATION on COMPONENT in the PLAN")) ;;;; Visiting dependencies of an action and computing action stamps (with-upgradability () - (defun map-direct-dependencies (operation component fun) + (defun (map-direct-dependencies) (plan operation component fun) (loop* :for (dep-o-spec . dep-c-specs) :in (component-depends-on operation component) :for dep-o = (find-operation operation dep-o-spec) :when dep-o :do (loop :for dep-c-spec :in dep-c-specs :for dep-c = (and dep-c-spec (resolve-dependency-spec component dep-c-spec)) - :when dep-c + :when (and dep-c (action-valid-p plan dep-o dep-c)) :do (funcall fun dep-o dep-c)))) - (defun reduce-direct-dependencies (operation component combinator seed) + (defun (reduce-direct-dependencies) (plan operation component combinator seed) (map-direct-dependencies - operation component + plan operation component #'(lambda (dep-o dep-c) (setf seed (funcall combinator dep-o dep-c seed)))) seed) - (defun direct-dependencies (operation component) - (reduce-direct-dependencies operation component #'acons nil)) + (defun (direct-dependencies) (plan operation component) + (reduce-direct-dependencies plan operation component #'acons nil)) - (defun visit-dependencies (plan operation component dependency-stamper &aux stamp) - (map-direct-dependencies - operation component - #'(lambda (dep-o dep-c) - (when (action-valid-p plan dep-o dep-c) - (latest-stamp-f stamp (funcall dependency-stamper dep-o dep-c))))) - stamp) + ;; In a distant future, get-file-stamp, component-operation-time and latest-stamp + ;; shall also be parametrized by the plan, or by a second model object, + ;; so they need not refer to the state of the filesystem, + ;; and the stamps could be cryptographic checksums rather than timestamps. + ;; Such a change remarkably would only affect COMPUTE-ACTION-STAMP. (defmethod compute-action-stamp (plan (o operation) (c component) &key just-done) - ;; In a distant future, get-file-stamp and component-operation-time - ;; shall also be parametrized by the plan, or by a second model object. - (let* ((stamp-lookup #'(lambda (o c) - (if-let (it (plan-action-status plan o c)) (action-stamp it) t))) - (out-files (output-files o c)) - (in-files (input-files o c)) - ;; Three kinds of actions: - (out-op (and out-files t)) ; those that create files on the filesystem - ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image - ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing - ;; When was the thing last actually done? (Now, or ask.) - (op-time (or just-done (component-operation-time o c))) - ;; Accumulated timestamp from dependencies (or T if forced or out-of-date) - (dep-stamp (visit-dependencies plan o c stamp-lookup)) - ;; Time stamps from the files at hand, and whether any is missing - (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) - (in-stamps (mapcar #'get-file-stamp in-files)) - (missing-in - (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) - (missing-out - (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) - (all-present (not (or missing-in missing-out))) - ;; Has any input changed since we last generated the files? - (earliest-out (stamps-earliest out-stamps)) - (latest-in (stamps-latest (cons dep-stamp in-stamps))) - (up-to-date-p (stamp<= latest-in earliest-out)) - ;; If everything is up to date, the latest of inputs and outputs is our stamp - (done-stamp (stamps-latest (cons latest-in out-stamps)))) - ;; Warn if some files are missing: - ;; either our model is wrong or some other process is messing with our files. - (when (and just-done (not all-present)) - (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ - ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" - (action-description o c) - missing-in (length missing-in) (and missing-in missing-out) - missing-out (length missing-out))) - ;; Note that we use stamp<= instead of stamp< to play nice with generated files. - ;; Any race condition is intrinsic to the limited timestamp resolution. - (if (or just-done ;; The done-stamp is valid: if we're just done, or - ;; if all filesystem effects are up-to-date and there's no invalidating reason. - (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 - 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))))) + ;; Given an action, figure out at what time in the past it has been done, + ;; or if it has just been done, return the time that it has. + ;; Returns two values: + ;; 1- the TIMESTAMP of the action if it has already been done and is up to date, + ;; or T is either hasn't been done or is out of date. + ;; 2- the DONE-IN-IMAGE-P boolean flag that is T if the action has already been done + ;; in the current image, or NIL if it hasn't. + ;; Note that if e.g. LOAD-OP only depends on up-to-date files, but + ;; hasn't been done in the current image yet, then it can have a non-T timestamp, + ;; yet a NIL done-in-image-p flag. + (nest + (block ()) + (let ((dep-stamp ; collect timestamp from dependencies (or T if forced or out-of-date) + (reduce-direct-dependencies + plan o c + #'(lambda (o c stamp) + (if-let (it (plan-action-status plan o c)) + (latest-stamp stamp (action-stamp it)) + t)) + nil))) + ;; out-of-date dependency: don't bother expensively querying the filesystem + (when (and (eq dep-stamp t) (not just-done)) (return (values t nil)))) + ;; collect timestamps from inputs, and exit early if any is missing + (let* ((in-files (input-files o c)) + (in-stamps (mapcar #'get-file-stamp in-files)) + (missing-in (loop :for f :in in-files :for s :in in-stamps :unless s :collect f)) + (latest-in (stamps-latest (cons dep-stamp in-stamps)))) + (when (and missing-in (not just-done)) (return (values t nil)))) + ;; collect timestamps from outputs, and exit early if any is missing + (let* ((out-files (output-files o c)) + (out-stamps (mapcar (if just-done 'register-file-stamp 'get-file-stamp) out-files)) + (missing-out (loop :for f :in out-files :for s :in out-stamps :unless s :collect f)) + (earliest-out (stamps-earliest out-stamps))) + (when (and missing-out (not just-done)) (return (values t nil)))) + (let* (;; There are three kinds of actions: + (out-op (and out-files t)) ; those that create files on the filesystem + ;;(image-op (and in-files (null out-files))) ; those that load stuff into the image + ;;(null-op (and (null out-files) (null in-files))) ; placeholders that do nothing + ;; When was the thing last actually done? (Now, or ask.) + (op-time (or just-done (component-operation-time o c))) + ;; Time stamps from the files at hand, and whether any is missing + (all-present (not (or missing-in missing-out))) + ;; Has any input changed since we last generated the files? + (up-to-date-p (stamp<= latest-in earliest-out)) + ;; If everything is up to date, the latest of inputs and outputs is our stamp + (done-stamp (stamps-latest (cons latest-in out-stamps)))) + ;; Warn if some files are missing: + ;; either our model is wrong or some other process is messing with our files. + (when (and just-done (not all-present)) + (warn "~A completed without ~:[~*~;~*its input file~:p~2:*~{ ~S~}~*~]~ + ~:[~; or ~]~:[~*~;~*its output file~:p~2:*~{ ~S~}~*~]" + (action-description o c) + missing-in (length missing-in) (and missing-in missing-out) + missing-out (length missing-out)))) + ;; Note that we use stamp<= instead of stamp< to play nice with generated files. + ;; Any race condition is intrinsic to the limited timestamp resolution. + (if (or just-done ;; The done-stamp is valid: if we're just done, or + ;; if all filesystem effects are up-to-date and there's no invalidating reason. + (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 + 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))))) ;;;; Generic support for plan-traversal @@ -8381,11 +8723,11 @@ the action of OPERATION on COMPONENT in the PLAN")) (:documentation "Detect circular dependencies")) (defmethod initialize-instance :after ((plan plan-traversal) - &key (force () fp) (force-not () fnp) system + &key force force-not system &allow-other-keys) (with-slots (forced forced-not) plan - (when fp (setf forced (normalize-forced-systems force system))) - (when fnp (setf forced-not (normalize-forced-systems force-not system))))) + (setf forced (normalize-forced-systems force system)) + (setf forced-not (normalize-forced-not-systems force-not system)))) (defmethod (setf plan-action-status) (new-status (plan plan-traversal) (o operation) (c component)) (setf (gethash (node-for o c) (plan-visited-actions plan)) new-status)) @@ -8425,42 +8767,63 @@ the action of OPERATION on COMPONENT in the PLAN")) (defgeneric traverse-action (plan operation component needed-in-image-p)) + ;; TRAVERSE-ACTION, in the context of a given PLAN object that accumulates dependency data, + ;; visits the action defined by its OPERATION and COMPONENT arguments, + ;; and all its transitive dependencies (unless already visited), + ;; in the context of the action being (or not) NEEDED-IN-IMAGE-P, + ;; i.e. needs to be done in the current image vs merely have been done in a previous image. + ;; For actions that are up-to-date, it returns a STAMP identifying the state of the action + ;; (that's timestamp, but it could be a cryptographic digest in some ASDF extension), + ;; or T if the action needs to be done again. + ;; + ;; Note that for an XCVB-like plan with one-image-per-file-outputting-action, + ;; the below method would be insufficient, since it assumes a single image + ;; to traverse each node at most twice; non-niip actions would be traversed only once, + ;; but niip nodes could be traversed once per image, i.e. once plus once per non-niip action. + (defmethod traverse-action (plan operation component needed-in-image-p) (block nil + ;; ACTION-VALID-P among other things, handles forcing logic, including FORCE-NOT, + ;; and IF-FEATURE filtering. (unless (action-valid-p plan operation component) (return nil)) + ;; the following hook is needed by POIU, which tracks a full dependency graph, + ;; instead of just a dependency order as in vanilla ASDF (plan-record-dependency plan operation component) - (let* ((aniip (needed-in-image-p operation component)) + ;; needed in image distinguishes b/w things that must happen in the + ;; current image and those things that simply need to have been done in a previous one. + (let* ((aniip (needed-in-image-p operation component)) ; action-specific needed-in-image + ;; effective niip: meaningful for the action and required by the plan as traversed (eniip (and aniip needed-in-image-p)) + ;; status: have we traversed that action previously, and if so what was its status? (status (plan-action-status plan operation component))) (when (and status (or (action-done-p status) (action-planned-p status) (not eniip))) - ;; Already visited with sufficient need-in-image level: just return the stamp. - (return (action-stamp status))) - (labels ((visit-action (niip) - (visit-dependencies plan operation component - #'(lambda (o c) (traverse-action plan o c niip))) - (multiple-value-bind (stamp done-p) - (compute-action-stamp plan operation component) + (return (action-stamp status))) ; Already visited with sufficient need-in-image level! + (labels ((visit-action (niip) ; We may visit the action twice, once with niip NIL, then T + (map-direct-dependencies ; recursively traverse dependencies + plan operation component #'(lambda (o c) (traverse-action plan o c niip))) + (multiple-value-bind (stamp done-p) ; AFTER dependencies have been traversed, + (compute-action-stamp plan operation component) ; compute action stamp (let ((add-to-plan-p (or (eql stamp t) (and niip (not done-p))))) - (cond - ((and add-to-plan-p (not niip)) ;; if we need to do it, - (visit-action t)) ;; then we need to do it in the image! + (cond ; it needs be done if it's out of date or needed in image but absent + ((and add-to-plan-p (not niip)) ; if we need to do it, + (visit-action t)) ; then we need to do it *in the (current) image*! (t - (setf (plan-action-status plan operation component) + (setf (plan-action-status plan operation component) ; update status: (make-instance 'planned-action-status - :stamp stamp - :done-p (and done-p (not add-to-plan-p)) - :planned-p add-to-plan-p - :index (if status - (action-index status) - (incf (plan-total-action-count plan))))) - (when add-to-plan-p - (incf (plan-planned-action-count plan)) - (unless aniip - (incf (plan-planned-output-action-count plan)))) - stamp)))))) + :stamp stamp ; computed stamp + :done-p (and done-p (not add-to-plan-p)) ; done *and* up-to-date? + :planned-p add-to-plan-p ; included in list of things to be done? + :index (if status ; index of action amongst all nodes in traversal + (action-index status) ;; if already visited, keep index + (incf (plan-total-action-count plan))))) ; else new index + (when add-to-plan-p ; if it needs to be added to the plan, + (incf (plan-planned-action-count plan)) ; count it + (unless aniip ; if it's output-producing, + (incf (plan-planned-output-action-count plan)))) ; count it + stamp)))))) ; return the stamp (while-visiting-action (plan operation component) ; maintain context, handle circularity. - (visit-action eniip))))))) + (visit-action eniip))))))) ; visit the action ;;;; Sequential plans (the default) @@ -8474,9 +8837,7 @@ the action of OPERATION on COMPONENT in the PLAN")) (defmethod plan-actions ((plan sequential-plan)) (reverse (plan-actions-r plan))) - (defmethod plan-record-dependency ((plan sequential-plan) - (operation operation) (component component)) - (declare (ignorable plan operation component)) + (defmethod plan-record-dependency ((plan sequential-plan) (o operation) (c component)) (values)) (defmethod (setf plan-action-status) :after @@ -8484,8 +8845,7 @@ the action of OPERATION on COMPONENT in the PLAN")) (when (action-planned-p new-status) (push (cons o c) (plan-actions-r p))))) - -;;;; high-level interface: traverse, perform-plan, plan-operates-on-p +;;;; High-level interface: traverse, perform-plan, plan-operates-on-p (with-upgradability () (defgeneric make-plan (plan-class operation component &key &allow-other-keys) (:documentation @@ -8498,13 +8858,13 @@ the action of OPERATION on COMPONENT in the PLAN")) (defvar *default-plan-class* 'sequential-plan) (defmethod make-plan (plan-class (o operation) (c component) &rest keys &key &allow-other-keys) - (let ((plan (apply 'make-instance - (or plan-class *default-plan-class*) + (let ((plan (apply 'make-instance (or plan-class *default-plan-class*) :system (component-system c) keys))) (traverse-action plan o c t) plan)) (defmethod perform-plan :around ((plan t) &key) + #+xcl (declare (ignorable plan)) (let ((*package* *package*) (*readtable* *readtable*)) (with-compilation-unit () ;; backward-compatibility. @@ -8527,6 +8887,9 @@ the action of OPERATION on COMPONENT in the PLAN")) ;;;; Incidental traversals + +;;; Making a FILTERED-SEQUENTIAL-PLAN can be used to, e.g., all of the source +;;; files required by a bundling operation. (with-upgradability () (defclass filtered-sequential-plan (sequential-plan) ((action-filter :initform t :initarg :action-filter :reader plan-action-filter) @@ -8535,12 +8898,12 @@ the action of OPERATION on COMPONENT in the PLAN")) (keep-component :initform t :initarg :keep-component :reader plan-keep-component))) (defmethod initialize-instance :after ((plan filtered-sequential-plan) - &key (force () fp) (force-not () fnp) + &key force force-not other-systems) (declare (ignore force force-not)) (with-slots (forced forced-not action-filter system) plan - (unless fp (setf forced (normalize-forced-systems (if other-systems :all t) system))) - (unless fnp (setf forced-not (normalize-forced-systems (if other-systems nil :all) system))) + (setf forced (normalize-forced-systems (if other-systems :all t) system)) + (setf forced-not (normalize-forced-not-systems (if other-systems nil t) system)) (setf action-filter (ensure-function action-filter)))) (defmethod action-valid-p ((plan filtered-sequential-plan) o c) @@ -8554,8 +8917,9 @@ the action of OPERATION on COMPONENT in the PLAN")) plan)) (define-convenience-action-methods traverse-sub-actions (operation component &key)) - (defmethod traverse-sub-actions ((operation operation) (component component) &rest keys &key &allow-other-keys) - (apply 'traverse-actions (direct-dependencies operation component) + (defmethod traverse-sub-actions ((operation operation) (component component) + &rest keys &key &allow-other-keys) + (apply 'traverse-actions (direct-dependencies t operation component) :system (component-system component) keys)) (defmethod plan-actions ((plan filtered-sequential-plan)) @@ -8574,15 +8938,15 @@ the action of OPERATION on COMPONENT in the PLAN")) ;;;; ------------------------------------------------------------------------- ;;;; Invoking Operations -(asdf/package:define-package :asdf/operate +(uiop/package:define-package :asdf/operate (:recycle :asdf/operate :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache :asdf/component :asdf/system :asdf/operation :asdf/action :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/plan) (:export #:operate #:oos #:*systems-being-operated* - #:build-system + #:build-op #:make #:load-system #:load-systems #:load-systems* #:compile-system #:test-system #:require-system #:*load-system-operation* #:module-provide-asdf @@ -8596,11 +8960,11 @@ the action of OPERATION on COMPONENT in the PLAN")) 1. It creates an instance of OPERATION-CLASS using any keyword parameters as initargs. 2. It finds the asdf-system specified by SYSTEM (possibly loading it from disk). -3. It then calls TRAVERSE with the operation and system as arguments +3. It then calls MAKE-PLAN with the operation and system as arguments -The traverse operation is wrapped in WITH-COMPILATION-UNIT and error handling code. -If a VERSION argument is supplied, then operate also ensures that the system found -satisfies it using the VERSION-SATISFIES method. +The operation of making a plan is wrapped in WITH-COMPILATION-UNIT and error +handling code. If a VERSION argument is supplied, then operate also ensures +that the system found satisfies it using the VERSION-SATISFIES method. Note that dependencies may cause the operation to invoke other operations on the system or its components: the new operations will be created with the same initargs as the original one. @@ -8626,13 +8990,15 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: &key verbose (on-warnings *compile-file-warnings-behaviour*) (on-failure *compile-file-failure-behaviour*) &allow-other-keys) - (declare (ignorable operation component)) (let* ((systems-being-operated *systems-being-operated*) (*systems-being-operated* (or systems-being-operated (make-hash-table :test 'equal))) - (operation-name (reify-symbol (etypecase operation - (operation (type-of operation)) - (symbol operation)))) - (component-path (typecase component + (operation-remaker ;; how to remake the operation after ASDF was upgraded (if it was) + (etypecase operation + (operation (let ((name (type-of operation)) + (initargs (operation-original-initargs operation))) + #'(lambda () (make-operation name :original-initargs initargs initargs)))) + ((or symbol string) (constantly operation)))) + (component-path (typecase component ;; to remake the component after ASDF upgrade (component (component-find-path component)) (t component)))) ;; Before we operate on any system, make sure ASDF is up-to-date, @@ -8642,11 +9008,9 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: ;; If we were upgraded, restart OPERATE the hardest of ways, for ;; its function may have been redefined, its symbol uninterned, its package deleted. (return-from operate - (apply (find-symbol* 'operate :asdf) - (unreify-symbol operation-name) - component-path keys)))) + (apply 'operate (funcall operation-remaker) component-path keys)))) ;; Setup proper bindings around any operate call. - (with-system-definitions () + (with-asdf-cache () (let* ((*verbose-out* (and verbose *standard-output*)) (*compile-file-warnings-behaviour* on-warnings) (*compile-file-failure-behaviour* on-failure)) @@ -8677,14 +9041,32 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be: (with-upgradability () (defvar *load-system-operation* 'load-op "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP. -You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle, +You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken. -This may change in the future as we will implement component-based strategy -for how to load or compile stuff") +The default operation may change in the future if we implement a +component-directed strategy for how to load or compile systems.") - (defun build-system (system &rest keys) - "Shorthand for `(operate 'asdf:build-op system)`." + (defmethod component-depends-on ((o prepare-op) (s system)) + `((,*load-system-operation* ,@(component-sideway-dependencies s)))) + + (defclass build-op (non-propagating-operation) () + (:documentation "Since ASDF3, BUILD-OP is the recommended 'master' operation, +to operate by default on a system or component, via the function BUILD. +Its meaning is configurable via the :BUILD-OPERATION option of a component. +which typically specifies the name of a specific operation to which to delegate the build, +as a symbol or as a string later read as a symbol (after loading the defsystem-depends-on); +if NIL is specified (the default), BUILD-OP falls back to the *LOAD-SYSTEM-OPERATION* +that will load the system in the current image, and its typically LOAD-OP.")) + (defmethod component-depends-on ((o build-op) (c component)) + `((,(or (component-build-operation c) *load-system-operation*) ,c))) + + (defun make (system &rest keys) + "The recommended way to interact with ASDF3.1 is via (ASDF:MAKE :FOO). +It will build system FOO using the operation BUILD-OP, +the meaning of which is configurable by the system, and +defaults to *LOAD-SYSTEM-OPERATION*, usually LOAD-OP, +to load it in current image." (apply 'operate 'build-op system keys) t) @@ -8730,21 +9112,20 @@ for how to load or compile stuff") (defvar *modules-being-required* nil) (defclass require-system (system) - ((module :initarg :module :initform nil :accessor required-module))) + ((module :initarg :module :initform nil :accessor required-module)) + (:documentation "A SYSTEM subclass whose processing is handled by +the implementation's REQUIRE rather than by internal ASDF mechanisms.")) (defmethod perform ((o compile-op) (c require-system)) - (declare (ignorable o c)) nil) (defmethod perform ((o load-op) (s require-system)) - (declare (ignorable o)) (let* ((module (or (required-module s) (coerce-name s))) (*modules-being-required* (cons module *modules-being-required*))) (assert (null (component-children s))) (require module))) (defmethod resolve-dependency-combination (component (combinator (eql :require)) arguments) - (declare (ignorable component combinator)) (unless (length=n-p arguments 1) (error (compatfmt "~@<Bad dependency ~S for ~S. ~S takes only one argument~@:>") (cons combinator arguments) component combinator)) @@ -8781,178 +9162,788 @@ for how to load or compile stuff") (with-upgradability () (defun restart-upgraded-asdf () ;; If we're in the middle of something, restart it. - (when *systems-being-defined* - (let ((l (loop :for name :being :the :hash-keys :of *systems-being-defined* :collect name))) - (clrhash *systems-being-defined*) + (when *asdf-cache* + (let ((l (loop* :for (x y) :being :the hash-keys :of *asdf-cache* + :when (eq x 'find-system) :collect y))) + (clrhash *asdf-cache*) (dolist (s l) (find-system s nil))))) - (register-hook-function '*post-upgrade-restart-hook* 'restart-upgraded-asdf)) -;;;; ------------------------------------------------------------------------- -;;; Internal hacks for backward-compatibility +;;;; --------------------------------------------------------------------------- +;;;; asdf-output-translations -(asdf/package:define-package :asdf/backward-internals - (:recycle :asdf/backward-internals :asdf) - (:use :uiop/common-lisp :uiop :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) +(uiop/package:define-package :asdf/output-translations + (:recycle :asdf/output-translations :asdf) + (:use :uiop/common-lisp :uiop :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) + +(when-upgrading () (undefine-function '(setf output-translations))) -;;;; Backward compatibility with "inline methods" (with-upgradability () - (defparameter +asdf-methods+ - '(perform-with-restarts perform explain output-files operation-done-p)) + (define-condition invalid-output-translation (invalid-configuration warning) + ((format :initform (compatfmt "~@<Invalid asdf output-translation ~S~@[ in ~S~]~@{ ~@?~}~@:>")))) - (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) + (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.") - (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 () + (car *output-translations*)) - (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 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) + (defun* ((setf output-translations)) (new-value) (set-output-translations new-value)) -;;;; 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 output-translations-initialized-p () + (and *output-translations* t)) -(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 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))))))) -;;;; load-sysdef -(with-upgradability () - (defun load-sysdef (name pathname) - (load-asd pathname :name name)) + (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 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 validate-output-translations-file (file) + (validate-configuration-file + file 'validate-output-translations-form :description "output translations")) + (defun validate-output-translations-directory (directory) + (validate-configuration-directory + directory :output-translations 'validate-output-translations-directive + :invalid-form-reporter 'invalid-output-translation)) -;;;; ------------------------------------------------------------------------- -;;;; Defsystem + (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))))))))) -(asdf/package:define-package :asdf/defsystem - (:recycle :asdf/defsystem :asdf) - (:use :uiop/common-lisp :uiop :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 - #:non-toplevel-system #:non-system-system - #:sysdef-error-component #:check-component-input)) -(in-package :asdf/defsystem) + (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)) -;;; 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))))) + (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/")) -;;; Component class -(with-upgradability () - (defvar *default-component-class* 'cl-source-file) + (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")) - (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)))) + (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)))) -;;; Check inputs -(with-upgradability () - (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* (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 (ensure-function (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 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 pathname) &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) + (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)) + + (defvar *output-translations-parameter* nil) + + (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))) + + (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))) + + ;; 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* (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 uiop'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 + +(uiop/package:define-package :asdf/source-registry + (:recycle :asdf/source-registry :asdf) + (:use :uiop/common-lisp :uiop :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-user-source-registry #:default-system-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) + +(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 + default-user-source-registry + system-source-registry + system-source-registry-directory + default-system-source-registry) + "List of default source registries" "3.1.0.102") + + (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))) + :inherit-configuration + #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) + #+cmu (:tree #p"modules:") + #+scl (:tree #p"file://modules/"))) + (defun default-user-source-registry () + `(:source-registry + (:tree (:home "common-lisp/")) + #+sbcl (:directory (:home ".sbcl/systems/")) + ,@(loop :for dir :in + `(,@(when (os-unix-p) + `(,(or (getenv-absolute-directory "XDG_DATA_HOME") + (subpathname (user-homedir-pathname) ".local/share/")))) + ,@(when (os-windows-p) + (mapcar 'get-folder-path '(:local-appdata :appdata)))) + :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) + :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) + :inherit-configuration)) + (defun default-system-source-registry () + `(:source-registry + ,@(loop :for dir :in + `(,@(when (os-unix-p) + (or (getenv-absolute-directories "XDG_DATA_DIRS") + '("/usr/local/share" "/usr/share"))) + ,@(when (os-windows-p) + (list (get-folder-path :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* (process-source-registry) (spec &key inherit register)) + + (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) + + (defmethod process-source-registry ((x symbol) &key inherit register) + (process-source-registry (funcall x) :inherit inherit :register register)) + (defmethod process-source-registry ((pathname pathname) &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) + (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)))) + + (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)) + + (defvar *source-registry-parameter* nil) + + (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)) + + ;; 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)) + + (defun sysdef-source-registry-search (system) + (ensure-source-registry) + (values (gethash (primary-system-name system) *source-registry*)))) + + +;;;; ------------------------------------------------------------------------- +;;; Internal hacks for backward-compatibility + +(uiop/package:define-package :asdf/backward-internals + (:recycle :asdf/backward-internals :asdf) + (:use :uiop/common-lisp :uiop :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 + #:make-sub-operation + #:load-sysdef #:make-temporary-package)) +(in-package :asdf/backward-internals) + +;;;; Backward compatibility with "inline methods" +(with-upgradability () + (defparameter* +asdf-methods+ + '(perform-with-restarts perform explain output-files operation-done-p)) + + (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 %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 %refresh-component-inline-methods (component rest) + ;; clear methods, then add the new ones + (%remove-component-inline-methods component) + (%define-component-inline-methods component rest))) + +(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))) + + +;;;; load-sysdef +(with-upgradability () + (defun load-sysdef (name pathname) + (load-asd pathname :name name)) + + (defun make-temporary-package () + ;; For loading a .asd file, we don'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)))) + + +;;;; ------------------------------------------------------------------------- +;;;; Defsystem + +(uiop/package:define-package :asdf/parse-defsystem + (:recycle :asdf/parse-defsystem :asdf/defsystem :asdf) + (:nicknames :asdf/defsystem) ;; previous name, to be compatible with, in case anyone cares + (:use :uiop/common-lisp :asdf/driver :asdf/upgrade + :asdf/cache :asdf/component :asdf/system + :asdf/find-system :asdf/find-component :asdf/lisp-action :asdf/operate + :asdf/backward-internals) + (:import-from :asdf/system #:depends-on #:weakly-depends-on) + (:export + #:defsystem #:register-system-definition + #:class-for-type #:*default-component-class* + #:determine-system-directory #:parse-component-form + #:non-toplevel-system #:non-system-system + #:sysdef-error-component #:check-component-input)) +(in-package :asdf/parse-defsystem) + +;;; 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))))) + + +;;; Component class +(with-upgradability () + (defvar *default-component-class* 'cl-source-file) + + (defun class-for-type (parent type) + (or (coerce-class type :package :asdf/interface :super 'component :error nil) + (and (eq type :file) + (coerce-class + (or (loop :for p = parent :then (component-parent p) :while p + :thereis (module-default-component-class p)) + *default-component-class*) + :package :asdf/interface :super 'component :error nil)) + (sysdef-error "don't recognize component type ~S" type)))) + + +;;; Check inputs +(with-upgradability () + (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)))) (define-condition non-toplevel-system (system-definition-error) ((parent :initarg :parent :reader non-toplevel-system-parent) @@ -8983,7 +9974,7 @@ for how to load or compile stuff") (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)) + (unless (if-let (target (find-component parent component)) (builtin-system-p target)) (apply 'warn control args) (invalid)))) (if-let (v (typecase form @@ -9012,6 +10003,32 @@ for how to load or compile stuff") ;;; Main parsing function (with-upgradability () + (defun* parse-dependency-def (dd) + (if (listp dd) + (case (first dd) + (:feature + (unless (= (length dd) 3) + (sysdef-error "Ill-formed feature dependency: ~s" dd)) + (let ((embedded (parse-dependency-def (third dd)))) + `(:feature ,(second dd) ,embedded))) + (feature + (sysdef-error "`feature' has been removed from the dependency spec language of ASDF. Use :feature instead in ~s." dd)) + (:require + (unless (= (length dd) 2) + (sysdef-error "Ill-formed require dependency: ~s" dd)) + dd) + (:version + (unless (= (length dd) 3) + (sysdef-error "Ill-formed version dependency: ~s" dd)) + `(:version ,(coerce-name (second dd)) ,(third dd))) + (otherwise (sysdef-error "Ill-formed dependency: ~s" dd))) + (coerce-name dd))) + + (defun* parse-dependency-defs (dd-list) + "Parse the dependency defs in DD-LIST into canonical form by translating all +system names contained using COERCE-NAME. Return the result." + (mapcar 'parse-dependency-def dd-list)) + (defun* (parse-component-form) (parent options &key previous-serial-component) (destructuring-bind (type name &rest rest &key @@ -9023,7 +10040,7 @@ for how to load or compile stuff") 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)) + (declare (ignore 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) @@ -9049,6 +10066,13 @@ for how to load or compile stuff") (apply 'reinitialize-instance component args) (setf component (apply 'make-instance class args))) (component-pathname component) ; eagerly compute the absolute pathname + (when (typep component 'system) + ;; cache information for introspection + (setf (slot-value component 'depends-on) + (parse-dependency-defs depends-on) + (slot-value component 'weakly-depends-on) + ;; these must be a list of systems, cannot be features or versioned systems + (mapcar 'coerce-name weakly-depends-on))) (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))) @@ -9077,7 +10101,10 @@ for how to load or compile stuff") (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)) + (error "The system definition for ~S uses deprecated ~ + ASDF option :IF-COMPONENT-DEP-FAILS. ~ + Starting with ASDF 3, please use :IF-FEATURE instead" + (coerce-name (component-system component)))) component))) (defun register-system-definition @@ -9088,8 +10115,8 @@ for how to load or compile stuff") ;; 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 () + ;; we also need to remember it in the asdf-cache. + (with-asdf-cache () (let* ((name (coerce-name name)) (source-file (if sfp source-file (resolve-symlinks* (load-pathname)))) (registered (system-registered-p name)) @@ -9099,10 +10126,16 @@ for how to load or compile stuff") (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)) + (component-options + (remove-plist-keys '(:defsystem-depends-on :class) options)) (defsystem-dependencies (loop :for spec :in defsystem-depends-on :collect (resolve-dependency-spec nil spec)))) - (setf (gethash name *systems-being-defined*) system) + ;; cache defsystem-depends-on in canonical form + (when defsystem-depends-on + (setf component-options + (append `(:defsystem-depends-on ,(parse-dependency-defs defsystem-depends-on)) + component-options))) + (set-asdf-cache-entry `(find-system ,name) (list system)) (load-systems* defsystem-dependencies) ;; We change-class AFTER we loaded the defsystem-depends-on ;; since the class might be defined as part of those. @@ -9122,99 +10155,152 @@ for how to load or compile stuff") ;;;; ------------------------------------------------------------------------- ;;;; ASDF-Bundle -(asdf/package:define-package :asdf/bundle +(uiop/package:define-package :asdf/bundle (:recycle :asdf/bundle :asdf) (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation - :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate) + :asdf/action :asdf/lisp-action :asdf/plan :asdf/operate :asdf/defsystem) (:export - #:bundle-op #:bundle-op-build-args #:bundle-type + #:bundle-op #:bundle-type #:program-system #: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 + #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op + #:basic-compile-bundle-op #:prepare-bundle-op + #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op #:lib-op #:monolithic-lib-op #:dll-op #:monolithic-dll-op - #:binary-op #:monolithic-binary-op - #:program-op #:compiled-file #:precompiled-system #:prebuilt-system + #:deliver-asd-op #:monolithic-deliver-asd-op + #:program-op #:image-op #:compiled-file #:precompiled-system #:prebuilt-system #:user-system-p #:user-system #:trivial-system-p - #+ecl #:make-build - #:register-pre-built-system + #:make-build #:build-args #:name-suffix #:prologue-code #:epilogue-code #:static-library)) (in-package :asdf/bundle) (with-upgradability () - (defclass bundle-op (operation) - ((build-args :initarg :args :initform nil :accessor bundle-op-build-args) + (defclass bundle-op (basic-compile-op) + ((build-args :initarg :args :initform nil :accessor extra-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))) + #+ecl (lisp-files :initform nil :accessor extra-object-files))) - (defclass bundle-compile-op (bundle-op basic-compile-op) - () - (:documentation "Abstract operation for ways to bundle the outputs of compiling *Lisp* files")) + (defclass monolithic-op (operation) () + (:documentation "A MONOLITHIC operation operates on a system *and all of its +dependencies*. So, for example, a monolithic concatenate operation will +concatenate together a system's components and all of its dependencies, but a +simple concatenate operation will concatenate only the components of the system +itself.")) ;; operation on a system and its dependencies + + (defclass monolithic-bundle-op (monolithic-op bundle-op) + ;; Old style way of specifying prologue and epilogue on ECL: in the monolithic operation + ((prologue-code :initform nil :accessor prologue-code) + (epilogue-code :initform nil :accessor epilogue-code))) + + (defclass program-system (system) + ;; New style (ASDF3.1) way of specifying prologue and epilogue on ECL: in the system + ((prologue-code :initform nil :initarg :prologue-code :reader prologue-code) + (epilogue-code :initform nil :initarg :epilogue-code :reader epilogue-code) + (no-uiop :initform nil :initarg :no-uiop :reader no-uiop) + (prefix-lisp-object-files :initarg :prefix-lisp-object-files + :initform nil :accessor prefix-lisp-object-files) + (postfix-lisp-object-files :initarg :postfix-lisp-object-files + :initform nil :accessor postfix-lisp-object-files) + (extra-object-files :initarg :extra-object-files + :initform nil :accessor extra-object-files) + (extra-build-args :initarg :extra-build-args + :initform nil :accessor extra-build-args))) + + (defmethod prologue-code ((x t)) nil) + (defmethod epilogue-code ((x t)) nil) + (defmethod no-uiop ((x t)) nil) + (defmethod prefix-lisp-object-files ((x t)) nil) + (defmethod postfix-lisp-object-files ((x t)) nil) + (defmethod extra-object-files ((x t)) nil) + (defmethod extra-build-args ((x t)) nil) + + (defclass link-op (bundle-op) () + (:documentation "Abstract operation for linking files together")) + + (defclass gather-op (bundle-op) + ((gather-op :initform nil :allocation :class :reader gather-op)) + (:documentation "Abstract operation for gathering many input files from a system")) + + (defun operation-monolithic-p (op) + (typep op 'monolithic-op)) + + (defmethod component-depends-on ((o gather-op) (s system)) + (let* ((mono (operation-monolithic-p o)) + (deps + (required-components + s :other-systems mono :component-type (if mono 'system '(not system)) + :goal-operation (find-operation o 'load-op) + :keep-operation 'compile-op))) + ;; NB: the explicit make-operation on ECL and MKCL + ;; ensures that we drop the original-initargs and its magic flags when recursing. + `((,(make-operation (or (gather-op o) (if mono 'lib-op 'compile-op))) ,@deps) + ,@(call-next-method)))) ;; create a single fasl for the entire library - (defclass basic-fasl-op (bundle-compile-op) + (defclass basic-compile-bundle-op (bundle-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 prepare-bundle-op (sideway-operation) + ((sideway-operation :initform #+(or ecl mkcl) 'load-bundle-op #-(or ecl mkcl) 'load-op + :allocation :class))) - (defclass no-ld-flags-op (operation) ()) + (defclass lib-op (link-op gather-op non-propagating-operation) + ((bundle-type :initform :lib)) + (:documentation "compile the system and produce linkable (.a) library for it.")) - (defclass lib-op (bundle-compile-op no-ld-flags-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 compile-bundle-op (basic-compile-bundle-op selfward-operation + #+(or ecl mkcl) link-op #-ecl gather-op) + ((selfward-operation :initform '(prepare-bundle-op #+ecl lib-op) :allocation :class))) - (defclass dll-op (bundle-compile-op selfward-operation no-ld-flags-op) - ((bundle-type :initform :dll)) - (:documentation "compile the system and produce dynamic (.so/.dll) library for it.")) + (defclass load-bundle-op (basic-load-op selfward-operation) + ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))) - (defclass binary-op (basic-compile-op selfward-operation) - ((selfward-operation :initform '(fasl-op lib-op))) - (:documentation "produce fasl and asd files for the system")) + ;; NB: since the monolithic-op's can't be sideway-operation's, + ;; if we wanted lib-op, dll-op, deliver-asd-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-compile-bundle-op above. - (defclass monolithic-op (operation) ()) ;; operation on a system and its dependencies + (defclass dll-op (link-op gather-op non-propagating-operation) + ((bundle-type :initform :dll)) + (:documentation "compile the system and produce dynamic (.so/.dll) library for it.")) - (defclass monolithic-bundle-op (monolithic-op bundle-op) - ((prologue-code :accessor monolithic-op-prologue-code) - (epilogue-code :accessor monolithic-op-epilogue-code))) + (defclass deliver-asd-op (basic-compile-op selfward-operation) + ((selfward-operation :initform '(compile-bundle-op #+(or ecl mkcl) lib-op) :allocation :class)) + (:documentation "produce an asd file for delivering the system as a single fasl")) - (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")) - (defclass monolithic-binary-op (monolithic-op binary-op) - ((selfward-operation :initform '(monolithic-fasl-op monolithic-lib-op))) + (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op) + ((selfward-operation :initform '(monolithic-compile-bundle-op #+(or ecl mkcl) monolithic-lib-op) + :allocation :class)) (:documentation "produce fasl and asd files for combined system and dependencies.")) - (defclass monolithic-fasl-op (monolithic-bundle-compile-op basic-fasl-op) () + (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op + #+(or ecl mkcl) link-op gather-op non-propagating-operation) + ((gather-op :initform #+(or ecl mkcl) 'lib-op #-(or ecl mkcl) 'compile-bundle-op :allocation :class)) (:documentation "Create a single fasl for the system and its dependencies.")) - (defclass monolithic-lib-op (monolithic-bundle-compile-op basic-compile-op no-ld-flags-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.")) + (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op) + ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class)) + (:documentation "Load a single fasl for the system and its dependencies.")) - (defclass monolithic-dll-op (monolithic-bundle-compile-op sideway-operation selfward-operation no-ld-flags-op) + (defclass monolithic-lib-op (monolithic-bundle-op lib-op non-propagating-operation) () + (:documentation "Create a single linkable library for the system and its dependencies.")) + + (defclass monolithic-dll-op (monolithic-bundle-op dll-op non-propagating-operation) ((bundle-type :initform :dll)) (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies.")) - (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)) + (defclass image-op (monolithic-bundle-op selfward-operation + #+(or ecl mkcl) link-op #+(or ecl mkcl) gather-op) + ((bundle-type :initform :image) + (selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class)) + (:documentation "create an image file from the system and its dependencies")) + + (defclass program-op (image-op) + ((bundle-type :initform :program)) (:documentation "create an executable file from the system and its dependencies")) (defun bundle-pathname-type (bundle-type) @@ -9223,31 +10309,33 @@ for how to load or compile stuff") ((or null string) bundle-type) ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") #+ecl - ((member :binary :dll :lib :shared-library :static-library :program :object :program) + ((member :dll :lib :shared-library :static-library :program :object :program) (compile-file-type :type bundle-type)) - ((eql :binary) "image") - ((eql :dll) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) - ((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib"))) + ((member :image) #-allegro "image" #+allegro "dxl") + ((member :dll :shared-library) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll"))) + ((member :lib :static-library) (cond ((os-unix-p) "a") + ((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib")))) ((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe"))))) (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)))))))) + (let ((bundle-type (bundle-type o))) + (unless (or (eq bundle-type :no-output-file) ;; NIL already means something regarding type. + (and (null (input-files o c)) (not (member bundle-type '(:image :program))))) + (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))))))) (defmethod output-files ((o bundle-op) (c system)) (bundle-output-files o c)) #-(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))) + (progn + (defmethod perform ((o image-op) (c system)) + (dump-image (output-file o c) :executable (typep o 'program-op))) + (defmethod perform :before ((o program-op) (c system)) + (setf *image-entry-point* (ensure-function (component-entry-point c))))) (defclass compiled-file (file-component) ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) @@ -9268,45 +10356,37 @@ for how to load or compile stuff") ;;; 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)) - +(with-upgradability () (defmethod initialize-instance :after ((instance bundle-op) &rest initargs &key (name-suffix nil name-suffix-p) &allow-other-keys) - (declare (ignorable initargs name-suffix)) + (declare (ignore 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 + (if (operation-monolithic-p instance) "--all-systems" #-(or ecl mkcl) "--system")))) ; . no good for Logical Pathnames (when (typep instance 'monolithic-bundle-op) - (destructuring-bind (&rest original-initargs - &key lisp-files prologue-code epilogue-code + (destructuring-bind (&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 no-ld-flags-op)) - (declare (ignorable o)) - (let ((args (call-next-method))) - (remf args :ld-flags) - args)) + (setf (prologue-code instance) prologue-code + (epilogue-code instance) epilogue-code) + #-ecl (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code))) + #+ecl (setf (extra-object-files instance) lisp-files))) + (setf (extra-build-args instance) + (remove-plist-keys + '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files + :force :force-not :plan-class) ;; TODO: refactor so we don't mix plan and operation arguments + (operation-original-initargs instance)))) (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)) + #+mkcl (or (equalp type (compile-file-type :fasl-p nil)) + #+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW + #+(and windows (not (or mingw32 mingw64))) (equalp type "lib")) #+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type))))) (defgeneric* (trivial-system-p) (component)) @@ -9328,57 +10408,40 @@ for how to load or compile stuff") ;;; MONOLITHIC SHARED LIBRARIES, PROGRAMS, FASL ;;; (with-upgradability () - (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))) - - (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)))))) + t 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)) + (defmethod input-files ((o gather-op) (c system)) (unless (eq (bundle-type o) :no-output-file) (direct-dependency-files o c :test 'bundlable-file-p :key 'output-files))) (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)) + (if monolithic 'monolithic-compile-bundle-op 'compile-bundle-op)) + ((:image) + 'image-op) ((:program) 'program-op))) + ;; DEPRECATED. This is originally from asdf-ecl.lisp. Does anyone use it? (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) + (ensure-pathname move-here :namestring :lisp :ensure-directory t) (system-relative-pathname system "asdf-output/"))) (operation (apply #'operate operation-name system @@ -9386,7 +10449,7 @@ for how to load or compile stuff") (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)))) + (member operation-name '(:program :image)))) (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) @@ -9394,34 +10457,33 @@ for how to load or compile stuff") :defaults dest-path) :do (rename-file-overwriting-target f new-f) :collect new-f) - files)))) + files))) + + ;; DEPRECATED. Does anyone use this? + (defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys) + (declare (ignore force verbose version)) + (apply #'operate 'deliver-asd-op system args))) ;;; -;;; LOAD-FASL-OP +;;; LOAD-BUNDLE-OP ;;; -;;; This is like ASDF's LOAD-OP, but using monolithic fasl files. +;;; This is like ASDF's LOAD-OP, but using bundle 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) + (defmethod component-depends-on ((o load-bundle-op) (c system)) + `((,o ,@(component-sideway-dependencies c)) + (,(if (user-system-p c) 'compile-bundle-op 'load-op) ,c) ,@(call-next-method))) - (defmethod input-files ((o load-fasl-op) (c system)) + (defmethod input-files ((o load-bundle-op) (c system)) (when (user-system-p c) - (output-files (find-operation o 'fasl-op) c))) + (output-files (find-operation o 'compile-bundle-op) c))) - (defmethod perform ((o load-fasl-op) c) - (declare (ignorable o c)) - nil) - - (defmethod perform ((o load-fasl-op) (c system)) + (defmethod perform ((o load-bundle-op) (c system)) (when (input-files o c) (perform-lisp-load-fasl o c))) - (defmethod mark-operation-done :after ((o load-fasl-op) (c system)) + (defmethod mark-operation-done :after ((o load-bundle-op) (c system)) (mark-operation-done (find-operation o 'load-op) c))) ;;; @@ -9434,20 +10496,13 @@ for how to load or compile stuff") (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 input-files ((o operation) (c compiled-file)) + (list (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)) ;;; @@ -9455,570 +10510,287 @@ for how to load or compile stuff") ;;; (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)) + (defmethod perform ((o link-op) (c prebuilt-system)) nil) - (defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system)) - (declare (ignorable o)) - nil)) - - -;;; -;;; PREBUILT SYSTEM CREATOR -;;; -(with-upgradability () - (defmethod output-files ((o binary-op) (s system)) - (list (make-pathname :name (component-name s) :type "asd" - :defaults (component-pathname s)))) - - (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))))) - - #-(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))))) - - (defmethod input-files ((o load-op) (s precompiled-system)) - (declare (ignorable o)) - (bundle-output-files (find-operation o 'fasl-op) s)) - - (defmethod perform ((o load-op) (s precompiled-system)) - (perform-lisp-load-fasl o s)) - - (defmethod component-depends-on ((o load-fasl-op) (s precompiled-system)) - (declare (ignorable o)) - `((load-op ,s) ,@(call-next-method)))) - - #| ;; 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) -|# - -#+(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)) - - (defun register-pre-built-system (name) - (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))) - -#+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)))))) - -#+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))) - - (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))) - - (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 :uiop/common-lisp :uiop :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) - -;;; -;;; 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) - (let ((a (assoc e other-encodings))) - (if a (push (component-find-path c) (cdr a)) - (push (list a (component-find-path c)) other-encodings))))) - (unless (equal around-compile (around-compile-hook c)) - (push (component-find-path c) other-around-compile)) - (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 - (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x))))) - 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)) - - (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))) - -;;;; --------------------------------------------------------------------------- -;;;; asdf-output-translations - -(asdf/package:define-package :asdf/output-translations - (:recycle :asdf/output-translations :asdf) - (:use :uiop/common-lisp :uiop :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) - -(when-upgrading () (undefine-function '(setf output-translations))) - -(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.") - - (defun output-translations () - (car *output-translations*)) - - (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) - - (defun output-translations-initialized-p () - (and *output-translations* t)) - - (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))))))) - - (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 perform ((o basic-compile-bundle-op) (c prebuilt-system)) + nil) - (defun validate-output-translations-file (file) - (validate-configuration-file - file 'validate-output-translations-form :description "output translations")) + (defmethod perform ((o lib-op) (c prebuilt-system)) + nil) - (defun validate-output-translations-directory (directory) - (validate-configuration-directory - directory :output-translations 'validate-output-translations-directive - :invalid-form-reporter 'invalid-output-translation)) + (defmethod perform ((o dll-op) (c prebuilt-system)) + nil) - (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))))))))) + (defmethod component-depends-on ((o gather-op) (c prebuilt-system)) + nil) - (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)) + (defmethod output-files ((o lib-op) (c prebuilt-system)) + (values (list (prebuilt-system-static-library c)) t))) - (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/")) +;;; +;;; PREBUILT SYSTEM CREATOR +;;; +(with-upgradability () + (defmethod output-files ((o deliver-asd-op) (s system)) + (list (make-pathname :name (component-name s) :type "asd" + :defaults (component-pathname s)))) - (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 perform ((o deliver-asd-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))) + (version (component-version s)) + (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 + t '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 + :version ,version + :depends-on ,depends-on + :components ((:compiled-file ,(pathname-name fasl))) + ,@(when library `(:lib ,(file-namestring library)))) + s) + (terpri s))))) - (defgeneric process-output-translations (spec &key inherit collect)) + #-(or ecl mkcl) + (defmethod perform ((o basic-compile-bundle-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 (or (prologue-code o) (epilogue-code o) + (prologue-code c) (epilogue-code c)) + (error "prologue-code and epilogue-code are not supported on ~A" + (implementation-type))) + (with-staging-pathname (output-file) + (combine-fasls fasl-files output-file))))) - (defun inherit-output-translations (inherit &key collect) - (when inherit - (process-output-translations (first inherit) :collect collect :inherit (rest inherit)))) + (defmethod input-files ((o load-op) (s precompiled-system)) + (bundle-output-files (find-operation o 'compile-bundle-op) s)) - (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 (ensure-function (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 perform ((o load-op) (s precompiled-system)) + (perform-lisp-load-fasl o s)) - (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 load-bundle-op) (s precompiled-system)) + #+xcl (declare (ignorable o)) + `((load-op ,s) ,@(call-next-method)))) - (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)) +#| ;; 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) +|# - (defvar *output-translations-parameter* nil) +#+(or ecl mkcl) +(with-upgradability () + ;; I think that Juanjo intended for this to be, + ;; but beware the weird bug in test-xach-update-bug.script, + ;; and also it makes mkcl fail test-logical-pathname.script, + ;; and ecl fail test-bundle.script. + ;;(unless (or #+ecl (use-ecl-byte-compiler-p)) + ;; (setf *load-system-operation* 'load-bundle-op)) + + (defun asdf-library-pathname () + #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style + (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style + #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf")) + + (defun compiler-library-pathname () + #+ecl (compile-file-pathname "sys:cmp" :type :lib) + #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp")) + + (defun make-library-system (name pathname) + (make-instance 'prebuilt-system + :name (coerce-name name) :static-library (resolve-symlinks* pathname))) + + (defmethod component-depends-on :around ((o image-op) (c system)) + (destructuring-bind ((lib-op . deps)) (call-next-method) + (flet ((has-it-p (x) (find x deps :test 'equal :key 'coerce-name))) + `((,lib-op + ,@(unless (or (no-uiop c) (has-it-p "cmp")) + `(,(make-library-system + "cmp" (compiler-library-pathname)))) + ,@(unless (or (no-uiop c) (has-it-p "uiop") (has-it-p "asdf")) + `(,(cond + ((system-source-directory :uiop) (find-system :uiop)) + ((system-source-directory :asdf) (find-system :asdf)) + (t (make-library-system "asdf" (asdf-library-pathname)))))) + ,@deps))))) + + (defmethod perform ((o link-op) (c system)) + (let* ((object-files (input-files o c)) + (output (output-files o c)) + (bundle (first output)) + (programp (typep o 'program-op)) + (kind (bundle-type o))) + (when output + (apply 'create-image + bundle (append + (when programp (prefix-lisp-object-files c)) + object-files + (when programp (postfix-lisp-object-files c))) + :kind kind + :prologue-code (or (prologue-code o) (when programp (prologue-code c))) + :epilogue-code (or (epilogue-code o) (when programp (epilogue-code c))) + :build-args (or (extra-build-args o) (when programp (extra-build-args c))) + :extra-object-files (or (extra-object-files o) (when programp (extra-object-files c))) + :no-uiop (no-uiop c) + (when programp `(:entry-point ,(component-entry-point c)))))))) + +#+(and (not asdf-use-unsafe-mac-bundle-op) + (or (and ecl darwin) + (and abcl darwin (not abcl-bundle-op-supported)))) +(defmethod perform :before ((o basic-compile-bundle-op) (c component)) + (unless (featurep :asdf-use-unsafe-mac-bundle-op) + (cerror "Continue after modifying *FEATURES*." + "BASIC-COMPILE-BUNDLE-OP operations are not supported on Mac OS X for this lisp.~%~T~ +To continue, push :asdf-use-unsafe-mac-bundle-op onto *FEATURES*.~%~T~ +Please report to ASDF-DEVEL if this works for you."))) + + +;;; Backward compatibility with pre-3.1.1 names +(defclass fasl-op (selfward-operation) + ((selfward-operation :initform 'compile-bundle-op :allocation :class))) +(defclass load-fasl-op (selfward-operation) + ((selfward-operation :initform 'load-bundle-op :allocation :class))) +(defclass binary-op (selfward-operation) + ((selfward-operation :initform 'deliver-asd-op :allocation :class))) +(defclass monolithic-fasl-op (selfward-operation) + ((selfward-operation :initform 'monolithic-compile-bundle-op :allocation :class))) +(defclass monolithic-load-fasl-op (selfward-operation) + ((selfward-operation :initform 'monolithic-load-bundle-op :allocation :class))) +(defclass monolithic-binary-op (selfward-operation) + ((selfward-operation :initform 'monolithic-deliver-asd-op :allocation :class))) +;;;; ------------------------------------------------------------------------- +;;;; Concatenate-source - (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))) +(uiop/package:define-package :asdf/concatenate-source + (:recycle :asdf/concatenate-source :asdf) + (:use :uiop/common-lisp :uiop :asdf/upgrade + :asdf/component :asdf/operation + :asdf/system :asdf/find-system + :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) - (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))) +;;; +;;; 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) ()) - ;; 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))) + (defclass concatenate-source-op (basic-concatenate-source-op non-propagating-operation) ()) + (defclass load-concatenated-source-op (basic-load-concatenated-source-op) + ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))) + (defclass compile-concatenated-source-op (basic-compile-concatenated-source-op) + ((selfward-operation :initform '(prepare-op concatenate-source-op) :allocation :class))) + (defclass load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform '(prepare-op compile-concatenated-source-op) :allocation :class))) - (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))))) + (defclass monolithic-concatenate-source-op (basic-concatenate-source-op monolithic-bundle-op non-propagating-operation) ()) + (defclass monolithic-load-concatenated-source-op (basic-load-concatenated-source-op) + ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))) + (defclass monolithic-compile-concatenated-source-op (basic-compile-concatenated-source-op) + ((selfward-operation :initform 'monolithic-concatenate-source-op :allocation :class))) + (defclass monolithic-load-compiled-concatenated-source-op (basic-load-compiled-concatenated-source-op) + ((selfward-operation :initform 'monolithic-compile-concatenated-source-op :allocation :class))) - ;; Hook into uiop's output-translation mechanism - #-cormanlisp - (setf *output-translation-function* 'apply-output-translations) + (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) + (let ((a (assoc e other-encodings))) + (if a (push (component-find-path c) (cdr a)) + (push (list a (component-find-path c)) other-encodings))))) + (unless (equal around-compile (around-compile-hook c)) + (push (component-find-path c) other-around-compile)) + (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 + (mapcar #'(lambda (x) (cons (car x) (list (reverse (cdr x))))) + 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)) - #+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)))))) + (defmethod perform ((o basic-concatenate-source-op) (s system)) + (let* ((ins (input-files o s)) + (out (output-file o s)) + (tmp (tmpize-pathname out))) + (concatenate-files ins tmp) + (rename-file-overwriting-target tmp out))) + (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))) ;;;; ------------------------------------------------------------------------- ;;; Backward-compatible interfaces -(asdf/package:define-package :asdf/backward-interface +(uiop/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 @@ -10057,16 +10829,16 @@ effectively disabling the output translation facility." (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)) + (defgeneric (setf operation-on-warnings) (x operation)) + (defgeneric (setf operation-on-failure) (x operation)) (defmethod operation-on-warnings ((o operation)) - (declare (ignorable o)) *compile-file-warnings-behaviour*) + *compile-file-warnings-behaviour*) (defmethod operation-on-failure ((o operation)) - (declare (ignorable o)) *compile-file-failure-behaviour*) + *compile-file-failure-behaviour*) (defmethod (setf operation-on-warnings) (x (o operation)) - (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x)) + (setf *compile-file-warnings-behaviour* x)) (defmethod (setf operation-on-failure) (x (o operation)) - (declare (ignorable o)) (setf *compile-file-failure-behaviour* x)) + (setf *compile-file-failure-behaviour* x)) (defun system-definition-pathname (x) ;; As of 2.014.8, we mean to make this function obsolete, @@ -10132,420 +10904,239 @@ processed in order by OPERATE.")) ,@(loop :for pattern :in patterns :collect `((:root ,*wild-inferiors* ,pattern) (,@destination-directory ,pattern))) - (t t) - :ignore-inherited-configuration)))) - - (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.")))) - - -;;; 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. - -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) - (let ((exit-code - (ignore-errors - (nth-value 2 (run-program command :force-shell t :ignore-error-status t - :output *verbose-out*))))) - (typecase exit-code - ((integer 0 255) exit-code) - (t 255)))))) - -(with-upgradability () - (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. - -;; 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 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)) -;;;; ----------------------------------------------------------------- -;;;; 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 :uiop/common-lisp :uiop :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) - -(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)) + (t t) + :ignore-inherited-configuration)))) - (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)))))))))) + (defmethod operate :before (operation-class system &rest args &key &allow-other-keys) + (declare (ignore 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 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)) +;;; 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. - (defparameter *source-registry-file* (parse-unix-namestring "source-registry.conf")) - (defparameter *source-registry-directory* (parse-unix-namestring "source-registry.conf.d/")) +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) + (let ((exit-code + (ignore-errors + (nth-value 2 (run-program command :force-shell t :ignore-error-status t + :output *verbose-out*))))) + (typecase exit-code + ((integer 0 255) exit-code) + (t 255)))))) - (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")) +(with-upgradability () + (defvar *asdf-verbose* nil)) ;; backward-compatibility with ASDF2 only. Unused. - (defgeneric* (process-source-registry) (spec &key inherit register)) +;; 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* (inherit-source-registry) (inherit &key register) - (when inherit - (process-source-registry (first inherit) :register register :inherit (rest inherit)))) + (defmethod component-property ((c component) property) + (cdr (assoc property (slot-value c 'properties) :test #'equal))) - (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) + (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)) +;;;; ------------------------------------------------------------------------- +;;;; Package systems in the style of quick-build or faslpath - (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)))) +(uiop:define-package :asdf/package-inferred-system + (:recycle :asdf/package-inferred-system :asdf/package-system :asdf) + (:use :uiop/common-lisp :uiop + :asdf/defsystem ;; Using the old name of :asdf/parse-defsystem for compatibility + :asdf/upgrade :asdf/component :asdf/system :asdf/find-system :asdf/lisp-action) + (:export + #:package-inferred-system #:sysdef-package-inferred-system-search + #:package-system ;; backward compatibility only. To be removed. + #:register-system-packages + #:*defpackage-forms* #:*package-inferred-systems* #:package-inferred-system-missing-package-error)) +(in-package :asdf/package-inferred-system) - (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)) +(with-upgradability () + (defparameter *defpackage-forms* '(cl:defpackage uiop:define-package)) - ;; 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)) + (defun initial-package-inferred-systems-table () + (let ((h (make-hash-table :test 'equal))) + (dolist (p (list-all-packages)) + (dolist (n (package-names p)) + (setf (gethash n h) t))) + h)) - (defvar *source-registry-parameter* nil) + (defvar *package-inferred-systems* (initial-package-inferred-systems-table)) - (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 package-inferred-system (system) + ()) - ;; 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)) + ;; For backward compatibility only. To be removed in an upcoming release: + (defclass package-system (package-inferred-system) ()) - (defun sysdef-source-registry-search (system) - (ensure-source-registry) - (values (gethash (primary-system-name system) *source-registry*)))) + (defun defpackage-form-p (form) + (and (consp form) + (member (car form) *defpackage-forms*))) + (defun stream-defpackage-form (stream) + (loop :for form = (read stream nil nil) :while form + :when (defpackage-form-p form) :return form)) + (defun file-defpackage-form (file) + "Return the first DEFPACKAGE form in FILE." + (with-input-file (f file) + (stream-defpackage-form f))) + + (define-condition package-inferred-system-missing-package-error (system-definition-error) + ((system :initarg :system :reader error-system) + (pathname :initarg :pathname :reader error-pathname)) + (:report (lambda (c s) + (format s (compatfmt "~@<No package form found while ~ + trying to define package-inferred-system ~A from file ~A~>") + (error-system c) (error-pathname c))))) + + (defun package-dependencies (defpackage-form) + "Return a list of packages depended on by the package +defined in DEFPACKAGE-FORM. A package is depended upon if +the DEFPACKAGE-FORM uses it or imports a symbol from it." + (assert (defpackage-form-p defpackage-form)) + (remove-duplicates + (while-collecting (dep) + (loop* :for (option . arguments) :in (cddr defpackage-form) :do + (ecase option + ((:use :mix :reexport :use-reexport :mix-reexport) + (dolist (p arguments) (dep (string p)))) + ((:import-from :shadowing-import-from) + (dep (string (first arguments)))) + ((:nicknames :documentation :shadow :export :intern :unintern :recycle))))) + :from-end t :test 'equal)) + + (defun package-designator-name (package) + (etypecase package + (package (package-name package)) + (string package) + (symbol (string package)))) + + (defun register-system-packages (system packages) + "Register SYSTEM as providing PACKAGES." + (let ((name (or (eq system t) (coerce-name system)))) + (dolist (p (ensure-list packages)) + (setf (gethash (package-designator-name p) *package-inferred-systems*) name)))) + + (defun package-name-system (package-name) + "Return the name of the SYSTEM providing PACKAGE-NAME, if such exists, +otherwise return a default system name computed from PACKAGE-NAME." + (check-type package-name string) + (if-let ((system-name (gethash package-name *package-inferred-systems*))) + system-name + (string-downcase package-name))) + + (defun package-inferred-system-file-dependencies (file &optional system) + (if-let (defpackage-form (file-defpackage-form file)) + (remove t (mapcar 'package-name-system (package-dependencies defpackage-form))) + (error 'package-inferred-system-missing-package-error :system system :pathname file))) + + (defun same-package-inferred-system-p (system name directory subpath dependencies) + (and (eq (type-of system) 'package-inferred-system) + (equal (component-name system) name) + (pathname-equal directory (component-pathname system)) + (equal dependencies (component-sideway-dependencies system)) + (let ((children (component-children system))) + (and (length=n-p children 1) + (let ((child (first children))) + (and (eq (type-of child) 'cl-source-file) + (equal (component-name child) "lisp") + (and (slot-boundp child 'relative-pathname) + (equal (slot-value child 'relative-pathname) subpath)))))))) + + (defun sysdef-package-inferred-system-search (system) + (let ((primary (primary-system-name system))) + (unless (equal primary system) + (let ((top (find-system primary nil))) + (when (typep top 'package-inferred-system) + (if-let (dir (system-source-directory top)) + (let* ((sub (subseq system (1+ (length primary)))) + (f (probe-file* (subpathname dir sub :type "lisp") + :truename *resolve-symlinks*))) + (when (file-pathname-p f) + (let ((dependencies (package-inferred-system-file-dependencies f system)) + (previous (cdr (system-registered-p system)))) + (if (same-package-inferred-system-p previous system dir sub dependencies) + previous + (eval `(defsystem ,system + :class package-inferred-system + :source-file nil + :pathname ,dir + :depends-on ,dependencies + :components ((cl-source-file "lisp" :pathname ,sub))))))))))))))) + +(with-upgradability () + (pushnew 'sysdef-package-inferred-system-search *system-definition-search-functions*) + (setf *system-definition-search-functions* + (remove (find-symbol* :sysdef-package-system-search :asdf/package-system nil) + *system-definition-search-functions*))) ;;;; --------------------------------------------------------------------------- ;;;; Handle ASDF package upgrade, including implementation-dependent magic. -(asdf/package:define-package :asdf/interface +(uiop/package:define-package :asdf/interface (:nicknames :asdf :asdf-utilities) (:recycle :asdf/interface :asdf) (:unintern - #:*asdf-revision* #:around #:asdf-method-combination - #:do-traverse #:do-dep #:do-one-dep #:visit-action #:component-visited-p - #:split #:make-collector #:loaded-systems ; makes for annoying SLIME completion - #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function + #:output-files-for-system-and-operation) ; ASDF-BINARY-LOCATION function we use to detect ABL (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/cache :asdf/component :asdf/system :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action :asdf/output-translations :asdf/source-registry - :asdf/plan :asdf/operate :asdf/defsystem :asdf/bundle :asdf/concatenate-source - :asdf/backward-internals :asdf/backward-interface) - ;; TODO: automatically generate interface with reexport? + :asdf/plan :asdf/operate :asdf/parse-defsystem :asdf/bundle :asdf/concatenate-source + :asdf/backward-internals :asdf/backward-interface :asdf/package-inferred-system) + ;; Note: (1) we are NOT automatically reexporting everything from previous packages. + ;; (2) we only reexport UIOP functionality when backward-compatibility requires it. (:export - #:defsystem #:find-system #:locate-system #:coerce-name + #:defsystem #:find-system #:locate-system #:coerce-name #:primary-system-name #:oos #:operate #:make-plan #:perform-plan #:sequential-plan - #:system-definition-pathname #:with-system-definitions + #:system-definition-pathname #:search-for-system-definition #:find-component #:component-find-path #:compile-system #:load-system #:load-systems #:load-systems* #:require-system #:test-system #:clear-system #:operation #:make-operation #:find-operation #:upward-operation #:downward-operation #:sideway-operation #:selfward-operation - #:build-system #:build-op + #:non-propagating-operation + #:build-op #:make #: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 + #:input-files #:output-files #:output-file #:perform #:perform-with-restarts #: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 #:monolithic-bundle-op #:precompiled-system #:compiled-file #:bundle-system - #+ecl #:make-build - #: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 + #:program-system #:make-build + #:fasl-op #:load-fasl-op #:monolithic-fasl-op #:binary-op #:monolithic-binary-op + #:basic-compile-bundle-op #:prepare-bundle-op + #:compile-bundle-op #:load-bundle-op #:monolithic-compile-bundle-op #:monolithic-load-bundle-op + #:lib-op #:dll-op #:deliver-asd-op #:program-op #:image-op + #:monolithic-lib-op #:monolithic-dll-op #:monolithic-deliver-asd-op #:concatenate-source-op #:load-concatenated-source-op #:compile-concatenated-source-op @@ -10562,8 +11153,10 @@ system names to pathnames of .asd files") #:file-component #:source-file #:c-source-file #:java-source-file #:cl-source-file #:cl-source-file.cl #:cl-source-file.lsp #:static-file #:doc-file #:html-file - #:file-type - #:source-file-type + #:file-type #:source-file-type + + #:package-inferred-system #:register-system-packages + #:package-system ;; backward-compatibility during migration, to be removed in a further release. #:component-children ; component accessors #:component-children-by-name @@ -10597,13 +11190,16 @@ system names to pathnames of .asd files") #:system-long-name #:system-source-control #:map-systems + #:system-defsystem-depends-on + #:system-depends-on + #:system-weakly-depends-on #:*system-definition-search-functions* ; variables #:*central-registry* #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*resolve-symlinks* - #:*load-system-operation* + #:*load-system-operation* #:*immutable-systems* #:*asdf-verbose* ;; unused. For backward-compatibility only. #:*verbose-out* @@ -10623,6 +11219,8 @@ system names to pathnames of .asd files") #:missing-dependency-of-version #:circular-dependency ; errors #:duplicate-names #:non-toplevel-system #:non-system-system + #:package-inferred-system-missing-package-error + #:operation-definition-warning #:operation-definition-error #:try-recompiling #:retry @@ -10669,25 +11267,25 @@ system names to pathnames of .asd files") ;;;; --------------------------------------------------------------------------- ;;;; ASDF-USER, where the action happens. -(asdf/package:define-package :asdf/user +(uiop/package:define-package :asdf/user (:nicknames :asdf-user) - (:use :asdf/common-lisp :asdf/package :asdf/interface)) + ;; NB: releases before 3.1.1 this :use'd only uiop/package instead of uiop below. + ;; They also :use'd uiop/common-lisp, that reexports common-lisp and is not included in uiop. + ;; ASDF3 releases from 2.27 to 2.31 called uiop asdf-driver and asdf/foo uiop/foo. + ;; ASDF1 and ASDF2 releases (2.26 and earlier) create a temporary package + ;; that only :use's :cl and :asdf + (:use :uiop/common-lisp :uiop :asdf/interface)) ;;;; ----------------------------------------------------------------------- ;;;; ASDF Footer: last words and cleanup -(asdf/package:define-package :asdf/footer +(uiop/package:define-package :asdf/footer (:recycle :asdf/footer :asdf) - (:use :uiop/common-lisp :uiop :asdf/upgrade - :asdf/find-system :asdf/find-component :asdf/operation :asdf/action :asdf/lisp-action - :asdf/operate :asdf/bundle :asdf/concatenate-source - :asdf/output-translations :asdf/source-registry - :asdf/backward-internals :asdf/defsystem :asdf/backward-interface)) + (:use :uiop/common-lisp :uiop :asdf/upgrade :asdf/operate :asdf/bundle)) (in-package :asdf/footer) ;;;; Hook ASDF into the implementation's REQUIRE and other entry points. - +#+(or abcl clisp clozure cmu ecl mkcl sbcl) (with-upgradability () - #+(or abcl clisp clozure cmu ecl mkcl sbcl) (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil))) (eval `(pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions* @@ -10699,7 +11297,7 @@ system names to pathnames of .asd files") #+(or ecl mkcl) (progn - (pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car) + (pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car) #+(or (and ecl win32) (and mkcl windows)) (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal) @@ -10715,7 +11313,7 @@ system names to pathnames of .asd files") (and (first l) (register-pre-built-system (coerce-name name))) (values-list l)))))))) -#+cmu +#+cmu ;; Hook into the CMUCL herald. (with-upgradability () (defun herald-asdf (stream) (format stream " ASDF ~A" (asdf-version))) @@ -10728,13 +11326,13 @@ system names to pathnames of .asd files") (when (boundp 'excl:*warn-on-nested-reader-conditionals*) (setf excl:*warn-on-nested-reader-conditionals* asdf/common-lisp::*acl-warn-save*)) - (dolist (f '(:asdf :asdf2 :asdf3)) (pushnew f *features*)) + (dolist (f '(:asdf :asdf2 :asdf3 :asdf3.1 :asdf-package-system)) (pushnew f *features*)) - (provide :asdf) + ;; Provide both lowercase and uppercase, to satisfy more people, especially LispWorks users. + (provide "asdf") (provide "ASDF") (cleanup-upgraded-asdf)) (when *load-verbose* (asdf-message ";; ASDF, version ~a~%" (asdf-version))) - diff --git a/src/general-info/release-20f.txt b/src/general-info/release-20f.txt index f7a012d..900898a 100644 --- a/src/general-info/release-20f.txt +++ b/src/general-info/release-20f.txt @@ -32,7 +32,7 @@ New in this release: ticket:92) * Changes - * Update to ASDF 3.0.3. + * Update to ASDF 3.1.2. * When *PRINT-CASE* is :DOWNCASE, integers are printed with lowercase letters when needed. * Micro-optimize KERNEL:DOUBLE-FLOAT-BITS for x86/sse2. ----------------------------------------------------------------------- Summary of changes: src/contrib/asdf/asdf.lisp | 5078 +++++++++++++++++++++----------------- src/general-info/release-20f.txt | 2 +- 2 files changed, 2839 insertions(+), 2241 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-02-2-g9be8ccb
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 9be8ccbffdd602b08e0ba12aa59bc0d137dc569d (commit) via b289505a0e52c6c980813467548b20a93c25492b (commit) from c96b5d32cec8300cccfcbcfc25211621a145f527 (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 9be8ccbffdd602b08e0ba12aa59bc0d137dc569d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Feb 7 08:12:40 2014 -0800 Add lisp-unit as a module. Use (require :lisp-unit) (or "lisp-unit") to load lisp-unit. This also allows the regression tests to be self-contained so we don't have to have lisp-unit installed via quicklisp or some other means. Unlike asdf and defsystem, we do not provide a precompiled fasl. code/module.lisp: * Add defmodule forms for lisp-unit contrib/load-lisp-unit.lisp: * Module file to compile and load lisp-unit. diff --git a/src/code/module.lisp b/src/code/module.lisp index 70ccba7..1ba11d8 100644 --- a/src/code/module.lisp +++ b/src/code/module.lisp @@ -148,6 +148,13 @@ (defmodule "asdf" "modules:asdf/asdf") +;; Lisp-unit +(defmodule :lisp-unit + "modules:lisp-unit/load-lisp-unit") + +(defmodule "lisp-unit" + "modules:load-lisp-unit") + ;; Allow user to specify "cmu-contribs" or :cmu-contribs. (defmodule "cmu-contribs" "modules:contrib") diff --git a/src/contrib/load-lisp-unit.lisp b/src/contrib/load-lisp-unit.lisp new file mode 100644 index 0000000..4270cfe --- /dev/null +++ b/src/contrib/load-lisp-unit.lisp @@ -0,0 +1,6 @@ +;; Load lisp-unit +(require "asdf") + +(load "modules:lisp-unit/lisp-unit.asd") + +(asdf:oos 'asdf:load-op :lisp-unit) commit b289505a0e52c6c980813467548b20a93c25492b Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Feb 7 08:09:24 2014 -0800 Import lisp-unit. This is the version from quicklisp which marked it as lisp-unit-20130615-git. No changes. diff --git a/src/contrib/lisp-unit/.gitignore b/src/contrib/lisp-unit/.gitignore new file mode 100644 index 0000000..73f35dd --- /dev/null +++ b/src/contrib/lisp-unit/.gitignore @@ -0,0 +1,5 @@ +# Ignore FASL files +*.fasl +*.lx64fsl +*.dx64fsl +*~ diff --git a/src/contrib/lisp-unit/README.md b/src/contrib/lisp-unit/README.md new file mode 100644 index 0000000..6114a2a --- /dev/null +++ b/src/contrib/lisp-unit/README.md @@ -0,0 +1,75 @@ +## lisp-unit + +*lisp-unit* is a Common Lisp library that supports unit testing. It is +an extension of the [library written by Chris Riesbeck][orig]. There +is a long history of testing packages in Lisp, usually called +"regression" testers. More recent packages in Lisp and other languages +have been inspired by [JUnit for Java][JUnit]. + +[Documentation is located on the project wiki.][wiki] + +### Features + +* Written in portable Common Lisp +* Loadable as a single file +* Loadable with [ASDF][] or [Quicklisp][] +* Simple to define and run tests +* Redfine functions and macros without reloading tests +* Test return values, printed output, macro expansions, and conditions +* Fined grained control over the testing output +* Store all test results in a database object that can be examined +* Group tests by package for modularity +* Group tests using tags +* Signal test completion and return results with the condition. + +### Extensions + +* Floating point predicates +* [Test Anything Protocol][TAP] output + +### How to use lisp-unit + +The core definitions of *lisp-unit* may be used by loading the single +file 'lisp-unit.lisp'. To use the extensions, *lisp-unit* must be +loaded using either [Quicklisp][] or [ASDF][]. + +1. Load (or compile and load) as a single file : `(load "lisp-unit")`. +2. Load using [Quicklisp][] : `(ql:quickload :lisp-unit)`. +3. Load using [ASDF][] : `(asdf:load-system :lisp-unit)`. + +## Version 0.9.5 Features + +No new features, improved the usability based on user feedback. The +list of tests or tags to the following functions is now optional and +defaults to `:ALL`. + +* `(remove-tests [names] [package])` +* `(tagged-tests [tags] [package])` +* `(remove-tags [tags] [package])` +* `(run-tests [names] [package])` +* `(run-tags [tags] [package])` + +## Version 1 Remaining Tasks + +* (1.0.0) Expanded internal testing. + +### Future Features + +* Fixtures +* Test Suites +* Benchmarking tools + +[orig]: <http://www.cs.northwestern.edu/academics/courses/325/readings/lisp-unit.html> + "Original Lisp Unit" +[wiki]: <https://github.com/OdonataResearchLLC/lisp-unit/wiki> + "Lisp Unit Wiki" +[JUnit]: <http://www.junit.org> "JUnit" +[Quicklisp]: <http://www.quicklisp.org> "Quicklisp" +[ASDF]: <http://common-lisp.net/project/asdf/> "ASDF" +[TAP]: <http://testanything.org/> "Test Anything Protocol" + +## 0.9.5 Acknowledgments + +* [Jesse Alama][jessealama] for usability feedback. + +[jessealama]: <https://github.com/jessealama> "Jesse Alama" diff --git a/src/contrib/lisp-unit/extensions/floating-point.lisp b/src/contrib/lisp-unit/extensions/floating-point.lisp new file mode 100644 index 0000000..3df2b06 --- /dev/null +++ b/src/contrib/lisp-unit/extensions/floating-point.lisp @@ -0,0 +1,818 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- +#| + + Floating tests and assertions for LISP-UNIT + + Copyright (c) 2009-2012, Thomas M. Hermann + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation + the rights to use, copy, modify, merge, publish, distribute, sublicense, + and/or sell copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS + OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR + OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + + References + [NumAlgoC] Gisela Engeln-Mullges and Frank Uhlig "Numerical + Algorithms with C", Springer, 1996 + ISBN: 3-540-60530-4 + +|# + +(in-package :lisp-unit) + +;;; Symbols exported from the floating point extension + +;;; Global variables +(export + '(*measure* *epsilon* *significant-figures*)) + +;;; Functions +(export + '(default-epsilon + sumsq sump norm + relative-error relative-error-norm + array-error)) + +;;; Predicates and assertions +(export + '(float-equal assert-float-equal + sigfig-equal assert-sigfig-equal + norm-equal assert-norm-equal + number-equal assert-number-equal + numerical-equal assert-numerical-equal)) + +;;; Utilities +(export + '(complex-random + make-2d-list + make-random-list + make-random-2d-list + make-random-2d-array)) + +;;; Floating point extensions + +(defvar *measure* 1) + +(defvar *epsilon* nil + "Set the error epsilon if the defaults are not acceptable.") + +(defvar *significant-figures* 4 + "Default to 4 significant figures.") + +(defgeneric default-epsilon (value) + (:documentation + "Return the default epsilon for the value.")) + +(defgeneric relative-error (exact approximate) + (:documentation + "Return the relative-error between the 2 quantities.")) + +(defgeneric float-equal (data1 data2 &optional epsilon) + (:documentation + "Return true if the floating point data is equal.")) + +(defgeneric sumsq (data) + (:documentation + "Return the scaling parameter and the sum of the squares of the ~ + data.")) + +(defgeneric sump (data p) + (:documentation + "Return the scaling parameter and the sum of the powers of p of the ~ + data.")) + +(defgeneric norm (data &optional measure) + (:documentation + "Return the element-wise norm of the data.")) + +(defgeneric relative-error-norm (exact approximate &optional measure) + (:documentation + "Return the relative error norm ")) + +(defgeneric norm-equal (data1 data2 &optional epsilon measure) + (:documentation + "Return true if the norm of the data is equal.")) + +(defgeneric sigfig-equal (data1 data2 &optional significant-figures) + (:documentation + "Return true if the data have equal significant figures.")) + +(defgeneric numerical-equal (result1 result2 &key test) + (:documentation + "Return true if the results are numerically equal according to :TEST.")) + +;;; (DEFAULT-EPSILON value) => epsilon +(defmethod default-epsilon ((value float)) + "Return a default epsilon value based on the floating point type." + (typecase value + (short-float (* 2S0 short-float-epsilon)) + (single-float (* 2F0 single-float-epsilon)) + (double-float (* 2D0 double-float-epsilon)) + (long-float (* 2L0 long-float-epsilon)))) + +(defmethod default-epsilon ((value complex)) + "Return a default epsilon value based on the complex type." + (typecase value + ((complex short-float) (* 2S0 short-float-epsilon)) + ((complex single-float) (* 2F0 single-float-epsilon)) + ((complex double-float) (* 2D0 double-float-epsilon)) + ((complex long-float) (* 2L0 long-float-epsilon)) + (t 0))) + +(defmethod default-epsilon ((value list)) + "Return the default epsilon based on contents of the list." + (loop for val in value maximize (default-epsilon val))) + +(defmethod default-epsilon ((value vector)) + "Return the default epsilon based on the contents of the vector." + (loop for val across value maximize (default-epsilon val))) + +(defmethod default-epsilon ((value array)) + "Return the default epsilon based on the contents of the array." + (loop for val across + (make-array + (array-total-size value) + :element-type (array-element-type value) + :displaced-to value) + maximize (default-epsilon val))) + +#| + (RELATIVE-ERROR x y) => float + [NumAlgoC] : Definition 1.3, pg. 2 + modified with Definition 1.1, pg. 1 + + The definition of relative error in this routine is modified from + the Definition 1.3 in [NumAlgoC] for cases when either the exact + or the approximate value equals zero. According to Definition 1.3, + the relative error is identically equal to 1 in those cases. This + function returns the absolute error in those cases. This is more + useful for testing. +|# +(defun %relative-error (exact approximate) + "Return the relative error of the numbers." + (abs (if (or (zerop exact) (zerop approximate)) + (- exact approximate) + (/ (- exact approximate) exact)))) + +(defmethod relative-error ((exact float) (approximate float)) + "Return the error delta between the exact and approximate floating +point value." + (%relative-error exact approximate)) + +(defmethod relative-error ((exact float) (approximate complex)) + "Return the relative error between the float and complex number." + (%relative-error exact approximate)) + +(defmethod relative-error ((exact complex) (approximate float)) + "Return the relative error between the float and complex number." + (%relative-error exact approximate)) + +(defmethod relative-error ((exact complex) (approximate complex)) + "Return the relative error of the complex numbers." + (if (or (typep exact '(complex float)) + (typep approximate '(complex float))) + (%relative-error exact approximate) + (error "Relative error is only applicable to complex values with ~ + floating point parts."))) + +;;; (FLOAT-EQUAL data1 data2 epsilon) => true or false +(defun %float-equal (data1 data2 epsilon) + "Return true if the relative error between the data is less than +epsilon." + (or + (and (zerop data1) (zerop data2)) + (< (%relative-error data1 data2) epsilon))) + +(defmethod float-equal ((data1 float) (data2 float) + &optional (epsilon *epsilon*)) + "Return true if the relative error between data1 and data2 is less +than epsilon." + (%float-equal data1 data2 + (or epsilon (max (default-epsilon data1) + (default-epsilon data2))))) + +(defmethod float-equal ((data1 float) (data2 rational) + &optional (epsilon *epsilon*)) + "Return true if the relative error between data1 and data2 is less +than epsilon." + (%float-equal data1 (float data2 data1) + (or epsilon (default-epsilon data1)))) + +(defmethod float-equal ((data1 rational) (data2 float) + &optional (epsilon *epsilon*)) + "Return true if the relative error between data1 and data2 is less +than epsilon." + (%float-equal (float data1 data2) data2 + (or epsilon (default-epsilon data2)))) + +(defmethod float-equal ((data1 float) (data2 complex) + &optional (epsilon *epsilon*)) + "Return true if the relative error between data1 and data2 is less +than epsilon." + (%float-equal data1 data2 + (or epsilon (max (default-epsilon data1) + (default-epsilon data2))))) + +(defmethod float-equal ((data1 complex) (data2 float) + &optional (epsilon *epsilon*)) + "Return true if the relative error between data1 and data2 is less +than epsilon." + (%float-equal data1 data2 + (or epsilon (max (default-epsilon data1) + (default-epsilon data2))))) + +(defmethod float-equal ((data1 complex) (data2 complex) + &optional (epsilon *epsilon*)) + "Return true if the relative error between data1 and data2 is less +than epsilon." + (< (relative-error data1 data2) + (or epsilon (max (default-epsilon data1) + (default-epsilon data2))))) + +(defun %seq-float-equal (seq1 seq2 epsilon) + "Return true if the element-wise comparison of relative error is +less than epsilon." + (or + (and (null seq1) (null seq2)) + (when (= (length seq1) (length seq2)) + (every + (lambda (d1 d2) (float-equal d1 d2 epsilon)) seq1 seq2)))) + +(defmethod float-equal ((data1 list) (data2 list) + &optional (epsilon *epsilon*)) + "Return true if the lists are equal in length and element-wise +comparison of the relative error is less than epsilon." + (%seq-float-equal data1 data2 epsilon)) + +(defmethod float-equal ((data1 list) (data2 vector) + &optional (epsilon *epsilon*)) + "Return true if the vector and the list are equal in length and +element-wise comparison of the relative error is less than epsilon." + (%seq-float-equal data1 data2 epsilon)) + +(defmethod float-equal ((data1 vector) (data2 list) + &optional (epsilon *epsilon*)) + "Return true if the vector and the list are equal in length and +element-wise comparison of the relative error is less than epsilon." + (%seq-float-equal data1 data2 epsilon)) + +(defmethod float-equal ((data1 vector) (data2 vector) + &optional (epsilon *epsilon*)) + "Return true if the vectors are equal in length and element-wise +comparison of the relative error is less than epsilon." + (%seq-float-equal data1 data2 epsilon)) + +(defmethod float-equal ((data1 array) (data2 array) + &optional (epsilon *epsilon*)) + "Return true if the arrays are equal in length and element-wise +comparison of the relative error is less than epsilon." + (when (equal (array-dimensions data1) + (array-dimensions data2)) + (%seq-float-equal + (make-array (array-total-size data1) + :element-type (array-element-type data1) + :displaced-to data1) + (make-array (array-total-size data2) + :element-type (array-element-type data2) + :displaced-to data2) + epsilon))) + +(defmacro assert-float-equal (expected form &rest extras) + `(expand-assert :equal ,form ,form ,expected ,extras :test #'float-equal)) + +;;; (SUMSQ data) => scale, sumsq +(defmethod sumsq ((data list)) + "Return the scaling parameter and the sum of the squares of the ~ + list." + (let ((scale 0) + (sumsq 1) + (abs-val nil)) + (dolist (elm data (values scale sumsq)) + (when (plusp (setq abs-val (abs elm))) + (if (< scale abs-val) + (setq + sumsq (1+ (* sumsq (expt (/ scale abs-val) 2))) + scale abs-val) + (setq sumsq (+ sumsq (expt (/ elm scale) 2)))))))) + +(defmethod sumsq ((data vector)) + "Return the scaling parameter and the sum of the squares of the ~ + vector." + (let ((scale 0) + (sumsq 1) + (abs-val nil) + (size (length data))) + (dotimes (index size (values scale sumsq)) + (when (plusp (setq abs-val (abs (svref data index)))) + (if (< scale abs-val) + (setq + sumsq (1+ (* sumsq (expt (/ scale abs-val) 2))) + scale abs-val) + (setq + sumsq + (+ sumsq (expt (/ (svref data index) scale) 2)))))))) + +(defmethod sumsq ((data array)) + "Return the scaling parameter and the sum of the squares of the ~ + array." + (sumsq (make-array (array-total-size data) + :element-type (array-element-type data) + :displaced-to data))) + +;;; (SUMP data) => scale, sump +(defmethod sump ((data list) (p real)) + "Return the scaling parameter and the sum of the powers of p of the ~ + data." + (let ((scale 0) + (sump 1) + (abs-val nil)) + (dolist (elm data (values scale sump)) + (when (plusp (setq abs-val (abs elm))) + (if (< scale abs-val) + (setq + sump (1+ (* sump (expt (/ scale abs-val) p))) + scale abs-val) + (setq sump (+ sump (expt (/ elm scale) p)))))))) + +(defmethod sump ((data vector) (p real)) + "Return the scaling parameter and the sum of the powers of p of the ~ + vector." + (let ((scale 0) + (sump 1) + (abs-val nil) + (size (length data))) + (dotimes (index size (values scale sump)) + (when (plusp (setq abs-val (abs (svref data index)))) + (if (< scale abs-val) + (setq + sump (1+ (* sump (expt (/ scale abs-val) p))) + scale abs-val) + (setq + sump + (+ sump (expt (/ (svref data index) scale) p)))))))) + +(defmethod sump ((data array) (p real)) + "Return the scaling parameter and the sum of the powers of p of the ~ + array." + (sump (make-array (array-total-size data) + :element-type (array-element-type data) + :displaced-to data) + p)) + +;;; (NORM data) => float + +(defgeneric %norm (data measure) + (:documentation + "Return the norm of the data according to measure.")) + +(defmethod %norm ((data list) (measure (eql 1))) + "Return the Taxicab norm of the list." + (loop for item in data sum (abs item))) + +(defmethod %norm ((data vector) (measure (eql 1))) + "Return the Taxicab norm of the vector." + (loop for item across data sum (abs item))) + +(defmethod %norm ((data list) (measure (eql 2))) + "Return the Euclidean norm of the list." + (multiple-value-bind (scale sumsq) + (sumsq (map-into (make-array (length data)) #'abs data)) + (* scale (sqrt sumsq)))) + +(defmethod %norm ((data vector) (measure (eql 2))) + "Return the Euclidean norm of the vector." + (multiple-value-bind (scale sumsq) + (sumsq (map-into (make-array (length data)) #'abs data)) + (* scale (sqrt sumsq)))) + +(defmethod %norm ((data list) (measure integer)) + "Return the Euclidean norm of the list." + (multiple-value-bind (scale sump) + (sump (map-into (make-array (length data)) #'abs data) + measure) + (* scale (expt sump (/ measure))))) + +(defmethod %norm ((data vector) (measure integer)) + "Return the Euclidean norm of the vector." + (multiple-value-bind (scale sump) + (sump (map-into (make-array (length data)) #'abs data) + measure) + (* scale (expt sump (/ measure))))) + +(defmethod %norm ((data list) (measure (eql :infinity))) + "Return the infinity, or maximum, norm of the list." + (loop for item in data maximize (abs item))) + +(defmethod %norm ((data vector) (measure (eql :infinity))) + "Return the infinity, or maximum, norm of the vector." + (loop for item across data maximize (abs item))) + +(defmethod norm ((data list) &optional (measure *measure*)) + "Return the norm of the list according to the measure." + (%norm data measure)) + +(defmethod norm ((data vector) &optional (measure *measure*)) + "Return the norm of the vector according to the measure." + (%norm data measure)) + +;;; FIXME : Is the entrywise norm of an array useful or confusing? +(defmethod norm ((data array) &optional (measure *measure*)) + "Return the entrywise norm of the array according to the measure." + (%norm + (make-array + (array-total-size data) + :element-type (array-element-type data) + :displaced-to data) + measure)) + +;;; (RELATIVE-ERROR-NORM exact approximate measure) => float +(defun %relative-error-norm (exact approximate measure) + "Return the relative error norm of the sequences." + (/ (norm (map-into (make-array (length exact)) + (lambda (x1 x2) (abs (- x1 x2))) + exact approximate) measure) + (norm exact measure))) + +(defmethod relative-error-norm ((exact list) (approximate list) + &optional (measure *measure*)) + "Return the relative error norm of the lists." + (if (= (length exact) (length approximate)) + (%relative-error-norm exact approximate measure) + (error "Lists are not equal in length."))) + +(defmethod relative-error-norm ((exact list) (approximate vector) + &optional (measure *measure*)) + "Return the relative error norm of the list and the vector." + (if (= (length exact) (length approximate)) + (%relative-error-norm exact approximate measure) + (error "The list and vector are not equal in length."))) + +(defmethod relative-error-norm ((exact vector) (approximate list) + &optional (measure *measure*)) + "Return the relative error norm of the list and the vector." + (if (= (length exact) (length approximate)) + (%relative-error-norm exact approximate measure) + (error "The list and vector are not equal in length."))) + +(defmethod relative-error-norm ((exact vector) (approximate vector) + &optional (measure *measure*)) + "Return the relative error norm of the vectors." + (if (= (length exact) (length approximate)) + (%relative-error-norm exact approximate measure) + (error "Vectors are not equal in length."))) + +(defmethod relative-error-norm ((exact array) (approximate vector) + &optional (measure *measure*)) + "Return the relative error norm of the arrays." + (if (equal (array-dimensions exact) + (array-dimensions approximate)) + (%relative-error-norm + (make-array (array-total-size exact) + :element-type (array-element-type exact) + :displaced-to exact) + (make-array (array-total-size approximate) + :element-type (array-element-type approximate) + :displaced-to approximate) + measure) + (error "Arrays are not equal dimensions."))) + +;;; (NORM-EQUAL data1 data2 epsilon measure) => boolean +(defun %norm-equal (seq1 seq2 epsilon measure) + "Return true if the relative error norm is less than epsilon." + (or + (and (null seq1) (null seq2)) + (< (%relative-error-norm seq1 seq2 measure) epsilon))) + +(defmethod norm-equal ((data1 list) (data2 list) &optional + (epsilon *epsilon*) (measure *measure*)) + "Return true if the lists are equal in length and the relative error +norm is less than epsilon." + (%norm-equal data1 data2 epsilon measure)) + +(defmethod norm-equal ((data1 list) (data2 vector) &optional + (epsilon *epsilon*) (measure *measure*)) + "Return true if the vector and the list are equal in length and the +relative error norm is less than epsilon." + (%norm-equal data1 data2 epsilon measure)) + +(defmethod norm-equal ((data1 vector) (data2 list) &optional + (epsilon *epsilon*) (measure *measure*)) + "Return true if the vector and the list are equal in length and the +relative error norm is less than epsilon." + (%norm-equal data1 data2 epsilon measure)) + +(defmethod norm-equal ((data1 vector) (data2 vector) &optional + (epsilon *epsilon*) (measure *measure*)) + "Return true if the vectors are equal in length and the relative +error norm is less than epsilon." + (%norm-equal data1 data2 epsilon measure)) + +(defmethod norm-equal ((data1 array) (data2 array) &optional + (epsilon *epsilon*) (measure *measure*)) + "Return true if the arrays are equal in length and the relative +error norm is less than epsilon." + (when (equal (array-dimensions data1) + (array-dimensions data2)) + (%norm-equal + (make-array (array-total-size data1) + :element-type (array-element-type data1) + :displaced-to data1) + (make-array (array-total-size data2) + :element-type (array-element-type data2) + :displaced-to data2) + epsilon measure))) + +(defmacro assert-norm-equal (expected form &rest extras) + `(expand-assert :equal ,form ,form ,expected ,extras :test #'norm-equal)) + +;;; (NORMALIZE-FLOAT significand &optional exponent) => significand,exponent +;;; [NumAlgoC] : Definition 1.7, pg. 4 +;;; +;;; To avoid using 0.1, first 1.0 <= significand < 10. On the final +;;; return, scale 0.1 <= significand < 1. +(defun %normalize-float (significand &optional (exponent 0)) + "Return the normalized floating point number and exponent." + ;;; FIXME : Use the LOOP. + (cond + ((zerop significand) + (values significand 0)) + ((>= (abs significand) 10) + (%normalize-float (/ significand 10.0) (1+ exponent))) + ((< (abs significand) 1) + (%normalize-float (* significand 10.0) (1- exponent))) + (t (values (/ significand 10.0) (1+ exponent))))) + +;;; (SIGFIG-EQUAL float1 float2 significant-figures) => true or false +(defun %sigfig-equal (float1 float2 significant-figures) + "Return true if the floating point numbers have equal significant +figures." + (if (or (zerop float1) (zerop float2)) + (< (abs (+ float1 float2)) (* 5D-1 (expt 1D1 (- significant-figures)))) + (multiple-value-bind (sig1 exp1) (%normalize-float float1) + (multiple-value-bind (sig2 exp2) (%normalize-float float2) + (= (round (* sig1 (expt 1D1 significant-figures))) + (round (* sig2 (expt 1D1 (- significant-figures (- exp1 exp2)))))))))) + +(defmethod sigfig-equal ((data1 float) (data2 float) &optional + (significant-figures *significant-figures*)) + "Return true if the floating point numbers have equal significant +figures." + (%sigfig-equal data1 data2 significant-figures)) + +(defun %seq-sigfig-equal (seq1 seq2 significant-figures) + "Return true if the element-wise comparison is equal to the +specified significant figures." + (or + (and (null seq1) (null seq2)) + (when (= (length seq1) (length seq2)) + (every + (lambda (d1 d2) (sigfig-equal d1 d2 significant-figures)) + seq1 seq2)))) + +(defmethod sigfig-equal ((data1 list) (data2 list) &optional + (significant-figures *significant-figures*)) + "Return true if the lists are equal in length and the element-wise +comparison is equal to significant figures." + (%seq-sigfig-equal data1 data2 significant-figures)) + +(defmethod sigfig-equal ((data1 vector) (data2 list) &optional + (significant-figures *significant-figures*)) + "Return true if the vector and the list are equal in length and the +element-wise comparison is equal to significant figures." + (%seq-sigfig-equal data1 data2 significant-figures)) + +(defmethod sigfig-equal ((data1 list) (data2 vector) &optional + (significant-figures *significant-figures*)) + "Return true if the list and the vector are equal in length and the +element-wise comparison is equal to significant figures." + (%seq-sigfig-equal data1 data2 significant-figures)) + +(defmethod sigfig-equal ((data1 vector) (data2 vector) &optional + (significant-figures *significant-figures*)) + "Return true if the vectors are equal in length and the element-wise +comparison is equal to significant figures." + (%seq-sigfig-equal data1 data2 significant-figures)) + +(defmethod sigfig-equal ((data1 array) (data2 array) &optional + (significant-figures *significant-figures*)) + "Return true if the arrays are equal in length and the element-wise +comparison is equal to significant figures." + (when (equal (array-dimensions data1) + (array-dimensions data2)) + (%seq-sigfig-equal + (make-array (array-total-size data1) + :element-type (array-element-type data1) + :displaced-to data1) + (make-array (array-total-size data2) + :element-type (array-element-type data2) + :displaced-to data2) + significant-figures))) + +(defmacro assert-sigfig-equal (expected form &rest extras) + `(expand-assert :equal ,form ,form ,expected ,extras :test #'sigfig-equal)) + +;;; (NUMBER-EQUAL number1 number2) => true or false +(defun number-equal (number1 number2 &optional (epsilon *epsilon*) type-eq-p) + "Return true if the numbers are equal within some epsilon, +optionally requiring the types to be identical." + (and + (or (not type-eq-p) (eq (type-of number1) (type-of number2))) + (float-equal (coerce number1 '(complex double-float)) + (coerce number2 '(complex double-float)) + epsilon))) + +(defmacro assert-number-equal (expected form &rest extras) + `(expand-assert :equal ,form ,form ,expected ,extras :test #'number-equal)) + +;;; (NUMERICAL-EQUAL result1 result2) => true or false +;;; +;;; This is a universal wrapper created by Liam Healy. It is +;;; implemented to support testing in GSLL. The interface is expanded, +;;; but backwards compatible with previous versions. +;;; +(defmethod numerical-equal ((result1 number) (result2 number) + &key (test #'number-equal)) + "Return true if the the numbers are equal according to :TEST." + (funcall test result1 result2)) + +(defun %sequence-equal (seq1 seq2 test) + "Return true if the sequences are equal in length and each element +is equal according to :TEST." + (when (= (length seq1) (length seq2)) + (every (lambda (s1 s2) (numerical-equal s1 s2 :test test)) + seq1 seq2))) + +(defmethod numerical-equal ((result1 list) (result2 list) + &key (test #'number-equal)) + "Return true if the lists are equal in length and each element is +equal according to :TEST." + (%sequence-equal result1 result2 test)) + +(defmethod numerical-equal ((result1 vector) (result2 vector) + &key (test #'number-equal)) + "Return true if the vectors are equal in length and each element is +equal according to :TEST." + (%sequence-equal result1 result2 test)) + +(defmethod numerical-equal ((result1 list) (result2 vector) + &key (test #'number-equal)) + "Return true if every element of the list is equal to the +corresponding element of the vector." + (%sequence-equal result1 result2 test)) + +(defmethod numerical-equal ((result1 vector) (result2 list) + &key (test #'number-equal)) + "Return true if every element of the list is equla to the +corresponding element of the vector." + (%sequence-equal result1 result2 test)) + +(defmethod numerical-equal ((result1 array) (result2 array) + &key (test #'number-equal)) + "Return true if the arrays are equal in dimension and each element +is equal according to :TEST." + (when (equal (array-dimensions result1) (array-dimensions result2)) + (every test + (make-array (array-total-size result1) + :element-type (array-element-type result1) + :displaced-to result1) + (make-array (array-total-size result2) + :element-type (array-element-type result2) + :displaced-to result2)))) + +(defmacro assert-numerical-equal (expected form &rest extras) + `(expand-assert :equal ,form ,form ,expected ,extras :test #'numerical-equal)) + +;;; FIXME : Audit and move the diagnostic functions to a separate +;;; file. + +;;; Diagnostic functions +;;; Failing a unit test is only half the problem. + +;;; Sequence errors and the indices. +(defun %sequence-error (sequence1 sequence2 test error-function) + "Return a sequence of the indice and error between the sequences." + (let ((n1 nil) (n2 nil) + (errseq '())) + (dotimes (index (length sequence1) errseq) + (setf n1 (elt sequence1 index) + n2 (elt sequence2 index)) + (unless (funcall test n1 n2) + (push (list (1- index) n1 n2 (funcall error-function n1 n2)) + errseq))))) + +(defun sequence-error (sequence1 sequence2 &key + (test #'number-equal) + (error-function #'relative-error)) + "Return a sequence of the indice and error between the sequence elements." + (cond + ((not (typep sequence1 'sequence)) + (error "SEQUENCE1 is not a valid sequence.")) + ((not (typep sequence2 'sequence)) + (error "SEQUENCE2 is not a valid sequence.")) + ((not (= (length sequence1) (length sequence2))) + (error "Lengths not equal. SEQUENCE1(~D) /= SEQUENCE2(~D)." + (length sequence1) (length sequence2))) + (t (%sequence-error sequence1 sequence2 test error-function)))) + +;;; Array errors and the indices. +(defun %array-indices (row-major-index dimensions) + "Recursively calculate the indices from the row major index." + (let ((remaining (rest dimensions))) + (if remaining + (multiple-value-bind (index remainder) + (floor row-major-index (reduce #'* remaining)) + (cons index (%array-indices remainder remaining))) + (cons row-major-index nil)))) + +(defun %array-error (array1 array2 test errfun) + "Return a list of the indices, values and error of the elements that +are not equal." + (let ((dimensions (array-dimensions array1)) + (n1 nil) (n2 nil) + (indices '()) + (errseq '())) + (dotimes (index (array-total-size array1) errseq) + (setf indices (%array-indices index dimensions) + n1 (apply #'aref array1 indices) + n2 (apply #'aref array2 indices)) + (unless (funcall test n1 n2) + (push (list indices n1 n2 (funcall errfun n1 n2)) + errseq))))) + +(defun array-error (array1 array2 &key + (test #'number-equal) + (error-function #'relative-error)) + "Return a list of the indices and error between the array elements." + (cond + ((not (arrayp array1)) + (error "ARRAY1 is not an array.")) + ((not (arrayp array2)) + (error "ARRAY2 is not an array.")) + ((not (equal (array-dimensions array1) (array-dimensions array2))) + (error "Arrays are not equal dimensions.")) + (t (%array-error array1 array2 test error-function)))) + +;;; Floating point data functions +(defun make-2d-list (rows columns &key (initial-element 0)) + "Return a nested list with INITIAL-ELEMENT." + (mapcar (lambda (x) (make-list columns :initial-element x)) + (make-list rows :initial-element initial-element))) + +(defun %complex-float-random (limit &optional (state *random-state*)) + "Return a random complex float number." + (complex + (random (realpart limit) state) + (random (imagpart limit) state))) + +(defun %complex-rational-random (limit &optional (state *random-state*)) + "Return a random complex rational number." + (let ((imaglimit (imagpart limit))) + (if (< 1 imaglimit) + (complex + (random (realpart limit) state) + ;; Ensure that the imaginary part is not zero. + (do ((im (random imaglimit state) + (random imaglimit state))) + ((< 0 im) im))) + (error "Imaginary part must be greater than 1.")))) + +(defun complex-random (limit &optional (state *random-state*)) + "Return a random complex number. " + (check-type limit complex) + (if (typep limit '(complex rational)) + (%complex-rational-random limit state) + (%complex-float-random limit state))) + +(defun make-random-list (size &optional (limit 1.0)) + "Return a list of random numbers." + (mapcar (if (complexp limit) #'complex-random #'random) + (make-list size :initial-element limit))) + +(defun make-random-2d-list (rows columns &optional (limit 1.0)) + "Return a nested list of random numbers." + (mapcar (lambda (x) (make-random-list columns x)) + (make-list rows :initial-element limit))) + +(defun make-random-2d-array (rows columns &optional (limit 1.0)) + "Return a 2D array of random numbers." + (let ((new-array (make-array (list rows columns) + :element-type (type-of limit))) + (random-func (if (complexp limit) + #'complex-random + #'random))) + (dotimes (i0 rows new-array) + (dotimes (i1 columns) + (setf (aref new-array i0 i1) + (funcall random-func limit)))))) diff --git a/src/contrib/lisp-unit/extensions/rational.lisp b/src/contrib/lisp-unit/extensions/rational.lisp new file mode 100644 index 0000000..43403a6 --- /dev/null +++ b/src/contrib/lisp-unit/extensions/rational.lisp @@ -0,0 +1,96 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- +#| + + Rational tests and assertions for LISP-UNIT + + Copyright (c) 2009-2012, Thomas M. Hermann + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation + the rights to use, copy, modify, merge, publish, distribute, sublicense, + and/or sell copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS + OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR + OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + +|# + +(in-package :lisp-unit) + +;;; Symbols exported from the rational extension + +(export '(rational-equal assert-rational-equal)) + +;;; Rational predicates and assertions + +(defgeneric rational-equal (data1 data2) + (:documentation + "Return true if the rational data is equal.")) + +;;; (RATIONAL-EQUAL data1 data2) => boolean +(defmethod rational-equal ((data1 rational) (data2 rational)) + "Return true if the rational numbers are equal." + (= data1 data2)) + +(defmethod rational-equal ((data1 complex) (data2 complex)) + "Return true if the complex parts are rational and equal." + (if (and (typep data1 '(complex rational)) + (typep data2 '(complex rational))) + (= data1 data2) + (error "Rational equality is not applicable to complex values ~ + with floating point parts."))) + +(defun %seq-rational-equal (seq1 seq2) + "Return true if the sequences are equal length and at each position +the corresponding elements are equal." + (or + (and (null seq1) (null seq2)) + (and + (= (length seq1) (length seq2)) + (every (lambda (d1 d2) (rational-equal d1 d2)) seq1 seq2)))) + +(defmethod rational-equal ((data1 list) (data2 list)) + "Return true if the lists are equal in length and element-wise +equal." + (%seq-rational-equal data1 data2)) + +(defmethod rational-equal ((data1 list) (data2 vector)) + "Return true if the vector and the list are equal in length and +element-wise equal." + (%seq-rational-equal data1 data2)) + +(defmethod rational-equal ((data1 vector) (data2 list)) + "Return true if the vector and the list are equal in length and +element-wise equal." + (%seq-rational-equal data1 data2)) + +(defmethod rational-equal ((data1 vector) (data2 vector)) + "Return true if the vectors are equal in length and element-wise +equal." + (%seq-rational-equal data1 data2)) + +(defmethod rational-equal ((data1 array) (data2 array)) + "Return true if the arrays are equal in dimension and element-wise +equal." + (when (equal (array-dimensions data1) + (array-dimensions data2)) + (%seq-rational-equal + (make-array (array-total-size data1) + :element-type (array-element-type data1) + :displaced-to data1) + (make-array (array-total-size data2) + :element-type (array-element-type data2) + :displaced-to data2)))) + +(defmacro assert-rational-equal (expected form &rest extras) + `(expand-assert :equal ,form ,form ,expected ,extras :test #'rational-equal)) diff --git a/src/contrib/lisp-unit/extensions/test-anything-protocol.lisp b/src/contrib/lisp-unit/extensions/test-anything-protocol.lisp new file mode 100644 index 0000000..09653f8 --- /dev/null +++ b/src/contrib/lisp-unit/extensions/test-anything-protocol.lisp @@ -0,0 +1,86 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- +#| + + Test Anything Protocol (TAP) support for LISP-UNIT + + Copyright (c) 2009-2013, Ryan Davis <ryan(a)acceleration.net> + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation + the rights to use, copy, modify, merge, publish, distribute, sublicense, + and/or sell copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS + OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR + OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + + References + [TAP]: http://testanything.org/wiki/index.php/Main_Page + +|# + +(in-package :lisp-unit) + +;;; Symbols exported from the TAP extension + +(export '(write-tap write-tap-to-file)) + +(defun run-time-s (test-result) + "calculate the run-time of the test in seconds" + (/ (run-time test-result) + internal-time-units-per-second)) + +(defun %write-tap-test-result (name test-result i stream) + "Output a single test, taking care to ensure the indentation level +is the same before and after invocation." + (pprint-logical-block (stream nil) + (format stream + "~:[ok~;not ok~] ~d ~s (~,2f s)" + (or (fail test-result) + (exerr test-result)) + i name + (run-time-s test-result)) + (when (or (fail test-result) + (exerr test-result)) + ;; indent only takes affect after a newline, so force one + (format stream "~2I~:@_---~@:_") + (when (exerr test-result) + (format stream "message: |~4I~_~s~2I~@:_" (exerr test-result))) + (when (fail test-result) + (format stream "message: ~d failed assertions~@:_" + (length (fail test-result)))) + (format stream "...")) + ;; always reset to zero and force a newline + (format stream "~0I~@:_"))) + +(defun write-tap (test-results &optional (stream *standard-output*)) + "Write the test results to `stream` in TAP format. Returns the test +results." + (check-type test-results test-results-db) + (let ((i 0) + (*print-pretty* T)) + (format stream "TAP version 13~%1..~d~%" + (hash-table-count (database test-results))) + (maphash + #'(lambda (name test-result) + (%write-tap-test-result name test-result (incf i) stream)) + (database test-results))) + test-results) + +(defun write-tap-to-file (test-results path) + "write the test results to `path` in TAP format, overwriting `path`. +Returns pathname to the output file" + (check-type path (or string pathname)) + (ensure-directories-exist path) + (with-open-file (s path :direction :output :if-exists :supersede) + (write-tap test-results s)) + (truename path)) diff --git a/src/contrib/lisp-unit/internal-test/example-tests.lisp b/src/contrib/lisp-unit/internal-test/example-tests.lisp new file mode 100644 index 0000000..6312be0 --- /dev/null +++ b/src/contrib/lisp-unit/internal-test/example-tests.lisp @@ -0,0 +1,153 @@ +#| + + LISP-UNIT Example Tests + + Copyright (c) 2010-2012, Thomas M. Hermann + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + o Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + o Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + o The names of the contributors may not be used to endorse or promote + products derived from this software without specific prior written + permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +|# + +(in-package :lisp-unit) + +(defun my-max (x y) + "Deliberately wrong" + (declare (ignore y)) + x) + +(define-test test-my-max + ;; Wrong + (assert-equal 5 (my-max 2 5)) + (assert-equal 5 (my-max 5 2)) + (assert-equal 10 (my-max 10 10)) + (assert-equal 0 (my-max -5 0)) + ;; Error + (assert-equal 5 (my-max-err 2 5))) + +(defun my-sqrt (n) + "Not really." + (/ n 2)) + +(define-test my-sqrt + (dotimes (i 5) + (assert-equal i (my-sqrt (* i i)) i))) + +;;; Macro + +(defmacro my-macro (arg1 arg2) + (let ((g1 (gensym)) + (g2 (gensym))) + `(let ((,g1 ,arg1) + (,g2 ,arg2)) + "Start" + (+ ,g1 ,g2 3)))) + +(define-test test-macro + (assert-expands + (let ((#:G1 A) (#:G2 B)) "Start" (+ #:G1 #:G2 3)) + (my-macro a b))) + +;;; Tags + +(defun add-integer (integer1 integer2) + "Add 2 integer numbers" + (check-type integer1 integer) + (check-type integer2 integer) + (+ integer1 integer2)) + +(defun subtract-integer (integer1 integer2) + "Subtract 2 integer numbers" + (check-type integer1 integer) + (check-type integer2 integer) + (- integer1 integer2)) + +(define-test add-integer + "Test add-integer for values and errors." + (:tag :add :integer) + (assert-eql 3 (add-integer 1 2)) + (assert-error 'type-error (add-integer 1.0 2)) + (assert-error 'type-error (add-integer 1 2.0))) + +(define-test subtract-integer + "Test subtract-integer for values and errors." + (:tag :subtract :integer) + (assert-eql 1 (subtract-integer 3 2)) + (assert-error 'type-error (subtract-integer 3.0 2)) + (assert-error 'type-error (subtract-integer 2 3.0))) + +(defun add-float (float1 float2) + "Add 2 floating point numbers" + (check-type float1 float) + (check-type float2 float) + (+ float1 float2)) + +(defun subtract-float (float1 float2) + "Subtract 2 floating point numbers" + (check-type float1 float) + (check-type float2 float) + (- float1 float2)) + +(define-test add-float + "Test add-float for values and errors." + (:tag :add :float) + (assert-eql 3.0 (add-float 1.0 2.0)) + (assert-error 'type-error (add-float 1.0 2)) + (assert-error 'type-error (add-float 1 2.0))) + +(define-test subtract-float + "Test subtract-float for values and errors." + (:tag :subtract :float) + (assert-eql 1.0 (subtract-float 3.0 2.0)) + (assert-error 'type-error (subtract-float 3.0 2)) + (assert-error 'type-error (subtract-float 2 3.0))) + +(defun add-complex (complex1 complex2) + "Add 2 complex numbers" + (check-type complex1 complex) + (check-type complex2 complex) + (+ complex1 complex2)) + +(defun subtract-complex (complex1 complex2) + "Subtract 2 complex numbers" + (check-type complex1 complex) + (check-type complex2 complex) + (- complex1 complex2)) + +(define-test add-complex + "Test add-complex for values and errors." + (:tag :add :complex) + (assert-eql #C(3 5) (add-complex #C(1 2) #C(2 3))) + (assert-error 'type-error (add-integer #C(1 2) 3)) + (assert-error 'type-error (add-integer 1 #C(2 3)))) + +(define-test subtract-complex + "Test subtract-complex for values and errors." + (:tag :subtract :complex) + (assert-eql #C(1 2) (subtract-complex #C(3 5) #C(2 3))) + (assert-error 'type-error (subtract-integer #C(3 5) 2)) + (assert-error 'type-error (subtract-integer 2 #C(2 3)))) diff --git a/src/contrib/lisp-unit/internal-test/floating-point.lisp b/src/contrib/lisp-unit/internal-test/floating-point.lisp new file mode 100644 index 0000000..2c89e58 --- /dev/null +++ b/src/contrib/lisp-unit/internal-test/floating-point.lisp @@ -0,0 +1,115 @@ +#| + + LISP-UNIT Floating Point Tests + + Copyright (c) 2010-2012, Thomas M. Hermann + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + o Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + o Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + o The names of the contributors may not be used to endorse or promote + products derived from this software without specific prior written + permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +|# + +(in-package :lisp-unit) + +;;; List norms + +(define-test %norm-list + "Internal test of %norm on lists." + (:tag :norm) + ;; Taxicab norm + (assert-rational-equal + 36 (%norm '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 1)) + (assert-float-equal + 19.535658 + (%norm + '(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) + 1)) + ;; Euclidean norm + (assert-float-equal + 12.083046 + (%norm '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 2)) + (assert-float-equal + 8.0 + (%norm + '(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) 2)) + ;; P-norm + (let ((data '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5)) + (zdata '(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)))) + (assert-float-equal 8.732892 (%norm data 3)) + (assert-float-equal 6.064035 (%norm zdata 3))) + ;; Infinity norm + (assert-rational-equal + 6 (%norm + '(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) + :infinity)) + (assert-float-equal + 4.0 (%norm + '(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) + :infinity))) + +;;; Vector norms + +(define-test %norm-vector + "Internal test of %norm on vectors" + (:tag :norm) + ;; Taxicab norm + (assert-rational-equal + 36 (%norm #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 1)) + (assert-float-equal + 19.535658 + (%norm + #(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) + 1)) + ;; Euclidean norm + (assert-float-equal + 12.083046 + (%norm #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) 2)) + (assert-float-equal + 8.0 + (%norm + #(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) + 2)) + ;; P-norm + (let ((data #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5)) + (zdata #(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)))) + (assert-float-equal 8.732892 (%norm data 3)) + (assert-float-equal 6.064035 (%norm zdata 3))) + ;; Infinity norm + (assert-rational-equal + 6 (%norm #(-6 -5 -4 -3 -2 -1 0 1 2 3 4 5) :infinity)) + (assert-float-equal + 4.0 (%norm + #(#C(1 0) #C(3 1) #C(2 3) #C(0 4) + #C(-2 3) #C(-3 1) #C(-1 0)) + :infinity))) diff --git a/src/contrib/lisp-unit/internal-test/fundamental-assertions.lisp b/src/contrib/lisp-unit/internal-test/fundamental-assertions.lisp new file mode 100644 index 0000000..818d401 --- /dev/null +++ b/src/contrib/lisp-unit/internal-test/fundamental-assertions.lisp @@ -0,0 +1,170 @@ +#| + + LISP-UNIT Internal Tests + + Copyright (c) 2010-2012, Thomas M. Hermann + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + o Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + o Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + o The names of the contributors may not be used to endorse or promote + products derived from this software without specific prior written + permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS + "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT + LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +|# + +(in-package :lisp-unit) + +;;; Internal utility functions + +(defun %expansion-equal (form1 form2) + "Descend into the forms checking for equality." + (let ((item1 (first form1)) + (item2 (first form2))) + (cond + ((and (null item1) (null item2))) + ((and (listp item1) (listp item2)) + (and (%expansion-equal item1 item2) + (%expansion-equal (rest form1) (rest form2)))) + ((and (symbolp item1) (symbolp item2)) + (and (string= (symbol-name item1) (symbol-name item2)) + (%expansion-equal (rest form1) (rest form2)))) + (t nil)))) + +(defun expansion-equal (macro-form expansion) + "MACROEXPAND-1 the macro-form and compare with the expansion." + (let ((*gensym-counter* 1)) + (%expansion-equal (macroexpand-1 macro-form) expansion))) + +(defun test-macro-expansions (expansions) + "Test each fundamental assertion and report the results." + (loop for (assertion macro-form expansion) in expansions collect + (list assertion (expansion-equal macro-form expansion)))) + +;;; Expansions + +(defvar *expand-assert-expansions* + '(("EXPAND-ASSERT-BASIC" + (expand-assert + :equal form form expected (extra1 extra2) :test #'eq) + (INTERNAL-ASSERT :EQUAL + (QUOTE FORM) + (LAMBDA NIL FORM) + (LAMBDA NIL EXPECTED) + (EXPAND-EXTRAS (EXTRA1 EXTRA2)) + (FUNCTION EQ))) + ("EXPAND-ASSERT-ERROR" + (expand-assert + :error form (expand-error-form form) condition (extra1 extra2)) + (INTERNAL-ASSERT :ERROR + (QUOTE FORM) + (LAMBDA NIL (HANDLER-CASE FORM (CONDITION (ERROR) ERROR))) + (LAMBDA NIL (QUOTE CONDITION)) + (EXPAND-EXTRAS (EXTRA1 EXTRA2)) + (FUNCTION EQL))) + ("EXPAND-ASSERT-MACRO" + (expand-assert + :macro form + (expand-macro-form form nil) + expansion (extra1 extra2)) + (INTERNAL-ASSERT :MACRO + (QUOTE FORM) + (LAMBDA NIL (MACROEXPAND-1 (QUOTE FORM) NIL)) + (LAMBDA NIL EXPANSION) + (EXPAND-EXTRAS (EXTRA1 EXTRA2)) + (FUNCTION EQL))) + ("EXPAND-ASSERTS-PRINT" + (expand-assert + :output form (expand-output-form form) output (extra1 extra2)) + (INTERNAL-ASSERT :OUTPUT + (QUOTE FORM) + (LAMBDA NIL + (LET* ((#:G1 (MAKE-STRING-OUTPUT-STREAM)) + (*STANDARD-OUTPUT* (MAKE-BROADCAST-STREAM + *STANDARD-OUTPUT* #:G1))) + FORM + (GET-OUTPUT-STREAM-STRING #:G1))) + (LAMBDA NIL OUTPUT) + (EXPAND-EXTRAS (EXTRA1 EXTRA2)) + (FUNCTION EQL)))) + "The correct expansions for the expand-assert macro.") + +(defvar *expansion-macros* + '(("EXPAND-ERROR-FORM" + (expand-error-form form) + (HANDLER-CASE FORM (CONDITION (ERROR) ERROR))) + ("EXPAND-OUTPUT-FORM" + (expand-output-form form) + (LET* ((#:G1 (MAKE-STRING-OUTPUT-STREAM)) + (*STANDARD-OUTPUT* + (MAKE-BROADCAST-STREAM *STANDARD-OUTPUT* #:G1))) + FORM + (GET-OUTPUT-STREAM-STRING #:G1))) + ("EXPAND-MACRO-FORM" + (expand-macro-form form env) + (MACROEXPAND-1 'FORM ENV)) + ("EXPAND-EXTRAS" + (expand-extras (extra1 extra2)) + (LAMBDA NIL (LIST (QUOTE EXTRA1) EXTRA1 (QUOTE EXTRA2) EXTRA2)))) + "The correct expansions for macros that expand forms.") + +(defvar *fundamental-assertion-expansions* + '(("ASSERT-EQ" + (assert-eq expected form extra1 extra2) + (EXPAND-ASSERT + :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQ))) + ("ASSERT-EQL" + (assert-eql expected form extra1 extra2) + (EXPAND-ASSERT + :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQL))) + ("ASSERT-EQUAL" + (assert-equal expected form extra1 extra2) + (EXPAND-ASSERT + :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQUAL))) + ("ASSERT-EQUALP" + (assert-equalp expected form extra1 extra2) + (EXPAND-ASSERT + :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST (FUNCTION EQUALP))) + ("ASSERT-ERROR" + (assert-error 'condition form extra1 extra2) + (EXPAND-ASSERT + :ERROR FORM (EXPAND-ERROR-FORM FORM) 'CONDITION (EXTRA1 EXTRA2))) + ("ASSERT-EXPANDS" + (assert-expands expansion form extra1 extra2) + (EXPAND-ASSERT + :MACRO FORM (EXPAND-MACRO-FORM FORM NIL) EXPANSION (EXTRA1 EXTRA2))) + ("ASSERT-FALSE" + (assert-false form extra1 extra2) + (EXPAND-ASSERT :RESULT FORM FORM NIL (EXTRA1 EXTRA2))) + ("ASSERT-EQUALITY" + (assert-equality test expected form extra1 extra2) + (EXPAND-ASSERT + :EQUAL FORM FORM EXPECTED (EXTRA1 EXTRA2) :TEST TEST)) + ("ASSERT-PRINTS" + (assert-prints output form extra1 extra2) + (EXPAND-ASSERT + :OUTPUT FORM (expand-output-form form) OUTPUT (EXTRA1 EXTRA2))) + ("ASSERT-TRUE" + (assert-true form extra1 extra2) + (EXPAND-ASSERT :RESULT FORM FORM T (EXTRA1 EXTRA2)))) + "The correct expansions for the fundamental assertions.") diff --git a/src/contrib/lisp-unit/lisp-unit.asd b/src/contrib/lisp-unit/lisp-unit.asd new file mode 100644 index 0000000..2409eb6 --- /dev/null +++ b/src/contrib/lisp-unit/lisp-unit.asd @@ -0,0 +1,38 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- +#| + Copyright (c) 2009-2012, Thomas M. Hermann + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the "Software"), + to deal in the Software without restriction, including without limitation + the rights to use, copy, modify, merge, publish, distribute, sublicense, + and/or sell copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS + OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, + FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL + THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR + OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, + ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + +|# + +(in-package :asdf) + +(defsystem :lisp-unit + :description "Common Lisp library that supports unit testing." + :version "0.9.2" + :author "Thomas M. Hermann <thomas.m.hermann(a)odonata-research.com>" + :license "MIT" + :components + ((:file "lisp-unit") + (:module extensions + :depends-on ("lisp-unit") + :components ((:file "rational") + (:file "floating-point") + (:file "test-anything-protocol"))))) diff --git a/src/contrib/lisp-unit/lisp-unit.lisp b/src/contrib/lisp-unit/lisp-unit.lisp new file mode 100644 index 0000000..efaae1a --- /dev/null +++ b/src/contrib/lisp-unit/lisp-unit.lisp @@ -0,0 +1,910 @@ +;;;-*- Mode: Lisp; Syntax: ANSI-Common-Lisp -*- + +#| +Copyright (c) 2004-2005 Christopher K. Riesbeck + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the "Software"), +to deal in the Software without restriction, including without limitation +the rights to use, copy, modify, merge, publish, distribute, sublicense, +and/or sell copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + + +How to use +---------- + +1. Read the documentation at: + https://github.com/OdonataResearchLLC/lisp-unit/wiki + +2. Make a file of DEFINE-TEST's. See exercise-tests.lisp for many +examples. If you want, start your test file with (REMOVE-TESTS :ALL) +to clear any previously defined tests. + +3. Load this file. + +4. (use-package :lisp-unit) + +5. Load your code file and your file of tests. + +6. Test your code with (RUN-TESTS '(test-name1 test-name2 ...)) or +simply (RUN-TESTS :ALL) to run all defined tests. + +A summary of how many tests passed and failed will be printed. + +NOTE: Nothing is compiled until RUN-TESTS is expanded. Redefining +functions or even macros does not require reloading any tests. + +|# + +;;; Packages + +(in-package :cl-user) + +(defpackage :lisp-unit + (:use :common-lisp) + ;; Print parameters + (:export :*print-summary* + :*print-failures* + :*print-errors*) + ;; Forms for assertions + (:export :assert-eq + :assert-eql + :assert-equal + :assert-equalp + :assert-equality + :assert-prints + :assert-expands + :assert-true + :assert-false + :assert-error) + ;; Functions for managing tests + (:export :define-test + :list-tests + :test-code + :test-documentation + :remove-tests + :run-tests + :use-debugger) + ;; Functions for managing tags + (:export :list-tags + :tagged-tests + :remove-tags + :run-tags) + ;; Functions for reporting test results + (:export :test-names + :failed-tests + :error-tests + :missing-tests + :print-failures + :print-errors + :summarize-results) + ;; Functions for extensibility via signals + (:export :signal-results + :test-run-complete + :results) + ;; Utility predicates + (:export :logically-equal :set-equal)) + +(in-package :lisp-unit) + +;;; Global counters + +(defparameter *pass* 0 + "The passed assertion results.") + +(defparameter *fail* () + "The failed assertion results.") + +(defun reset-counters () + "Reset the counters to empty lists." + (setf *pass* 0 *fail* ())) + +;;; Global options + +(defparameter *print-summary* nil + "Print a summary of the pass, fail, and error count if non-nil.") + +(defparameter *print-failures* nil + "Print failure messages if non-NIL.") + +(defparameter *print-errors* nil + "Print error messages if non-NIL.") + +(defparameter *use-debugger* nil + "If not NIL, enter the debugger when an error is encountered in an +assertion.") + +(defparameter *signal-results* nil + "Signal the result if non NIL.") + +(defun use-debugger-p (condition) + "Debug or ignore errors." + (cond + ((eq :ask *use-debugger*) + (y-or-n-p "~A -- debug?" condition)) + (*use-debugger*))) + +(defun use-debugger (&optional (flag t)) + "Use the debugger when testing, or not." + (setq *use-debugger* flag)) + +(defun signal-results (&optional (flag t)) + "Signal the results for extensibility." + (setq *signal-results* flag)) + +;;; Global unit test database + +(defparameter *test-db* (make-hash-table :test #'eq) + "The unit test database is simply a hash table.") + +(defun null-tests-warning-report (null-tests-warning stream) + "Write the null-tests-warning to the stream." + (format stream "No tests defined for package ~A." + (tests-package-name null-tests-warning))) + +(define-condition null-tests-warning (simple-warning) + ((name + :type string + :initarg :name + :reader tests-package-name)) + (:report null-tests-warning-report)) + +(defun package-table (package &optional create) + (let ((packobj (find-package package))) + (cond + ((gethash packobj *test-db*)) + (create + (setf (gethash packobj *test-db*) (make-hash-table))) + (t (warn 'null-tests-warning :name (package-name package)))))) + +(defmacro with-package-table ((table + &optional (package *package*) create) + &body body) + "Execute the body only if the package table exists." + (let ((gtable (gensym "TABLE-"))) + `(let* ((,gtable (package-table ,package ,create)) + (,table ,gtable)) + (when (hash-table-p ,gtable) ,@body)))) + +;;; Global tags database + +(defparameter *tag-db* (make-hash-table :test #'eq) + "The tag database is simply a hash table.") + +(defun null-tags-warning-report (null-tags-warning stream) + "Write the null-tags-warning to the stream." + (format stream "No tags defined for package ~A." + (tags-package-name null-tags-warning))) + +(define-condition null-tags-warning (simple-warning) + ((name + :type string + :initarg :name + :reader tags-package-name)) + (:report null-tags-warning-report)) + +(defun package-tags (package &optional create) + "Return the tags DB for the package." + (let ((packobj (find-package package))) + (cond + ((gethash packobj *tag-db*)) + (create + (setf (gethash packobj *tag-db*) (make-hash-table))) + (t (warn 'null-tags-warning :name (package-name package)))))) + +(defmacro with-package-tags ((table + &optional (package *package*) create) + &body body) + "Execute the body only if the package tags exists." + (let ((gtable (gensym "TABLE-"))) + `(let* ((,gtable (package-tags ,package ,create)) + (,table ,gtable)) + (when (hash-table-p ,gtable) ,@body)))) + +;;; Unit test definition + +(defclass unit-test () + ((doc + :type string + :initarg :doc + :reader doc) + (code + :type list + :initarg :code + :reader code)) + (:default-initargs :doc "" :code ()) + (:documentation + "Organize the unit test documentation and code.")) + +;;; NOTE: Shamelessly taken from PG's analyze-body +(defun parse-body (body &optional doc tag) + "Separate the components of the body." + (let ((item (first body))) + (cond + ((and (listp item) (eq :tag (first item))) + (parse-body (rest body) doc (nconc (rest item) tag))) + ((and (stringp item) (not doc) (rest body)) + (if tag + (values doc tag (rest body)) + (parse-body (rest body) doc tag))) + (t (values doc tag body))))) + +(defun test-name-error-report (test-name-error stream) + "Write the test-name-error to the stream." + (format stream "Test name ~S is not of type ~A." + (type-error-datum test-name-error) + (type-error-expected-type test-name-error))) + +(define-condition test-name-error (type-error) + () + (:default-initargs :expected-type 'symbol) + (:report test-name-error-report) + (:documentation + "The test name error is a type error.")) + +(defun valid-test-name (name) + "Signal a type-error if the test name is not a symbol." + (if (symbolp name) + name + (error 'test-name-error :datum name))) + +(defmacro define-test (name &body body) + "Store the test in the test database." + (let ((qname (gensym "NAME-"))) + (multiple-value-bind (doc tag code) (parse-body body) + `(let* ((,qname (valid-test-name ',name)) + (doc (or ,doc (string ,qname)))) + (setf + ;; Unit test + (gethash ,qname (package-table *package* t)) + (make-instance 'unit-test :doc doc :code ',code)) + ;; Tags + (loop for tag in ',tag do + (pushnew + ,qname (gethash tag (package-tags *package* t)))) + ;; Return the name of the test + ,qname)))) + +;;; Manage tests + +(defun list-tests (&optional (package *package*)) + "Return a list of the tests in package." + (with-package-table (table package) + (loop for test-name being each hash-key in table + collect test-name))) + +(defun test-documentation (name &optional (package *package*)) + "Return the documentation for the test." + (with-package-table (table package) + (let ((unit-test (gethash name table))) + (if (null unit-test) + (warn "No test ~A in package ~A." + name (package-name package)) + (doc unit-test))))) + +(defun test-code (name &optional (package *package*)) + "Returns the code stored for the test name." + (with-package-table (table package) + (let ((unit-test (gethash name table))) + (if (null unit-test) + (warn "No test ~A in package ~A." + name (package-name package)) + (code unit-test))))) + +(defun remove-tests (&optional (names :all) (package *package*)) + "Remove individual tests or entire sets." + (if (eq :all names) + (if (null package) + (clrhash *test-db*) + (progn + (remhash (find-package package) *test-db*) + (remhash (find-package package) *tag-db*))) + (progn + ;; Remove tests + (with-package-table (table package) + (loop for name in names + unless (remhash name table) do + (warn "No test ~A in package ~A to remove." + name (package-name package)))) + ;; Remove tests from tags + (with-package-tags (tags package) + (loop for tag being each hash-key in tags + using (hash-value tagged-tests) + do + (setf + (gethash tag tags) + (set-difference tagged-tests names))))))) + +;;; Manage tags + +(defun %tests-from-all-tags (&optional (package *package*)) + "Return all of the tests that have been tagged." + (with-package-tags (table package) + (loop for tests being each hash-value in table + nconc (copy-list tests) into all-tests + finally (return (delete-duplicates all-tests))))) + +(defun %tests-from-tags (tags &optional (package *package*)) + "Return the tests associated with the tags." + (with-package-tags (table package) + (loop for tag in tags + as tests = (gethash tag table) + if (null tests) do (warn "No tests tagged with ~S." tag) + else nconc (copy-list tests) into all-tests + finally (return (delete-duplicates all-tests))))) + +(defun list-tags (&optional (package *package*)) + "Return a list of the tags in package." + (with-package-tags (table package) + (loop for tag being each hash-key in table collect tag))) + +(defun tagged-tests (&optional (tags :all) (package *package*)) + "Return a list of the tests associated with the tags." + (if (eq :all tags) + (%tests-from-all-tags package) + (%tests-from-tags tags package))) + +(defun remove-tags (&optional (tags :all) (package *package*)) + "Remove individual tags or entire sets." + (if (eq :all tags) + (if (null package) + (clrhash *tag-db*) + (remhash (find-package package) *tag-db*)) + (with-package-tags (tag-table package) + (loop for tag in tags + unless (remhash tag tag-table) do + (warn "No tag ~A in package ~A to remove." + tag (package-name package)))))) + +;;; Assert macros + +(defmacro assert-eq (expected form &rest extras) + "Assert whether expected and form are EQ." + `(expand-assert :equal ,form ,form ,expected ,extras :test #'eq)) + +(defmacro assert-eql (expected form &rest extras) + "Assert whether expected and form are EQL." + `(expand-assert :equal ,form ,form ,expected ,extras :test #'eql)) + +(defmacro assert-equal (expected form &rest extras) + "Assert whether expected and form are EQUAL." + `(expand-assert :equal ,form ,form ,expected ,extras :test #'equal)) + +(defmacro assert-equalp (expected form &rest extras) + "Assert whether expected and form are EQUALP." + `(expand-assert :equal ,form ,form ,expected ,extras :test #'equalp)) + +(defmacro assert-error (condition form &rest extras) + "Assert whether form signals condition." + `(expand-assert :error ,form (expand-error-form ,form) + ,condition ,extras)) + +(defmacro assert-expands (expansion form &rest extras) + "Assert whether form expands to expansion." + `(expand-assert :macro ,form + (expand-macro-form ,form nil) + ',expansion ,extras)) + +(defmacro assert-false (form &rest extras) + "Assert whether the form is false." + `(expand-assert :result ,form ,form nil ,extras)) + +(defmacro assert-equality (test expected form &rest extras) + "Assert whether expected and form are equal according to test." + `(expand-assert :equal ,form ,form ,expected ,extras :test ,test)) + +(defmacro assert-prints (output form &rest extras) + "Assert whether printing the form generates the output." + `(expand-assert :output ,form (expand-output-form ,form) + ,output ,extras)) + +(defmacro assert-true (form &rest extras) + "Assert whether the form is true." + `(expand-assert :result ,form ,form t ,extras)) + +(defmacro expand-assert (type form body expected extras &key (test '#'eql)) + "Expand the assertion to the internal format." + `(internal-assert ,type ',form + (lambda () ,body) + (lambda () ,expected) + (expand-extras ,extras) + ,test)) + +(defmacro expand-error-form (form) + "Wrap the error assertion in HANDLER-CASE." + `(handler-case ,form + (condition (error) error))) + +(defmacro expand-output-form (form) + "Capture the output of the form in a string." + (let ((out (gensym))) + `(let* ((,out (make-string-output-stream)) + (*standard-output* + (make-broadcast-stream *standard-output* ,out))) + ,form + (get-output-stream-string ,out)))) + +(defmacro expand-macro-form (form env) + "Expand the macro form once." + `(let ((*gensym-counter* 1)) + (macroexpand-1 ',form ,env))) + +(defmacro expand-extras (extras) + "Expand extra forms." + `(lambda () + (list ,@(mapcan (lambda (form) (list `',form form)) extras)))) + +(defgeneric assert-result (type test expected actual) + (:documentation + "Return the result of the assertion.")) + +(defgeneric record-failure (type form actual expected extras test) + (:documentation + "Record the details of the failure.")) + +(defclass failure-result () + ((form + :initarg :form + :reader form) + (actual + :type list + :initarg :actual + :reader actual) + (expected + :type list + :initarg :expected + :reader expected) + (extras + :type list + :initarg :extras + :reader extras) + (test + :type function + :initarg :test + :reader test)) + (:documentation + "Failure details of the assertion.")) + +(defun %record-failure (class form actual expected extras test) + "Return an instance of the failure result." + (make-instance class + :form form + :actual actual + :expected expected + :extras extras + :test test)) + +(defclass equal-result (failure-result) + () + (:documentation + "Result of a failed equal assertion.")) + +(defmethod assert-result ((type (eql :equal)) test expected actual) + "Return the result of an equal assertion." + (and + (<= (length expected) (length actual)) + (every test expected actual))) + +(defmethod record-failure ((type (eql :equal)) + form actual expected extras test) + "Return an instance of an equal failure result." + (%record-failure 'equal-result form actual expected extras test)) + +(defclass error-result (failure-result) + () + (:documentation + "Result of a failed error assertion.")) + +(defmethod assert-result ((type (eql :error)) test expected actual) + "Return the result of an error assertion." + (declare (ignore test)) + (or + (eql (car actual) (car expected)) + (typep (car actual) (car expected)))) + +(defmethod record-failure ((type (eql :error)) + form actual expected extras test) + "Return an instance of an error failure result." + (%record-failure 'error-result form actual expected extras test)) + +(defclass macro-result (failure-result) + () + (:documentation + "Result of a failed macro expansion assertion.")) + +(defun %expansion-equal (form1 form2) + "Descend into the forms checking for equality." + (let ((item1 (first form1)) + (item2 (first form2))) + (cond + ((and (null item1) (null item2))) + ((and (listp item1) (listp item2)) + (and + (%expansion-equal item1 item2) + (%expansion-equal (rest form1) (rest form2)))) + ((and (symbolp item1) (symbolp item2)) + (and + (string= (symbol-name item1) (symbol-name item2)) + (%expansion-equal (rest form1) (rest form2)))) + (t (and + (equal item1 item2) + (%expansion-equal (rest form1) (rest form2))))))) + +(defmethod assert-result ((type (eql :macro)) test expected actual) + "Return the result of a macro assertion." + (declare (ignore test)) + (%expansion-equal (first expected) (first actual))) + +(defmethod record-failure ((type (eql :macro)) + form actual expected extras test) + "Return an instance of a macro failure result." + (%record-failure 'macro-result form actual expected extras test)) + +(defclass boolean-result (failure-result) + () + (:documentation + "Result of a failed boolean assertion.")) + +(defmethod assert-result ((type (eql :result)) test expected actual) + "Return the result of a result assertion." + (declare (ignore test)) + (logically-equal (car actual) (car expected))) + +(defmethod record-failure ((type (eql :result)) + form actual expected extras test) + "Return an instance of a boolean failure result." + (%record-failure 'boolean-result form actual expected extras test)) + +(defclass output-result (failure-result) + () + (:documentation + "Result of a failed output assertion.")) + +(defmethod assert-result ((type (eql :output)) test expected actual) + "Return the result of an output assertion." + (declare (ignore test)) + (string= + (string-trim '(#\newline #\return #\space) (car actual)) + (car expected))) + +(defmethod record-failure ((type (eql :output)) + form actual expected extras test) + "Return an instance of an output failure result." + (%record-failure 'output-result form actual expected extras test)) + +(defun internal-assert + (type form code-thunk expected-thunk extras test) + "Perform the assertion and record the results." + (let* ((actual (multiple-value-list (funcall code-thunk))) + (expected (multiple-value-list (funcall expected-thunk))) + (result (assert-result type test expected actual))) + (if result + (incf *pass*) + (push + (record-failure + type form actual expected + (when extras (funcall extras)) test) + *fail*)) + ;; Return the result + result)) + +;;; Unit test results + +(defclass test-result () + ((name + :type symbol + :initarg :name + :reader name) + (pass + :type fixnum + :initarg :pass + :reader pass) + (fail + :type list + :initarg :fail + :reader fail) + (exerr + :initarg :exerr + :reader exerr) + (run-time + :initarg :run-time + :reader run-time + :documentation + "Test run time measured in internal time units")) + (:default-initargs :exerr nil) + (:documentation + "Store the results of the unit test.")) + +(defun print-summary (test-result &optional + (stream *standard-output*)) + "Print a summary of the test result." + (format stream "~&~A: ~S assertions passed, ~S failed" + (name test-result) + (pass test-result) + (length (fail test-result))) + (if (exerr test-result) + (format stream ", and an execution error.") + (write-char #\. stream)) + (terpri stream) + (terpri stream)) + +(defun run-code (code) + "Run the code to test the assertions." + (funcall (coerce `(lambda () ,@code) 'function))) + +(defun run-test-thunk (name code) + (let ((*pass* 0) + (*fail* ()) + (start (get-internal-run-time))) + (handler-bind + ((error + (lambda (condition) + (if (use-debugger-p condition) + condition + (return-from run-test-thunk + (make-instance + 'test-result + :name name + :pass *pass* + :fail *fail* + :run-time (- (get-internal-run-time) start) + :exerr condition)))))) + (run-code code)) + ;; Return the result count + (make-instance + 'test-result + :name name + :pass *pass* + :fail *fail* + :run-time (- (get-internal-run-time) start)))) + +;;; Test results database + +(defclass test-results-db () + ((database + :type hash-table + :initform (make-hash-table :test #'eq) + :reader database) + (pass + :type fixnum + :initform 0 + :accessor pass) + (fail + :type fixnum + :initform 0 + :accessor fail) + (exerr + :type fixnum + :initform 0 + :accessor exerr) + (failed-tests + :type list + :initform () + :accessor failed-tests) + (error-tests + :type list + :initform () + :accessor error-tests) + (missing-tests + :type list + :initform () + :accessor missing-tests)) + (:documentation + "Store the results of the tests for further evaluation.")) + +(defmethod print-object ((object test-results-db) stream) + "Print the summary counts with the object." + (let ((pass (pass object)) + (fail (fail object)) + (exerr (exerr object))) + (format + stream "#<~A Total(~D) Passed(~D) Failed(~D) Errors(~D)>~%" + (class-name (class-of object)) + (+ pass fail) pass fail exerr))) + +(defun test-names (test-results-db) + "Return a list of the test names in the database." + (loop for name being each hash-key in (database test-results-db) + collect name)) + +(defun record-result (test-name code results) + "Run the test code and record the result." + (let ((result (run-test-thunk test-name code))) + ;; Store the result + (setf (gethash test-name (database results)) result) + ;; Count passed tests + (when (plusp (pass result)) + (incf (pass results) (pass result))) + ;; Count failed tests and record the name + (when (fail result) + (incf (fail results) (length (fail result))) + (push test-name (failed-tests results))) + ;; Count errors and record the name + (when (exerr result) + (incf (exerr results)) + (push test-name (error-tests results))) + ;; Running output + (when *print-failures* (print-failures result)) + (when *print-errors* (print-errors result)) + (when (or *print-summary* *print-failures* *print-errors*) + (print-summary result)))) + +(defun summarize-results (results &optional + (stream *standard-output*)) + "Print a summary of all results to the stream." + (let ((pass (pass results)) + (fail (fail results))) + (format stream "~&Unit Test Summary~%") + (format stream " | ~D assertions total~%" (+ pass fail)) + (format stream " | ~D passed~%" pass) + (format stream " | ~D failed~%" fail) + (format stream " | ~D execution errors~%" (exerr results)) + (format stream " | ~D missing tests~2%" + (length (missing-tests results))))) + +;;; Run the tests + +(define-condition test-run-complete () + ((results + :type 'test-results-db + :initarg :results + :reader results)) + (:documentation + "Signaled when a test run is finished.")) + +(defun %run-all-thunks (&optional (package *package*)) + "Run all of the test thunks in the package." + (with-package-table (table package) + (loop + with results = (make-instance 'test-results-db) + for test-name being each hash-key in table + using (hash-value unit-test) + if unit-test do + (record-result test-name (code unit-test) results) + else do + (push test-name (missing-tests results)) + ;; Summarize and return the test results + finally + (when *signal-results* + (signal 'test-run-complete :results results)) + (summarize-results results) + (return results)))) + +(defun %run-thunks (test-names &optional (package *package*)) + "Run the list of test thunks in the package." + (with-package-table (table package) + (loop + with results = (make-instance 'test-results-db) + for test-name in test-names + as unit-test = (gethash test-name table) + if unit-test do + (record-result test-name (code unit-test) results) + else do + (push test-name (missing-tests results)) + finally + (when *signal-results* + (signal 'test-run-complete :results results)) + (summarize-results results) + (return results)))) + +(defun run-tests (&optional (test-names :all) (package *package*)) + "Run the specified tests in package." + (reset-counters) + (if (eq :all test-names) + (%run-all-thunks package) + (%run-thunks test-names package))) + +(defun run-tags (&optional (tags :all) (package *package*)) + "Run the tests associated with the specified tags in package." + (reset-counters) + (%run-thunks (tagged-tests tags package) package)) + +;;; Print failures + +(defgeneric print-failures (result &optional stream) + (:documentation + "Report the results of the failed assertion.")) + +(defmethod print-failures :around ((result failure-result) &optional + (stream *standard-output*)) + "Failure header and footer output." + (format stream "~& | Failed Form: ~S" (form result)) + (call-next-method) + (when (extras result) + (format stream "~{~& | ~S => ~S~}~%" (extras result))) + (format stream "~& |~%")) + +(defmethod print-failures ((result failure-result) &optional + (stream *standard-output*)) + (format stream "~& | Expected ~{~S~^; ~} " (expected result)) + (format stream "~<~% | ~:;but saw ~{~S~^; ~}~>" (actual result))) + +(defmethod print-failures ((result error-result) &optional + (stream *standard-output*)) + (format stream "~& | ~@[Should have signalled ~{~S~^; ~} but saw~]" + (expected result)) + (format stream " ~{~S~^; ~}" (actual result))) + +(defmethod print-failures ((result macro-result) &optional + (stream *standard-output*)) + (format stream "~& | Should have expanded to ~{~S~^; ~} " + (expected result)) + (format stream "~<~%~:;but saw ~{~S~^; ~}~>" (actual result))) + +(defmethod print-failures ((result output-result) &optional + (stream *standard-output*)) + (format stream "~& | Should have printed ~{~S~^; ~} " + (expected result)) + (format stream "~<~%~:;but saw ~{~S~^; ~}~>" + (actual result))) + +(defmethod print-failures ((result test-result) &optional + (stream *standard-output*)) + "Print the failed assertions in the unit test." + (loop for fail in (fail result) do + (print-failures fail stream))) + +(defmethod print-failures ((results test-results-db) &optional + (stream *standard-output*)) + "Print all of the failure tests." + (loop with db = (database results) + for test in (failed-tests results) + as result = (gethash test db) + do + (print-failures result stream) + (print-summary result stream))) + +;;; Print errors + +(defgeneric print-errors (result &optional stream) + (:documentation + "Print the error condition.")) + +(defmethod print-errors ((result test-result) &optional + (stream *standard-output*)) + "Print the error condition." + (let ((exerr (exerr result)) + (*print-escape* nil)) + (when exerr + (format stream "~& | Execution error:~% | ~W" exerr) + (format stream "~& |~%")))) + +(defmethod print-errors ((results test-results-db) &optional + (stream *standard-output*)) + "Print all of the error tests." + (loop with db = (database results) + for test in (error-tests results) + as result = (gethash test db) + do + (print-errors result stream) + (print-summary result stream))) + +;;; Useful equality predicates for tests + +(defun logically-equal (x y) + "Return true if x and y are both false or both true." + (eql (not x) (not y))) + +(defun set-equal (list1 list2 &rest initargs &key key (test #'equal)) + "Return true if every element of list1 is an element of list2 and +vice versa." + (declare (ignore key test)) + (and + (listp list1) + (listp list2) + (apply #'subsetp list1 list2 initargs) + (apply #'subsetp list2 list1 initargs))) + +(pushnew :lisp-unit common-lisp:*features*) ----------------------------------------------------------------------- Summary of changes: src/code/module.lisp | 7 + src/contrib/lisp-unit/.gitignore | 5 + src/contrib/lisp-unit/README.md | 75 ++ .../lisp-unit/extensions/floating-point.lisp | 818 ++++++++++++++++++ src/contrib/lisp-unit/extensions/rational.lisp | 96 +++ .../extensions/test-anything-protocol.lisp | 86 ++ .../lisp-unit/internal-test/example-tests.lisp | 153 ++++ .../lisp-unit/internal-test/floating-point.lisp | 115 +++ .../internal-test/fundamental-assertions.lisp | 170 ++++ src/contrib/lisp-unit/lisp-unit.asd | 38 + src/contrib/lisp-unit/lisp-unit.lisp | 910 ++++++++++++++++++++ src/contrib/load-lisp-unit.lisp | 6 + 12 files changed, 2479 insertions(+) create mode 100644 src/contrib/lisp-unit/.gitignore create mode 100644 src/contrib/lisp-unit/README.md create mode 100644 src/contrib/lisp-unit/extensions/floating-point.lisp create mode 100644 src/contrib/lisp-unit/extensions/rational.lisp create mode 100644 src/contrib/lisp-unit/extensions/test-anything-protocol.lisp create mode 100644 src/contrib/lisp-unit/internal-test/example-tests.lisp create mode 100644 src/contrib/lisp-unit/internal-test/floating-point.lisp create mode 100644 src/contrib/lisp-unit/internal-test/fundamental-assertions.lisp create mode 100644 src/contrib/lisp-unit/lisp-unit.asd create mode 100644 src/contrib/lisp-unit/lisp-unit.lisp create mode 100644 src/contrib/load-lisp-unit.lisp hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-27-g7107249
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 7107249f265148e246a9eec84b15cfbe96121594 (commit) from 13f320d9568705f58010d456b957917b2d2c62c6 (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 7107249f265148e246a9eec84b15cfbe96121594 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Jul 31 15:50:44 2014 -0700 Finally remove the Lisp implementation of the trig functions that are now in C. diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index c48d09d..7c8b031 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -208,440 +208,6 @@ (declare (ignore ign)) (values s c))) -#|| -;; Implement sin/cos/tan in Lisp. These are based on the routines -;; from fdlibm. - -;; Block compile so the trig routines don't cons their args when -;; calling the kernel trig routines. -(declaim (ext:start-block kernel-sin kernel-cos kernel-tan - %sin %cos %tan - %sincos)) - -;; kernel sin function on [-pi/4, pi/4], pi/4 ~ 0.7854 -;; Input x is assumed to be bounded by ~pi/4 in magnitude. -;; Input y is the tail of x. -;; Input iy indicates whether y is 0. (if iy=0, y assume to be 0). -;; -;; Algorithm -;; 1. Since sin(-x) = -sin(x), we need only to consider positive x. -;; 2. if x < 2^-27 (hx<0x3e400000 0), return x with inexact if x!=0. -;; 3. sin(x) is approximated by a polynomial of degree 13 on -;; [0,pi/4] -;; 3 13 -;; sin(x) ~ x + S1*x + ... + S6*x -;; where -;; -;; |sin(x) 2 4 6 8 10 12 | -58 -;; |----- - (1+S1*x +S2*x +S3*x +S4*x +S5*x +S6*x )| <= 2 -;; | x | -;; -;; 4. sin(x+y) = sin(x) + sin'(x')*y -;; ~ sin(x) + (1-x*x/2)*y -;; For better accuracy, let -;; 3 2 2 2 2 -;; r = x *(S2+x *(S3+x *(S4+x *(S5+x *S6)))) -;; then 3 2 -;; sin(x) = x + (S1*x + (x *(r-y/2)+y)) - -(declaim (ftype (function (double-float double-float fixnum) - double-float) - kernel-sin)) - -(defun kernel-sin (x y iy) - (declare (type (double-float -1d0 1d0) x y) - (fixnum iy) - (optimize (speed 3) (safety 0))) - (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) - (when (< ix #x3e400000) - ;; |x| < 2^-27 - ;; Signal inexact if x /= 0 - (if (zerop (truncate x)) - (return-from kernel-sin x) - (return-from kernel-sin x))) - (let* ((s1 -1.66666666666666324348d-01) ; #xBFC55555 #x55555549 - (s2 8.33333333332248946124d-03) ; #x3F811111 #x1110F8A6 - (s3 -1.98412698298579493134d-04) ; #xBF2A01A0 #x19C161D5 - (s4 2.75573137070700676789d-06) ; #x3EC71DE3 #x57B1FE7D - (s5 -2.50507602534068634195d-08) ; #xBE5AE5E6 #x8A2B9CEB - (s6 1.58969099521155010221d-10) ; #x3DE5D93A #x5ACFD57C - (z (* x x)) - (v (* z x)) - (r (+ s2 - (* z - (+ s3 - (* z - (+ s4 - (* z - (+ s5 - (* z s6)))))))))) - (if (zerop iy) - (+ x (* v (+ s1 (* z r)))) - (- x (- (- (* z (- (* .5 y) - (* v r))) - y) - (* v s1))))))) - -;; kernel cos function on [-pi/4, pi/4], pi/4 ~ 0.785398164 -;; Input x is assumed to be bounded by ~pi/4 in magnitude. -;; Input y is the tail of x. -;; -;; Algorithm -;; 1. Since cos(-x) = cos(x), we need only to consider positive x. -;; 2. if x < 2^-27 (hx<0x3e400000 0), return 1 with inexact if x!=0. -;; 3. cos(x) is approximated by a polynomial of degree 14 on -;; [0,pi/4] -;; 4 14 -;; cos(x) ~ 1 - x*x/2 + C1*x + ... + C6*x -;; where the remez error is -;; -;; | 2 4 6 8 10 12 14 | -58 -;; |cos(x)-(1-.5*x +C1*x +C2*x +C3*x +C4*x +C5*x +C6*x )| <= 2 -;; | | -;; -;; 4 6 8 10 12 14 -;; 4. let r = C1*x +C2*x +C3*x +C4*x +C5*x +C6*x , then -;; cos(x) = 1 - x*x/2 + r -;; since cos(x+y) ~ cos(x) - sin(x)*y -;; ~ cos(x) - x*y, -;; a correction term is necessary in cos(x) and hence -;; cos(x+y) = 1 - (x*x/2 - (r - x*y)) -;; For better accuracy when x > 0.3, let qx = |x|/4 with -;; the last 32 bits mask off, and if x > 0.78125, let qx = 0.28125. -;; Then -;; cos(x+y) = (1-qx) - ((x*x/2-qx) - (r-x*y)). -;; Note that 1-qx and (x*x/2-qx) is EXACT here, and the -;; magnitude of the latter is at least a quarter of x*x/2, -;; thus, reducing the rounding error in the subtraction. -(declaim (ftype (function (double-float double-float) - double-float) - kernel-cos)) - -(defun kernel-cos (x y) - (declare (type (double-float -1d0 1d0) x y) - (optimize (speed 3) (safety 0))) - ;; cos(-x) = cos(x), so we just compute cos(|x|). - (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) - ;; cos(x) = 1 when |x| < 2^-27 - (when (< ix #x3e400000) - ;; Signal inexact if x /= 0 - (if (zerop (truncate x)) - (return-from kernel-cos 1d0) - (return-from kernel-cos 1d0))) - (let* ((c1 4.16666666666666019037d-02) - (c2 -1.38888888888741095749d-03) - (c3 2.48015872894767294178d-05) - (c4 -2.75573143513906633035d-07) - (c5 2.08757232129817482790d-09) - (c6 -1.13596475577881948265d-11) - (z (* x x)) - (r (* z - (+ c1 - (* z - (+ c2 - (* z - (+ c3 - (* z - (+ c4 - (* z - (+ c5 - (* z c6))))))))))))) - (cond ((< ix #x3fd33333) - ;; \x| < 0.3 - (- 1 (- (* .5 z) - (- (* z r) - (* x y))))) - (t - ;; qx = 0.28125 if |x| > 0.78125, else x/4 dropping the - ;; least significant 32 bits. - (let* ((qx (if (> ix #x3fe90000) - 0.28125d0 - ;; x/4, exactly, and also dropping the - ;; least significant 32 bits of the - ;; fraction. - (make-double-float (- ix #x00200000) - 0))) - (hz (- (* 0.5 z) qx)) - (a (- 1 qx))) - (- a (- hz (- (* z r) - (* x y)))))))))) - -(declaim (type (simple-array double-float (*)) tan-coef)) -(defconstant tan-coef - (make-array 13 :element-type 'double-float - :initial-contents - '(3.33333333333334091986d-01 - 1.33333333333201242699d-01 - 5.39682539762260521377d-02 - 2.18694882948595424599d-02 - 8.86323982359930005737d-03 - 3.59207910759131235356d-03 - 1.45620945432529025516d-03 - 5.88041240820264096874d-04 - 2.46463134818469906812d-04 - 7.81794442939557092300d-05 - 7.14072491382608190305d-05 - -1.85586374855275456654d-05 - 2.59073051863633712884d-05))) - -;; kernel tan function on [-pi/4, pi/4], pi/4 ~ 0.7854 -;; Input x is assumed to be bounded by ~pi/4 in magnitude. -;; Input y is the tail of x. -;; Input k indicates whether tan (if k = 1) or -1/tan (if k = -1) is returned. -;; -;; Algorithm -;; 1. Since tan(-x) = -tan(x), we need only to consider positive x. -;; 2. if x < 2^-28 (hx<0x3e300000 0), return x with inexact if x!=0. -;; 3. tan(x) is approximated by a odd polynomial of degree 27 on -;; [0,0.67434] -;; 3 27 -;; tan(x) ~ x + T1*x + ... + T13*x -;; where -;; -;; |tan(x) 2 4 26 | -59.2 -;; |----- - (1+T1*x +T2*x +.... +T13*x )| <= 2 -;; | x | -;; -;; Note: tan(x+y) = tan(x) + tan'(x)*y -;; ~ tan(x) + (1+x*x)*y -;; Therefore, for better accuracy in computing tan(x+y), let -;; 3 2 2 2 2 -;; r = x *(T2+x *(T3+x *(...+x *(T12+x *T13)))) -;; then -;; 3 2 -;; tan(x+y) = x + (T1*x + (x *(r+y)+y)) -;; -;; 4. For x in [0.67434,pi/4], let y = pi/4 - x, then -;; tan(x) = tan(pi/4-y) = (1-tan(y))/(1+tan(y)) -;; = 1 - 2*(tan(y) - (tan(y)^2)/(1+tan(y))) -(declaim (ftype (function (double-float double-float fixnum) - double-float) - kernel-tan)) - -(defun kernel-tan (x y iy) - (declare (type (double-float -1d0 1d0) x y) - (type (member -1 1) iy) - (optimize (speed 3) (safety 0))) - (let* ((hx (kernel:double-float-high-bits x)) - (ix (logand hx #x7fffffff)) - (w 0d0) - (z 0d0) - (v 0d0) - (s 0d0) - (r 0d0)) - (declare (double-float w z v s r)) - (when (< ix #x3e300000) - ;; |x| < 2^-28 - (when (zerop (truncate x)) - (cond ((zerop (logior (logior ix (kernel:double-float-low-bits x)) - (+ iy 1))) - ;; x = 0 (because hi and low bits are 0) and iy = -1 - ;; (cot) - (return-from kernel-tan (/ (abs x)))) - ((= iy 1) - (return-from kernel-tan x)) - (t - ;; x /= 0 and iy = -1 (cot) - ;; Compute -1/(x+y) carefully - (let ((a 0d0) - (tt 0d0)) - (setf w (+ x y)) - (setf z (make-double-float (double-float-high-bits w) 0)) - (setf v (- y (- z x))) - (setf a (/ -1 w)) - (setf tt (make-double-float (double-float-high-bits a) 0)) - (setf s (+ 1 (* tt z))) - (return-from kernel-tan (+ tt - (* a (+ s (* tt v)))))))))) - (when (>= ix #x3FE59428) - ;; |x| > .6744 - (when (minusp hx) - (setf x (- x)) - (setf y (- y))) - ;; The two constants below are such that pi/4 + pi/4_lo is pi/4 - ;; to twice the accuracy of a double float. - ;; - ;; z = pi/4-x - (setf z (- (make-double-float #x3FE921FB #x54442D18) x)) - ;; w = pi/4_lo - y. - (setf w (- (make-double-float #x3C81A626 #x33145C07) y)) - (setf x (+ z w)) - (setf y 0d0)) - (setf z (* x x)) - (setf w (* z z)) - ;; Break x^5*(T[1]+x^2*T[2]+...) into - ;; x^5(T[1]+x^4*T[3]+...+x^20*T[11]) + - ;; x^5(x^2*(T[2]+x^4*T[4]+...+x^22*[T12])) - (setf r (+ (aref tan-coef 1) - (* w - (+ (aref tan-coef 3) - (* w - (+ (aref tan-coef 5) - (* w - (+ (aref tan-coef 7) - (* w - (+ (aref tan-coef 9) - (* w (aref tan-coef 11)))))))))))) - (setf v (* z - (+ (aref tan-coef 2) - (* w - (+ (aref tan-coef 4) - (* w - (+ (aref tan-coef 6) - (* w - (+ (aref tan-coef 8) - (* w - (+ (aref tan-coef 10) - (* w (aref tan-coef 12))))))))))))) - (setf s (* z x)) - (setf r (+ y (* z (+ (* s (+ r v)) - y)))) - (incf r (* s (aref tan-coef 0))) - (setf w (+ x r)) - (when (>= ix #x3FE59428) - (let ((v (float iy 1d0))) - (return-from kernel-tan - (* (- 1 (logand 2 (ash hx -30))) - (- v - (* 2 - (- x (- (/ (* w w) - (+ w v)) - r)))))))) - (when (= iy 1) - (return-from kernel-tan w)) - ;; Compute 1/w=1/(x+r) carefully - (let ((a 0d0) - (tt 0d0)) - (setf z (kernel:make-double-float (kernel:double-float-high-bits w) 0)) - (setf v (- r (- z x))) ; z + v = r + x - (setf a (/ -1 w)) - (setf tt (kernel:make-double-float (kernel:double-float-high-bits a) 0)) - (setf s (+ 1 (* tt z))) - (+ tt - (* a - (+ s (* tt v))))))) - -;; Return sine function of x. -;; -;; kernel function: -;; __kernel_sin ... sine function on [-pi/4,pi/4] -;; __kernel_cos ... cose function on [-pi/4,pi/4] -;; __ieee754_rem_pio2 ... argument reduction routine -;; -;; Method. -;; Let S,C and T denote the sin, cos and tan respectively on -;; [-PI/4, +PI/4]. Reduce the argument x to y1+y2 = x-k*pi/2 -;; in [-pi/4 , +pi/4], and let n = k mod 4. -;; We have -;; -;; n sin(x) cos(x) tan(x) -;; ---------------------------------------------------------- -;; 0 S C T -;; 1 C -S -1/T -;; 2 -S -C T -;; 3 -C S -1/T -;; ---------------------------------------------------------- -;; -;; Special cases: -;; Let trig be any of sin, cos, or tan. -;; trig(+-INF) is NaN, with signals; -;; trig(NaN) is that NaN; -;; -;; Accuracy: -;; TRIG(x) returns trig(x) nearly rounded -(defun %sin (x) - (declare (double-float x) - (optimize (speed 3))) - (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) - (cond - ((<= ix #x3fe921fb) - ;; |x| < pi/4, approx - (kernel-sin x 0d0 0)) - ((>= ix #x7ff00000) - ;; sin(Inf or NaN) is NaN - (- x x)) - (t - ;; Argument reduction needed - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (case (logand n 3) - (0 - (kernel-sin y0 y1 1)) - (1 - (kernel-cos y0 y1)) - (2 - (- (kernel-sin y0 y1 1))) - (3 - (- (kernel-cos y0 y1))))))))) - -(defun %cos (x) - (declare (double-float x) - (optimize (speed 3))) - (let ((ix (ldb (byte 31 0) (kernel:double-float-high-bits x)))) - (cond - ((< ix #x3fe921fb) - ;;|x| < pi/4, approx - (kernel-cos x 0d0)) - ((>= ix #x7ff00000) - ;; cos(Inf or NaN) is NaN - (- x x)) - (t - ;; Argument reduction needed - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (ecase (logand n 3) - (0 - (kernel-cos y0 y1)) - (1 - (- (kernel-sin y0 y1 1))) - (2 - (- (kernel-cos y0 y1))) - (3 - (kernel-sin y0 y1 1)))))))) - -(defun %tan (x) - (declare (double-float x) - (optimize (speed 3))) - (let ((ix (logand #x7fffffff (kernel:double-float-high-bits x)))) - (cond ((<= ix #x3fe921fb) - ;; |x| < pi/4 - (kernel-tan x 0d0 1)) - ((>= ix #x7ff00000) - ;; tan(Inf or Nan) is NaN - (- x x)) - (t - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (let ((flag (- 1 (ash (logand n 1) 1)))) - ;; flag = 1 if n even, -1 if n odd - (kernel-tan y0 y1 flag))))))) -;; Compute sin and cos of x, simultaneously. -(defun %sincos (x) - (declare (double-float x) - (optimize (speed 3))) - (cond ((<= (abs x) (/ pi 4)) - (values (kernel-sin x 0d0 0) - (kernel-cos x 0d0))) - (t - ;; Argument reduction needed - (multiple-value-bind (n y0 y1) - (%ieee754-rem-pi/2 x) - (case (logand n 3) - (0 - (values (kernel-sin y0 y1 1) - (kernel-cos y0 y1))) - (1 - (values (kernel-cos y0 y1) - (- (kernel-sin y0 y1 1)))) - (2 - (values (- (kernel-sin y0 y1 1)) - (- (kernel-cos y0 y1)))) - (3 - (values (- (kernel-cos y0 y1)) - (kernel-sin y0 y1 1)))))))) -;;(declaim (ext:end-block)) -||# - ;;;; Power functions. ----------------------------------------------------------------------- Summary of changes: src/code/irrat.lisp | 434 --------------------------------------------------- 1 file changed, 434 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp annotated tag snapshot-2014-04 created. snapshot-2014-04
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-04 has been created at d29f514ce86a5c31f5c73a3b048779c3c4d9984b (tag) tagging 28740a75c3a9948d9a6fea93f4fffde1453ea665 (commit) replaces snapshot-2014-03 tagged by Raymond Toy on Sat Mar 29 09:29:47 2014 -0700 - Log ----------------------------------------------------------------- Snapshot 2014-04 -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.13 (Darwin) iEYEABECAAYFAlM29QEACgkQJ5IjUmgZO7JawACfbHukAckqWi9QSCqW1ooGTlnU 2EsAoKSQJQOTAVLcCeme2gzd5wfzfou3 =nIaD -----END PGP SIGNATURE----- Raymond Toy (13): Revert change for ticket 92. Add double-double-float-positive-infinity and Return the correct values for (log -0w0) and (log 0w0). Previously we Add unicode tests, based on the tests in src/i18n/tests. Remove these test files since they've been migrated to lisp-unit. First cut at adding PCL tests. Fix typos in eval-when cases. Add comments. Copy the PCL tests here, changing the package from PCL-TEST to Remove the tests and just use mk-defsystem to load the separate PCL Add comments. Note that this can't be run from a build; you have to Update from commit logs. Note dropping of x87 support after this snapshot. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[git] CMU Common Lisp branch master updated. snapshot-2014-06-34-g7211ebf
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 7211ebf377b1b4025ab8424d6f31109fa7489479 (commit) from e9be6b48a40993444db72d4a9434b9eb44099f65 (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 7211ebf377b1b4025ab8424d6f31109fa7489479 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Jul 31 19:56:40 2014 -0700 CLEAR-OUTPUT should call STREAM-CLEAR-OUTPUT for Gray streams. See ticket #101. This fixes item 1 of that bug report. diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 0e27cba..6cb5256 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -1103,7 +1103,7 @@ ;; lisp-stream (funcall (lisp-stream-misc stream) stream :clear-output) ;; fundamental-stream - (stream-force-output stream))) + (stream-clear-output stream))) nil) (defun write-byte (integer stream) ----------------------------------------------------------------------- Summary of changes: src/code/stream.lisp | 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-02-8-g0e94b21
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 0e94b217534b1306e73ab5b61fd34060311c1608 (commit) from 8e32631b0fd464a6f753639f02ceb36d58eeabde (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 0e94b217534b1306e73ab5b61fd34060311c1608 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Feb 10 22:05:45 2014 -0800 Fix path so (require :lisp-unit) actually loads. diff --git a/src/code/module.lisp b/src/code/module.lisp index 1ba11d8..7a40b73 100644 --- a/src/code/module.lisp +++ b/src/code/module.lisp @@ -150,7 +150,7 @@ ;; Lisp-unit (defmodule :lisp-unit - "modules:lisp-unit/load-lisp-unit") + "modules:load-lisp-unit") (defmodule "lisp-unit" "modules:load-lisp-unit") ----------------------------------------------------------------------- Summary of changes: src/code/module.lisp | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) hooks/post-receive -- CMU Common Lisp

1 0