cmucl-cvs

cmucl-cvs@common-lisp.net

2904 discussions

[cmucl-cvs] CMUCL commit: src/lisp (Darwin-os.c)
by Raymond Toy 03 Sep '11

03 Sep '11

Date: Friday, September 2, 2011 @ 21:46:35 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Modified: Darwin-os.c Cleanup sigbus handler for stack overflow. We don't need sigbus_handler_tramp; sigbus_handle_now is good enough. Print out the PC too when we get a real sigbus. -------------+ Darwin-os.c | 32 +++----------------------------- 1 file changed, 3 insertions(+), 29 deletions(-) Index: src/lisp/Darwin-os.c diff -u src/lisp/Darwin-os.c:1.34 src/lisp/Darwin-os.c:1.35 --- src/lisp/Darwin-os.c:1.34 Thu Sep 1 09:16:49 2011 +++ src/lisp/Darwin-os.c Fri Sep 2 21:46:34 2011 @@ -14,7 +14,7 @@ * Frobbed for OpenBSD by Pierre R. Mai, 2001. * Frobbed for Darwin by Pierre R. Mai, 2003. * - * $Header: /project/cmucl/cvsroot/src/lisp/Darwin-os.c,v 1.34 2011/09/01 16:16:49 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/Darwin-os.c,v 1.35 2011/09/03 04:46:34 rtoy Exp $ * */ @@ -462,18 +462,6 @@ interrupt_handle_now(signal, code, context); } - -static int tramp_signal; -static siginfo_t tramp_code; -static ucontext_t tramp_context; - -static void -sigbus_handler_tramp(void) -{ - sigbus_handle_now(tramp_signal, &tramp_code, &tramp_context); -} - - static void sigbus_handler(HANDLER_ARGS) { @@ -508,24 +496,10 @@ if (interrupt_maybe_gc(signal, code, context)) return; #endif -#ifdef RED_ZONE_HIT - { - /* - * Switch back to the normal stack and invoke the Lisp signal - * handler there. Global variables are used to pass the - * context * to the other stack. - */ - - tramp_signal = signal; - tramp_code = *code; - tramp_context = *context; - SC_PC(context) = sigbus_handler_tramp; - return; - } -#endif /* a *real* protection fault */ - fprintf(stderr, "sigbus_handler: Real protection violation: %p\n", fault_addr); + fprintf(stderr, "sigbus_handler: Real protection violation at %p, PC = %p\n", + fault_addr, SC_PC(context)); sigbus_handle_now(signal, code, context); #ifdef __ppc__ /* Work around G5 bug; fix courtesy gbyers via chandler */

1 0

[cmucl-cvs] CMUCL commit: src/code (interr.lisp)
by Raymond Toy 01 Sep '11

01 Sep '11

Date: Thursday, September 1, 2011 @ 09:53:46 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: interr.lisp Insert line breaks in the yellow-zone message. -------------+ interr.lisp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) Index: src/code/interr.lisp diff -u src/code/interr.lisp:1.50 src/code/interr.lisp:1.51 --- src/code/interr.lisp:1.50 Tue Apr 20 10:57:44 2010 +++ src/code/interr.lisp Thu Sep 1 09:53:46 2011 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/interr.lisp,v 1.50 2010/04/20 17:57:44 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/interr.lisp,v 1.51 2011/09/01 16:53:46 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -666,9 +666,9 @@ (defun yellow-zone-hit () (let ((debug:*stack-top-hint* nil)) (format *error-output* - (intl:gettext "~2&~@<A control stack overflow has occurred: ~ - the program has entered the yellow control stack guard zone. ~ - Please note that you will be returned to the Top-Level if you ~ + (intl:gettext "~2&~@<A control stack overflow has occurred:~%~ + the program has entered the yellow control stack guard zone.~%~ + Please note that you will be returned to the Top-Level if you~%~ enter the red control stack guard zone while debugging.~@:>~2%")) (infinite-error-protect (error 'stack-overflow))))

1 0

[cmucl-cvs] CMUCL commit: src/lisp (Darwin-os.c)
by Raymond Toy 01 Sep '11

01 Sep '11

Date: Thursday, September 1, 2011 @ 09:16:50 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Modified: Darwin-os.c Oops. Need to check for gc write barrier before handling the sigbus. -------------+ Darwin-os.c | 25 +++++++++++++------------ 1 file changed, 13 insertions(+), 12 deletions(-) Index: src/lisp/Darwin-os.c diff -u src/lisp/Darwin-os.c:1.33 src/lisp/Darwin-os.c:1.34 --- src/lisp/Darwin-os.c:1.33 Wed Aug 31 22:18:26 2011 +++ src/lisp/Darwin-os.c Thu Sep 1 09:16:49 2011 @@ -14,7 +14,7 @@ * Frobbed for OpenBSD by Pierre R. Mai, 2001. * Frobbed for Darwin by Pierre R. Mai, 2003. * - * $Header: /project/cmucl/cvsroot/src/lisp/Darwin-os.c,v 1.33 2011/09/01 05:18:26 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/Darwin-os.c,v 1.34 2011/09/01 16:16:49 rtoy Exp $ * */ @@ -497,6 +497,17 @@ DPRINTF(0, (stderr, " foreign_function_call = %d\n", foreign_function_call_active)); #endif +#if defined(GENCGC) +#if defined(SIGSEGV_VERBOSE) + fprintf(stderr, "Signal %d, fault_addr=%x\n", + signal, fault_addr); +#endif + if (gc_write_barrier(code->si_addr)) + return; +#else + if (interrupt_maybe_gc(signal, code, context)) + return; +#endif #ifdef RED_ZONE_HIT { /* @@ -504,6 +515,7 @@ * handler there. Global variables are used to pass the * context * to the other stack. */ + tramp_signal = signal; tramp_code = *code; tramp_context = *context; @@ -512,17 +524,6 @@ } #endif -#if defined(GENCGC) -#if defined(SIGSEGV_VERBOSE) - fprintf(stderr, "Signal %d, fault_addr=%x, page_index=%d:\n", - signal, fault_addr, page_index); -#endif - if (gc_write_barrier(code->si_addr)) - return; -#else - if (interrupt_maybe_gc(signal, code, context)) - return; -#endif /* a *real* protection fault */ fprintf(stderr, "sigbus_handler: Real protection violation: %p\n", fault_addr); sigbus_handle_now(signal, code, context);

1 0

[cmucl-cvs] CMUCL commit: src/lisp (13 files)
by Raymond Toy 01 Sep '11

01 Sep '11

Date: Wednesday, August 31, 2011 @ 22:18:26 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Modified: Darwin-os.c FreeBSD-os.c Linux-os.c NetBSD-os.c OpenBSD-os.c hpux-os.c irix-os.c lisp.c mach-os.c os.h osf1-os.c solaris-os.c sunos-os.c Add os_init0 to allow for some really early OS inits. On Linux, os_init can re-exec lisp to set up the correct personality. Not normally a problem, but if any output happens before os_init is called, the output appears to happen twice. So add os_init0 to do this early on, before any output. This is a bit of a kludge. lisp/lisp.c: o Call os_init0 early in main. lisp/Linux-os.c: o Move the personality stuff from os_init to os_init0. lisp/Darwin-os.c: lisp/FreeBSD-os.c: lisp/NetBSD-os.c: lisp/OpenBSD-os.c: lisp/hpux-os.c: lisp/irix-os.c: lisp/mach-os.c: lisp/osf1-os.c: lisp/solaris-os.c: lisp/sunos-os.c: o Add dummy implementation of os_init0. These OSes don't (currently) need anything special. lisp/os.h: o Declare os_init0. --------------+ Darwin-os.c | 5 ++++- FreeBSD-os.c | 6 +++++- Linux-os.c | 13 ++++++++++--- NetBSD-os.c | 6 +++++- OpenBSD-os.c | 6 +++++- hpux-os.c | 6 +++++- irix-os.c | 6 +++++- lisp.c | 12 +++++++++++- mach-os.c | 6 +++++- os.h | 3 ++- osf1-os.c | 6 +++++- solaris-os.c | 6 +++++- sunos-os.c | 6 +++++- 13 files changed, 72 insertions(+), 15 deletions(-) Index: src/lisp/Darwin-os.c diff -u src/lisp/Darwin-os.c:1.32 src/lisp/Darwin-os.c:1.33 --- src/lisp/Darwin-os.c:1.32 Wed Aug 31 21:39:56 2011 +++ src/lisp/Darwin-os.c Wed Aug 31 22:18:26 2011 @@ -14,7 +14,7 @@ * Frobbed for OpenBSD by Pierre R. Mai, 2001. * Frobbed for Darwin by Pierre R. Mai, 2003. * - * $Header: /project/cmucl/cvsroot/src/lisp/Darwin-os.c,v 1.32 2011/09/01 04:39:56 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/Darwin-os.c,v 1.33 2011/09/01 05:18:26 rtoy Exp $ * */ @@ -99,6 +99,9 @@ } #endif +void +os_init0(const char *argv[], const char *envp[]) +{} void os_init(const char *argv[], const char *envp[]) Index: src/lisp/FreeBSD-os.c diff -u src/lisp/FreeBSD-os.c:1.37 src/lisp/FreeBSD-os.c:1.38 --- src/lisp/FreeBSD-os.c:1.37 Sun Dec 26 08:04:43 2010 +++ src/lisp/FreeBSD-os.c Wed Aug 31 22:18:26 2011 @@ -12,7 +12,7 @@ * Much hacked by Paul Werkowski * GENCGC support by Douglas Crosher, 1996, 1997. * - * $Header: /project/cmucl/cvsroot/src/lisp/FreeBSD-os.c,v 1.37 2010/12/26 16:04:43 rswindells Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/FreeBSD-os.c,v 1.38 2011/09/01 05:18:26 rtoy Exp $ * */ @@ -39,6 +39,10 @@ vm_size_t os_vm_page_size; void +os_init0(const char *argv[], const char *envp[]) +{} + +void os_init(const char *argv[], const char *envp[]) { os_vm_page_size = getpagesize(); Index: src/lisp/Linux-os.c diff -u src/lisp/Linux-os.c:1.51 src/lisp/Linux-os.c:1.52 --- src/lisp/Linux-os.c:1.51 Sun Dec 26 08:04:43 2010 +++ src/lisp/Linux-os.c Wed Aug 31 22:18:26 2011 @@ -15,7 +15,7 @@ * GENCGC support by Douglas Crosher, 1996, 1997. * Alpha support by Julian Dolby, 1999. * - * $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.c,v 1.51 2010/12/26 16:04:43 rswindells Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/Linux-os.c,v 1.52 2011/09/01 05:18:26 rtoy Exp $ * */ @@ -132,6 +132,15 @@ } void +os_init0(const char *argv[], const char *envp[]) +{ + struct utsname name; + + uname(&name); + check_personality(&name, argv, envp); +} + +void os_init(const char *argv[], const char *envp[]) { struct utsname name; @@ -146,8 +155,6 @@ } os_vm_page_size = getpagesize(); - - check_personality(&name, argv, envp); } #ifdef __i386 Index: src/lisp/NetBSD-os.c diff -u src/lisp/NetBSD-os.c:1.19 src/lisp/NetBSD-os.c:1.20 --- src/lisp/NetBSD-os.c:1.19 Sun Dec 26 08:04:43 2010 +++ src/lisp/NetBSD-os.c Wed Aug 31 22:18:26 2011 @@ -15,7 +15,7 @@ * Frobbed for OpenBSD by Pierre R. Mai, 2001. * Frobbed for NetBSD by Pierre R. Mai, 2002. * - * $Header: /project/cmucl/cvsroot/src/lisp/NetBSD-os.c,v 1.19 2010/12/26 16:04:43 rswindells Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/NetBSD-os.c,v 1.20 2011/09/01 05:18:26 rtoy Exp $ * */ @@ -46,6 +46,10 @@ void +os_init0(const char *argv[], const char *envp[]) +{} + +void os_init(const char *argv[], const char *envp[]) { os_vm_page_size = OS_VM_DEFAULT_PAGESIZE; Index: src/lisp/OpenBSD-os.c diff -u src/lisp/OpenBSD-os.c:1.10 src/lisp/OpenBSD-os.c:1.11 --- src/lisp/OpenBSD-os.c:1.10 Mon Feb 1 08:04:43 2010 +++ src/lisp/OpenBSD-os.c Wed Aug 31 22:18:26 2011 @@ -13,7 +13,7 @@ * GENCGC support by Douglas Crosher, 1996, 1997. * Frobbed for OpenBSD by Pierre R. Mai, 2001. * - * $Header: /project/cmucl/cvsroot/src/lisp/OpenBSD-os.c,v 1.10 2010/02/01 16:04:43 rtoy Rel $ + * $Header: /project/cmucl/cvsroot/src/lisp/OpenBSD-os.c,v 1.11 2011/09/01 05:18:26 rtoy Exp $ * */ @@ -41,6 +41,10 @@ void +os_init0(const char *argv[], const char *envp[]) +{} + +void os_init(const char *argv[], const char *envp[]) { os_vm_page_size = OS_VM_DEFAULT_PAGESIZE; Index: src/lisp/hpux-os.c diff -u src/lisp/hpux-os.c:1.10 src/lisp/hpux-os.c:1.11 --- src/lisp/hpux-os.c:1.10 Mon Feb 1 08:04:43 2010 +++ src/lisp/hpux-os.c Wed Aug 31 22:18:26 2011 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/hpux-os.c,v 1.10 2010/02/01 16:04:43 rtoy Rel $ + * $Header: /project/cmucl/cvsroot/src/lisp/hpux-os.c,v 1.11 2011/09/01 05:18:26 rtoy Exp $ * * OS-dependent routines. This file (along with os.h) exports an * OS-independent interface to the operating system VM facilities. @@ -53,6 +53,10 @@ } segments[MAX_SEGMENTS]; void +os_init0(const char *argv[], const char *envp[]) +{} + +void os_init(const char *argv[], const char *envp[]) { int i; Index: src/lisp/irix-os.c diff -u src/lisp/irix-os.c:1.6 src/lisp/irix-os.c:1.7 --- src/lisp/irix-os.c:1.6 Mon Feb 1 08:04:43 2010 +++ src/lisp/irix-os.c Wed Aug 31 22:18:26 2011 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/irix-os.c,v 1.6 2010/02/01 16:04:43 rtoy Rel $ + * $Header: /project/cmucl/cvsroot/src/lisp/irix-os.c,v 1.7 2011/09/01 05:18:26 rtoy Exp $ * * OS-dependent routines. This file (along with os.h) exports an * OS-independent interface to the operating system VM facilities. @@ -30,6 +30,10 @@ int zero_fd; void +os_init0(const char *argv[], const char *envp[]) +{} + +void os_init(const char *argv[], const char *envp[]) { zero_fd = open("/dev/zero", O_RDONLY); Index: src/lisp/lisp.c diff -u src/lisp/lisp.c:1.83 src/lisp/lisp.c:1.84 --- src/lisp/lisp.c:1.83 Fri Jun 10 12:32:31 2011 +++ src/lisp/lisp.c Wed Aug 31 22:18:26 2011 @@ -1,7 +1,7 @@ /* * main() entry point for a stand alone lisp image. * - * $Header: /project/cmucl/cvsroot/src/lisp/lisp.c,v 1.83 2011/06/10 19:32:31 rtoy Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/lisp.c,v 1.84 2011/09/01 05:18:26 rtoy Exp $ * */ @@ -461,6 +461,16 @@ } + /* + * Do any special OS initialization that needs to be done early. + * In particular, on Linux, we might re-exec ourselves to set our + * personality correctly. Not normally a problem, but this does + * cause any output to happen twice. That can be confusing. + * + * So make sure we don't do any output before this point! + */ + + os_init0(argv, envp); #if defined(SVR4) tzset(); #endif Index: src/lisp/mach-os.c diff -u src/lisp/mach-os.c:1.8 src/lisp/mach-os.c:1.9 --- src/lisp/mach-os.c:1.8 Mon Feb 1 08:04:43 2010 +++ src/lisp/mach-os.c Wed Aug 31 22:18:26 2011 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/mach-os.c,v 1.8 2010/02/01 16:04:43 rtoy Rel $ + * $Header: /project/cmucl/cvsroot/src/lisp/mach-os.c,v 1.9 2011/09/01 05:18:26 rtoy Exp $ * * OS-dependent routines. This file (along with os.h) exports an * OS-independent interface to the operating system VM facilities. @@ -38,6 +38,10 @@ #endif void +os_init0(const char *argv[], const char *envp[]) +{} + +void os_init(const char *argv[], const char *envp[]) { os_vm_page_size = vm_page_size; Index: src/lisp/os.h diff -u src/lisp/os.h:1.27 src/lisp/os.h:1.28 --- src/lisp/os.h:1.27 Sun Dec 26 08:04:43 2010 +++ src/lisp/os.h Wed Aug 31 22:18:26 2011 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/os.h,v 1.27 2010/12/26 16:04:43 rswindells Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/os.h,v 1.28 2011/09/01 05:18:26 rtoy Exp $ * * Common interface for os-dependent functions. * @@ -72,6 +72,7 @@ extern os_vm_size_t os_vm_page_size; +extern void os_init0(const char *argv[], const char *envp[]); extern void os_init(const char *argv[], const char *envp[]); extern void os_install_interrupt_handlers(void); Index: src/lisp/osf1-os.c diff -u src/lisp/osf1-os.c:1.6 src/lisp/osf1-os.c:1.7 --- src/lisp/osf1-os.c:1.6 Mon Feb 1 08:04:43 2010 +++ src/lisp/osf1-os.c Wed Aug 31 22:18:26 2011 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/osf1-os.c,v 1.6 2010/02/01 16:04:43 rtoy Rel $ + * $Header: /project/cmucl/cvsroot/src/lisp/osf1-os.c,v 1.7 2011/09/01 05:18:26 rtoy Exp $ * * OS-dependent routines. This file (along with os.h) exports an * OS-independent interface to the operating system VM facilities. @@ -26,6 +26,10 @@ vm_size_t os_vm_page_size; void +os_init0(const char *argv[], const char *envp[]) +{} + +void os_init(const char *argv[], const char *envp[]) { int buf[2] = { SSIN_UACPROC, UAC_SIGBUS | UAC_NOPRINT }; Index: src/lisp/solaris-os.c diff -u src/lisp/solaris-os.c:1.29 src/lisp/solaris-os.c:1.30 --- src/lisp/solaris-os.c:1.29 Sun Dec 26 08:04:43 2010 +++ src/lisp/solaris-os.c Wed Aug 31 22:18:26 2011 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/solaris-os.c,v 1.29 2010/12/26 16:04:43 rswindells Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/solaris-os.c,v 1.30 2011/09/01 05:18:26 rtoy Exp $ * * OS-dependent routines. This file (along with os.h) exports an * OS-independent interface to the operating system VM facilities. @@ -73,6 +73,10 @@ } void +os_init0(const char *argv[], const char *envp[]) +{} + +void os_init(const char *argv[], const char *envp[]) { zero_fd = open(ZEROFILE, O_RDONLY); Index: src/lisp/sunos-os.c diff -u src/lisp/sunos-os.c:1.12 src/lisp/sunos-os.c:1.13 --- src/lisp/sunos-os.c:1.12 Mon Feb 1 08:04:43 2010 +++ src/lisp/sunos-os.c Wed Aug 31 22:18:26 2011 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/sunos-os.c,v 1.12 2010/02/01 16:04:43 rtoy Rel $ + * $Header: /project/cmucl/cvsroot/src/lisp/sunos-os.c,v 1.13 2011/09/01 05:18:26 rtoy Exp $ * * OS-dependent routines. This file (along with os.h) exports an * OS-independent interface to the operating system VM facilities. @@ -81,6 +81,10 @@ } void +os_init0(const char *argv[], const char *envp[]) +{} + +void os_init(const char *argv[], const char *envp[]) { char *empty_file = getenv("CMUCL_EMPTYFILE");

1 0

[cmucl-cvs] CMUCL commit: src (general-info/release-20c.txt lisp/Darwin-os.c)
by Raymond Toy 01 Sep '11

01 Sep '11

Date: Wednesday, August 31, 2011 @ 21:39:56 Author: rtoy Path: /project/cmucl/cvsroot/src Modified: general-info/release-20c.txt lisp/Darwin-os.c Make the stack checking feature actually work on Darwin. Previously, stack overflows would crash lisp. Darwin-os.c: o Need to check for stack overflow in the sigbus handler. (Without that, it's treated as a regular bus error.) o Add the rest of the infrastructure to handle the stack overflow. release-20c.txt: o Update ------------------------------+ general-info/release-20c.txt | 3 +++ lisp/Darwin-os.c | 41 +++++++++++++++++++++++++++++++++++++++-- 2 files changed, 42 insertions(+), 2 deletions(-) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.30 src/general-info/release-20c.txt:1.31 --- src/general-info/release-20c.txt:1.30 Mon Aug 22 21:16:04 2011 +++ src/general-info/release-20c.txt Wed Aug 31 21:39:55 2011 @@ -138,6 +138,9 @@ signals an error in DGETTEXT trying to translate the null documentation string. - Reduce unnecessary consing of SAPs in ROOM. + - Make stack overflow checking actually work on Mac OS X. The + implementation had the :stack-checking feature, but it didn't + actually prevent stack overflows from crashing lisp. * Trac Tickets: Index: src/lisp/Darwin-os.c diff -u src/lisp/Darwin-os.c:1.31 src/lisp/Darwin-os.c:1.32 --- src/lisp/Darwin-os.c:1.31 Sun Dec 26 08:04:43 2010 +++ src/lisp/Darwin-os.c Wed Aug 31 21:39:56 2011 @@ -14,7 +14,7 @@ * Frobbed for OpenBSD by Pierre R. Mai, 2001. * Frobbed for Darwin by Pierre R. Mai, 2003. * - * $Header: /project/cmucl/cvsroot/src/lisp/Darwin-os.c,v 1.31 2010/12/26 16:04:43 rswindells Exp $ + * $Header: /project/cmucl/cvsroot/src/lisp/Darwin-os.c,v 1.32 2011/09/01 04:39:56 rtoy Exp $ * */ @@ -453,6 +453,23 @@ return FALSE; } +static void +sigbus_handle_now(HANDLER_ARGS) +{ + interrupt_handle_now(signal, code, context); +} + + +static int tramp_signal; +static siginfo_t tramp_code; +static ucontext_t tramp_context; + +static void +sigbus_handler_tramp(void) +{ + sigbus_handle_now(tramp_signal, &tramp_code, &tramp_context); +} + static void sigbus_handler(HANDLER_ARGS) @@ -461,6 +478,11 @@ caddr_t fault_addr = code->si_addr; #endif +#ifdef RED_ZONE_HIT + if (os_control_stack_overflow((void *) fault_addr, context)) + return; +#endif + #ifdef __ppc__ DPRINTF(0, (stderr, "sigbus:\n")); DPRINTF(0, (stderr, " PC = %p\n", SC_PC(context))); @@ -472,6 +494,21 @@ DPRINTF(0, (stderr, " foreign_function_call = %d\n", foreign_function_call_active)); #endif +#ifdef RED_ZONE_HIT + { + /* + * Switch back to the normal stack and invoke the Lisp signal + * handler there. Global variables are used to pass the + * context * to the other stack. + */ + tramp_signal = signal; + tramp_code = *code; + tramp_context = *context; + SC_PC(context) = sigbus_handler_tramp; + return; + } +#endif + #if defined(GENCGC) #if defined(SIGSEGV_VERBOSE) fprintf(stderr, "Signal %d, fault_addr=%x, page_index=%d:\n", @@ -485,7 +522,7 @@ #endif /* a *real* protection fault */ fprintf(stderr, "sigbus_handler: Real protection violation: %p\n", fault_addr); - interrupt_handle_now(signal, code, context); + sigbus_handle_now(signal, code, context); #ifdef __ppc__ /* Work around G5 bug; fix courtesy gbyers via chandler */ sigreturn(context);

1 0

[cmucl-cvs] CMUCL commit: src (contrib/asdf/asdf.lisp general-info/release-20c.txt)
by Raymond Toy 23 Aug '11

23 Aug '11

Date: Monday, August 22, 2011 @ 21:16:04 Author: rtoy Path: /project/cmucl/cvsroot/src Modified: contrib/asdf/asdf.lisp general-info/release-20c.txt contrib/asdf/asdf.lisp general-info/release-20c.txt o Update to asdf2 2.017. ------------------------------+ contrib/asdf/asdf.lisp | 518 ++++++++++++++++++++--------------------- general-info/release-20c.txt | 2 2 files changed, 260 insertions(+), 260 deletions(-) Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.15 src/contrib/asdf/asdf.lisp:1.16 --- src/contrib/asdf/asdf.lisp:1.15 Wed Jun 8 08:42:22 2011 +++ src/contrib/asdf/asdf.lisp Mon Aug 22 21:16:04 2011 @@ -1,5 +1,5 @@ ;;; -*- mode: common-lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.016: Another System Definition Facility. +;;; This is ASDF 2.017: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -50,7 +50,7 @@ (cl:in-package #-genera :common-lisp-user #+genera :future-common-lisp-user) #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) -(error "ASDF is not supported on your implementation. Please help us with it.") +(error "ASDF is not supported on your implementation. Please help us port it.") #+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this @@ -62,6 +62,11 @@ (remove "asdf" excl::*autoload-package-name-alist* :test 'equalp :key 'car)) ; need that BEFORE any mention of package ASDF as below #+(and ecl (not ecl-bytecmp)) (require :cmp) + #+gcl ;; Debian's GCL 2.7 has bugs with compiling multiple-value stuff, but can run ASDF 2.011 + (when (or (< system::*gcl-major-version* 2) ;; GCL 2.6 fails to fully compile ASDF at all + (and (= system::*gcl-major-version* 2) + (< system::*gcl-minor-version* 7))) + (pushnew :gcl-pre2.7 *features*)) #+(and (or win32 windows mswindows mingw32) (not cygwin)) (pushnew :asdf-windows *features*) #+(or unix cygwin) (pushnew :asdf-unix *features*) ;;; make package if it doesn't exist yet. @@ -84,14 +89,15 @@ ;; Strip out formatting that is not supported on Genera. ;; Has to be inside the eval-when to make Lispworks happy (!) (defmacro compatfmt (format) - #-genera format - #+genera + #-(or gcl genera) format + #+(or gcl genera) (loop :for (unsupported . replacement) :in - '(("~@<" . "") - ("; ~@;" . "; ") - ("~3i~_" . "") - ("~@:>" . "") - ("~:>" . "")) :do + `(("~3i~_" . "") + #+genera + ,@(("~@<" . "") + ("; ~@;" . "; ") + ("~@:>" . "") + ("~:>" . ""))) :do (loop :for found = (search unsupported format) :while found :do (setf format (concatenate 'simple-string @@ -106,7 +112,7 @@ ;; "2.345.6" would be a development version in the official upstream ;; "2.345.0.7" would be your seventh local modification of official release 2.345 ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 - (asdf-version "2.016") + (asdf-version "2.017") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -194,12 +200,13 @@ :do (unintern old user))) (loop :for x :in newly-exported-symbols :do (export (intern* x package))))) - (ensure-package (name &key nicknames use unintern fmakunbound shadow export) + (ensure-package (name &key nicknames use unintern fmakunbound + shadow export redefined-functions) (let* ((p (ensure-exists name nicknames use))) (ensure-unintern p unintern) (ensure-shadow p shadow) (ensure-export p export) - (ensure-fmakunbound p fmakunbound) + (ensure-fmakunbound p (append fmakunbound redefined-functions)) p))) (macrolet ((pkgdcl (name &key nicknames use export @@ -207,8 +214,9 @@ `(ensure-package ',name :nicknames ',nicknames :use ',use :export ',export :shadow ',shadow - :unintern ',(append #-(or gcl ecl) redefined-functions unintern) - :fmakunbound ',(append fmakunbound)))) + :unintern ',unintern + :redefined-functions ',redefined-functions + :fmakunbound ',fmakunbound))) (pkgdcl :asdf :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only. @@ -342,7 +350,6 @@ ;; #:ends-with #:ensure-directory-pathname #:getenv - ;; #:get-uid ;; #:length=n-p ;; #:find-symbol* #:merge-pathnames* @@ -367,12 +374,6 @@ ;;;; ------------------------------------------------------------------------- ;;;; User-visible parameters ;;;; -(defun asdf-version () - "Exported interface to the version of ASDF currently installed. A string. -You can compare this string with e.g.: -(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." - *asdf-version*) - (defvar *resolve-symlinks* t "Determine whether or not ASDF resolves symlinks when defining systems. @@ -415,27 +416,37 @@ condition-arguments condition-form condition-format condition-location coerce-name) - #-cormanlisp + #-(or cormanlisp gcl-pre2.7) (ftype (function (t t) t) (setf module-components-by-name))) ;;;; ------------------------------------------------------------------------- -;;;; Compatibility with Corman Lisp +;;;; Compatibility various implementations #+cormanlisp (progn (deftype logical-pathname () nil) - (defun make-broadcast-stream () *error-output*) - (defun file-namestring (p) + (defun* make-broadcast-stream () *error-output*) + (defun* file-namestring (p) (setf p (pathname p)) - (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))) - (defparameter *count* 3) - (defun dbg (&rest x) - (format *error-output* "~S~%" x))) -#+cormanlisp -(defun maybe-break () - (decf *count*) - (unless (plusp *count*) - (setf *count* 3) - (break))) + (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) + +#.(or #+mcl ;; the #$ doesn't work on other lisps, even protected by #+mcl + (read-from-string + "(eval-when (:compile-toplevel :load-toplevel :execute) + (ccl:define-entry-point (_getenv \"getenv\") ((name :string)) :string) + (ccl:define-entry-point (_system \"system\") ((name :string)) :int) + ;; Note: ASDF may expect user-homedir-pathname to provide + ;; the pathname of the current user's home directory, whereas + ;; MCL by default provides the directory from which MCL was started. + ;; See http://code.google.com/p/mcl/wiki/Portability + (defun current-user-homedir-pathname () + (ccl::findfolder #$kuserdomain #$kCurrentUserFolderType)) + (defun probe-posix (posix-namestring) + \"If a file exists for the posix namestring, return the pathname\" + (ccl::with-cstrs ((cpath posix-namestring)) + (ccl::rlet ((is-dir :boolean) + (fsref :fsref)) + (when (eq #$noerr (#_fspathmakeref cpath fsref is-dir)) + (ccl::%path-from-fsref fsref is-dir))))))")) ;;;; ------------------------------------------------------------------------- ;;;; General Purpose Utilities @@ -444,7 +455,7 @@ ((defdef (def* def) `(defmacro ,def* (name formals &rest rest) `(progn - #+(or ecl gcl) (fmakunbound ',name) + #+(or ecl (and gcl (not gcl-pre2.7))) (fmakunbound ',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))) @@ -515,8 +526,11 @@ :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) (defun* merge-pathnames* (specified &optional (defaults *default-pathname-defaults*)) - "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that if the SPECIFIED pathname -does not have an absolute directory, then the HOST and DEVICE come from the DEFAULTS. + "MERGE-PATHNAMES* is like MERGE-PATHNAMES except that +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. Also, if either argument is NIL, then the other argument is returned unmodified." (when (null specified) (return-from merge-pathnames* defaults)) (when (null defaults) (return-from merge-pathnames* specified)) @@ -559,7 +573,6 @@ '(:relative :back) (pathname-directory pathname)) :defaults pathname))) - (define-modify-macro appendf (&rest args) append "Append onto list") ;; only to be used on short lists. @@ -660,10 +673,6 @@ :unless (eq k key) :append (list k v))) -#+mcl -(eval-when (:compile-toplevel :load-toplevel :execute) - (ccl:define-entry-point (_getenv "getenv") ((name :string)) :string)) - (defun* getenv (x) (declare (ignorable x)) #+(or abcl clisp xcl) (ext:getenv x) @@ -730,7 +739,7 @@ #+genera (unless (fboundp 'ensure-directories-exist) - (defun ensure-directories-exist (path) + (defun* ensure-directories-exist (path) (fs:create-directories-recursively (pathname path)))) (defun* absolute-pathname-p (pathspec) @@ -760,30 +769,6 @@ :until (eq form eof) :collect form))) -#+asdf-unix -(progn - #+ecl #.(cl:and (cl:< ext:+ecl-version-number+ 100601) - '(ffi:clines "#include <sys/types.h>" "#include <unistd.h>")) - (defun* get-uid () - #+allegro (excl.osi:getuid) - #+ccl (ccl::getuid) - #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") - :for f = (ignore-errors (read-from-string s)) - :when f :return (funcall f)) - #+(or cmu scl) (unix:unix-getuid) - #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601) - '(ffi:c-inline () () :int "getuid()" :one-liner t) - '(ext::getuid)) - #+sbcl (sb-unix:unix-getuid) - #-(or allegro ccl clisp cmu ecl sbcl scl) - (let ((uid-string - (with-output-to-string (*verbose-out*) - (run-shell-command "id -ur")))) - (with-input-from-string (stream uid-string) - (read-line stream) - (handler-case (parse-integer (read-line stream)) - (error () (error "Unable to find out user ID"))))))) - (defun* pathname-root (pathname) (make-pathname :directory '(:absolute) :name nil :type nil :version nil @@ -798,22 +783,25 @@ (null nil) (string (probe-file* (parse-namestring p))) (pathname (unless (wild-pathname-p p) - #.(or #+(or allegro clozure cmu cormanlisp ecl sbcl scl) '(probe-file p) + #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl) + '(probe-file p) #+clisp (aif (find-symbol* '#:probe-pathname :ext) `(ignore-errors (,it p))) '(ignore-errors (truename p))))))) -(defun* truenamize (p) +(defun* truenamize (pathname &optional (defaults *default-pathname-defaults*)) "Resolve as much of a pathname as possible" (block nil - (when (typep p '(or null logical-pathname)) (return p)) - (let* ((p (merge-pathnames* p)) - (directory (pathname-directory p))) + (when (typep pathname '(or null logical-pathname)) (return pathname)) + (let ((p (merge-pathnames* pathname defaults))) (when (typep p 'logical-pathname) (return p)) (let ((found (probe-file* p))) (when found (return found))) - #-(or cmu sbcl scl) (when (stringp directory) (return p)) - (when (not (eq :absolute (car directory))) (return p)) + (unless (absolute-pathname-p p) + (let ((true-defaults (ignore-errors (truename defaults)))) + (when true-defaults + (setf p (merge-pathnames pathname true-defaults))))) + (unless (absolute-pathname-p p) (return p)) (let ((sofar (probe-file* (pathname-root p)))) (unless sofar (return p)) (flet ((solution (directories) @@ -824,7 +812,9 @@ :type (pathname-type p) :version (pathname-version p)) sofar))) - (loop :for component :in (cdr directory) + (loop :with directory = (normalize-pathname-directory-component + (pathname-directory p)) + :for component :in (cdr directory) :for rest :on (cdr directory) :for more = (probe-file* (merge-pathnames* @@ -847,7 +837,7 @@ (and path (resolve-symlinks path)) path)) -(defun ensure-pathname-absolute (path) +(defun* ensure-pathname-absolute (path) (cond ((absolute-pathname-p path) path) ((stringp path) (ensure-pathname-absolute (pathname path))) @@ -877,7 +867,7 @@ (merge-pathnames* *wild-path* path)) #-scl -(defun directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) +(defun* directory-separator-for-host (&optional (pathname *default-pathname-defaults*)) (let ((foo (make-pathname :directory '(:absolute "FOO") :defaults pathname))) (last-char (namestring foo)))) @@ -961,7 +951,7 @@ (defgeneric* (setf component-property) (new-value component property)) -(eval-when (:compile-toplevel :load-toplevel :execute) +(eval-when (#-gcl :compile-toplevel :load-toplevel :execute) (defgeneric* (setf module-components-by-name) (new-value module))) (defgeneric* version-satisfies (component version)) @@ -1270,8 +1260,8 @@ (slot-value component 'absolute-pathname) (let ((pathname (merge-pathnames* - (component-relative-pathname component) - (pathname-directory-pathname (component-parent-pathname component))))) + (component-relative-pathname component) + (pathname-directory-pathname (component-parent-pathname component))))) (unless (or (null pathname) (absolute-pathname-p pathname)) (error (compatfmt "~@<Invalid relative pathname ~S for component ~S~@:>") pathname (component-find-path component))) @@ -1312,7 +1302,13 @@ (return-from version-satisfies t)) (version-satisfies (component-version c) version)) -(defun parse-version (string &optional on-error) +(defun* asdf-version () + "Exported interface to the version of ASDF currently installed. A string. +You can compare this string with e.g.: +(ASDF:VERSION-SATISFIES (ASDF:ASDF-VERSION) \"2.345.67\")." + *asdf-version*) + +(defun* parse-version (string &optional on-error) "Parse a version string as a series of natural integers separated by dots. Return a (non-null) list of integers if the string is valid, NIL otherwise. If on-error is error, warn, or designates a function of compatible signature, @@ -1427,11 +1423,9 @@ (defun* probe-asd (name defaults) (block nil (when (directory-pathname-p defaults) - (let ((file - (make-pathname - :defaults defaults :version :newest :case :local - :name name - :type "asd"))) + (let ((file (make-pathname + :defaults defaults :name name + :version :newest :case :local :type "asd"))) (when (probe-file* file) (return file))) #+(and asdf-windows (not clisp)) @@ -2113,7 +2107,7 @@ (flags :initarg :flags :accessor compile-op-flags :initform nil))) -(defun output-file (operation component) +(defun* output-file (operation component) "The unique output file of performing OPERATION on COMPONENT" (let ((files (output-files operation component))) (assert (length=n-p files 1)) @@ -2144,8 +2138,8 @@ (*compile-file-warnings-behaviour* (operation-on-warnings operation)) (*compile-file-failure-behaviour* (operation-on-failure operation))) (multiple-value-bind (output warnings-p failure-p) - (apply *compile-op-compile-file-function* source-file :output-file output-file - (compile-op-flags operation)) + (apply *compile-op-compile-file-function* source-file + :output-file output-file (compile-op-flags operation)) (unless output (error 'compile-error :component c :operation operation)) (when failure-p @@ -2366,7 +2360,7 @@ (t (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") version new-version))) - (let ((asdf (find-system :asdf))) + (let ((asdf (funcall (find-symbol* 'find-system :asdf) :asdf))) ;; invalidate all systems but ASDF itself (setf *defined-systems* (make-defined-systems-table)) (register-system asdf) @@ -2602,7 +2596,7 @@ components pathname default-component-class perform explain output-files operation-done-p weakly-depends-on - depends-on serial in-order-to + depends-on serial in-order-to do-first (version nil versionp) ;; list ends &allow-other-keys) options @@ -2663,7 +2657,10 @@ in-order-to `((compile-op (compile-op ,@depends-on)) (load-op (load-op ,@depends-on))))) - (setf (component-do-first ret) `((compile-op (load-op ,@depends-on)))) + (setf (component-do-first ret) + (union-of-dependencies + do-first + `((compile-op (load-op ,@depends-on))))) (%refresh-component-inline-methods ret rest) ret))) @@ -2747,6 +2744,13 @@ :input nil :output *verbose-out* :wait t))) + #+(or cmu scl) + (ext:process-exit-code + (ext:run-program + "/bin/sh" + (list "-c" command) + :input nil :output *verbose-out*)) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll (si:system command) @@ -2761,6 +2765,9 @@ :prefix "" :output-stream *verbose-out*) + #+mcl + (ccl::with-cstrs ((%command command)) (_system %command)) + #+sbcl (sb-ext:process-exit-code (apply 'sb-ext:run-program @@ -2769,17 +2776,10 @@ :input nil :output *verbose-out* #+win32 '(:search t) #-win32 nil)) - #+(or cmu scl) - (ext:process-exit-code - (ext:run-program - "/bin/sh" - (list "-c" command) - :input nil :output *verbose-out*)) - #+xcl (ext:run-shell-command command) - #-(or abcl allegro clisp clozure cmu ecl gcl lispworks sbcl scl xcl) + #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl) (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) ;;;; --------------------------------------------------------------------------- @@ -2807,9 +2807,7 @@ "Return a pathname object corresponding to the directory in which the system specification (.asd file) is located." - (make-pathname :name nil - :type nil - :defaults (system-source-file system-designator))) + (pathname-directory-pathname (system-source-file system-designator))) (defun* relativize-directory (directory) (cond @@ -2836,109 +2834,77 @@ ;;; implementation-identifier ;;; ;;; produce a string to identify current implementation. -;;; Initially stolen from SLIME's SWANK, hacked since. +;;; Initially stolen from SLIME's SWANK, rewritten since. +;;; The (car '(...)) idiom avoids unreachable code warnings. -(defparameter *implementation-features* - '((:abcl :armedbear) - (:acl :allegro) - (:mcl :digitool) ; before clozure, so it won't get preempted by ccl - (:ccl :clozure) - (:corman :cormanlisp) - (:lw :lispworks) - :clisp :cmu :ecl :gcl :sbcl :scl :symbolics :xcl)) - -(defparameter *os-features* - '(:cygwin (:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows - (:solaris :sunos) - (:linux :linux-target) ;; for GCL at least, must appear before :bsd. - (:macosx :darwin :darwin-target :apple) - :freebsd :netbsd :openbsd :bsd - :unix - :genera)) - -(defparameter *architecture-features* - '((:x64 :amd64 :x86-64 :x86_64 :x8664-target #+(and clisp word-size=64) :pc386) - (:x86 :i386 :i486 :i586 :i686 :pentium3 :pentium4 :pc386 :iapx386 :x8632-target) - :hppa64 :hppa - (:ppc64 :ppc64-target) (:ppc32 :ppc32-target :ppc :powerpc) - :sparc64 (:sparc32 :sparc) - (:arm :arm-target) - (:java :java-1.4 :java-1.5 :java-1.6 :java-1.7) - :mipsel :mipseb :mips - :alpha - :imach)) +(defparameter *implementation-type* + (car '(#+abcl :abcl #+allegro :acl + #+clozure :ccl #+clisp :clisp #+cormanlisp :corman #+cmu :cmu + #+ecl :ecl #+gcl :gcl #+lispworks :lw #+mcl :mcl + #+sbcl :sbcl #+scl :scl #+symbolics :symbolic #+xcl :xcl))) + +(defparameter *operating-system* + (car '(#+cygwin :cygwin #+(or windows mswindows win32 mingw32) :win + #+(or linux linux-target) :linux ;; for GCL at least, must appear before :bsd. + #+(or macosx darwin darwin-target apple) :macosx ; also before :bsd + #+(or solaris sunos) :solaris + #+(or freebsd netbsd openbsd bsd) :bsd + #+unix :unix + #+genera :genera))) + +(defparameter *architecture* + (car '(#+(or amd64 x86-64 x86_64 x8664-target (and word-size=64 pc386)) :x64 + #+(or x86 i386 i486 i586 i686 pentium3 pentium4 pc386 iapx386 x8632-target) :x86 + #+hppa64 :hppa64 #+hppa :hppa + #+(or ppc64 ppc64-target) :ppc64 + #+(or ppc32 ppc32-target ppc powerpc) :ppc32 + #+sparc64 :sparc64 #+(or sparc32 sparc) :sparc32 + #+(or arm arm-target) :arm + #+(or java java-1.4 java-1.5 java-1.6 java-1.7) :java + #+mipsel :mispel #+mipseb :mipseb #+mips :mips + #+alpha :alpha #+imach :imach))) -(defun* lisp-version-string () +(defparameter *lisp-version-string* (let ((s (lisp-implementation-version))) (or - #+allegro (format nil - "~A~A~A" - excl::*common-lisp-version-number* - ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox - (if (eq excl:*current-case-mode* - :case-sensitive-lower) "M" "A") - ;; Note if not using International ACL - ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-targe… - (excl:ics-target-case - (:-ics "8") - (:+ics ""))) ; redundant? (if (member :64bit *features*) "-64bit" "")) + #+allegro + (format nil "~A~A~@[~A~]" + excl::*common-lisp-version-number* + ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox + (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A") + ;; Note if not using International ACL + ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-targe… + (excl:ics-target-case (:-ics "8"))) #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) - #+clisp (subseq s 0 (position #\space s)) ; strip build information (date, etc.) - #+clozure (format nil "~d.~d-f~d" ; shorten for windows - ccl::*openmcl-major-version* - ccl::*openmcl-minor-version* - (logand ccl::fasl-version #xFF)) + #+clisp + (subseq s 0 (position #\space s)) ; strip build information (date, etc.) + #+clozure + (format nil "~d.~d-f~d" ; shorten for windows + ccl::*openmcl-major-version* + ccl::*openmcl-minor-version* + (logand ccl::fasl-version #xFF)) #+cmu (substitute #\- #\/ s) #+ecl (format nil "~A~@[-~A~]" s - (let ((vcs-id (ext:lisp-implementation-vcs-id))) - (when (>= (length vcs-id) 8) - (subseq vcs-id 0 8)))) + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (subseq vcs-id 0 (min (length vcs-id) 8)))) #+gcl (subseq s (1+ (position #\space s))) - #+genera (multiple-value-bind (major minor) (sct:get-system-version "System") - (format nil "~D.~D" major minor)) - ;; #+lispworks (format nil "~A~@[~A~]" s (when (member :lispworks-64bit *features*) "-64bit") #+mcl (subseq s 8) ; strip the leading "Version " - ;; #+sbcl (format nil "~a-fasl~d" s sb-fasl:+fasl-file-version+) ; f-f-v redundant w/ version + #+genera + (multiple-value-bind (major minor) (sct:get-system-version "System") + (format nil "~D.~D" major minor)) + #+mcl (subseq s 8) ; strip the leading "Version " s))) -(defun* first-feature (features) - (labels - ((fp (thing) - (etypecase thing - (symbol - (let ((feature (find thing *features*))) - (when feature (return-from fp feature)))) - ;; allows features to be lists of which the first - ;; member is the "main name", the rest being aliases - (cons - (dolist (subf thing) - (when (find subf *features*) (return-from fp (first thing)))))) - nil)) - (loop :for f :in features - :when (fp f) :return :it))) - (defun* implementation-type () - (first-feature *implementation-features*)) + *implementation-type*) (defun* implementation-identifier () - (labels - ((maybe-warn (value fstring &rest args) - (cond (value) - (t (apply 'warn fstring args) - "unknown")))) - (let ((lisp (maybe-warn (implementation-type) - (compatfmt "~@<No implementation feature found in ~a.~@:>") - *implementation-features*)) - (os (maybe-warn (first-feature *os-features*) - (compatfmt "~@<No OS feature found in ~a.~@:>") *os-features*)) - (arch (or #-clisp - (maybe-warn (first-feature *architecture-features*) - (compatfmt "~@<No architecture feature found in ~a.~@:>") - *architecture-features*))) - (version (maybe-warn (lisp-version-string) - "Don't know how to get Lisp implementation version."))) - (substitute-if - #\_ #'(lambda (x) (find x " /:\\(){}[]$#`'\"")) - (format nil "~(~a~@{~@[-~a~]~}~)" lisp version os arch))))) + (substitute-if + #\_ #'(lambda (x) (find x " /:;&^\\|?<>(){}[]$#`'\"")) + (format nil "~(~a~@{~@[-~a~]~}~)" + (or *implementation-type* (lisp-implementation-type)) + (or *lisp-version-string* (lisp-implementation-version)) + (or *operating-system* (software-type)) + (or *architecture* (machine-type))))) ;;; --------------------------------------------------------------------------- @@ -2948,14 +2914,6 @@ #+asdf-unix #\: #-asdf-unix #\;) -;; Note: ASDF may expect user-homedir-pathname to provide the pathname of -;; the current user's home directory, while MCL by default provides the -;; directory from which MCL was started. -;; See http://code.google.com/p/mcl/wiki/Portability -#.(or #+mcl ;; the #$ doesn't work on other implementations, even inside #+mcl - `(defun current-user-homedir-pathname () - ,(read-from-string "(ccl::findfolder #$kuserdomain #$kCurrentUserFolderType))"))) - (defun* user-homedir () (truenamize (pathname-directory-pathname @@ -3121,10 +3079,6 @@ (getenv "APPDATA")) "common-lisp" "cache" :implementation) '(:home ".cache" "common-lisp" :implementation)))) -(defvar *system-cache* - ;; No good default, plus there's a security problem - ;; with other users messing with such directories. - *user-cache*) (defun* output-translations () (car *output-translations*)) @@ -3155,35 +3109,32 @@ (values (or null pathname) &optional)) resolve-location)) -(defun* resolve-relative-location-component (super x &key directory wilden) - (let* ((r (etypecase x - (pathname x) - (string x) - (cons - (return-from resolve-relative-location-component - (if (null (cdr x)) +(defun* resolve-relative-location-component (x &key directory wilden) + (let ((r (etypecase x + (pathname x) + (string (coerce-pathname x :type (when directory :directory))) + (cons + (if (null (cdr x)) + (resolve-relative-location-component + (car x) :directory directory :wilden wilden) + (let* ((car (resolve-relative-location-component + (car x) :directory t :wilden nil))) + (merge-pathnames* (resolve-relative-location-component - super (car x) :directory directory :wilden wilden) - (let* ((car (resolve-relative-location-component - super (car x) :directory t :wilden nil)) - (cdr (resolve-relative-location-component - (merge-pathnames* car super) (cdr x) - :directory directory :wilden wilden))) - (merge-pathnames* cdr car))))) - ((eql :default-directory) - (relativize-pathname-directory (default-directory))) - ((eql :*/) *wild-directory*) - ((eql :**/) *wild-inferiors*) - ((eql :*.*.*) *wild-file*) - ((eql :implementation) (implementation-identifier)) - ((eql :implementation-type) (string-downcase (implementation-type))) - #+asdf-unix - ((eql :uid) (princ-to-string (get-uid))))) - (d (if (or (pathnamep x) (not directory)) r (ensure-directory-pathname r))) - (s (if (or (pathnamep x) (not wilden)) d (wilden d)))) - (when (and (absolute-pathname-p s) (not (pathname-match-p s (wilden super)))) - (error (compatfmt "~@<Pathname ~S is not relative to ~S~@:>") s super)) - (merge-pathnames* s super))) + (cdr x) :directory directory :wilden wilden) + car)))) + ((eql :default-directory) + (relativize-pathname-directory (default-directory))) + ((eql :*/) *wild-directory*) + ((eql :**/) *wild-inferiors*) + ((eql :*.*.*) *wild-file*) + ((eql :implementation) + (coerce-pathname (implementation-identifier) :type :directory)) + ((eql :implementation-type) + (coerce-pathname (string-downcase (implementation-type)) :type :directory))))) + (when (absolute-pathname-p r) + (error (compatfmt "~@<pathname ~S is not relative~@:>") x)) + (if (or (pathnamep x) (not wilden)) r (wilden r)))) (defvar *here-directory* nil "This special variable is bound to the currect directory during calls to @@ -3194,17 +3145,19 @@ (let* ((r (etypecase x (pathname x) - (string (if directory (ensure-directory-pathname x) (parse-namestring x))) + (string (let ((p (#+mcl probe-posix #-mcl parse-namestring x))) + #+mcl (unless p (error "POSIX pathname ~S does not exist" x)) + (if directory (ensure-directory-pathname p) p))) (cons (return-from resolve-absolute-location-component (if (null (cdr x)) (resolve-absolute-location-component (car x) :directory directory :wilden wilden) - (let* ((car (resolve-absolute-location-component - (car x) :directory t :wilden nil)) - (cdr (resolve-relative-location-component - car (cdr x) :directory directory :wilden wilden))) - (merge-pathnames* cdr car))))) ; XXX why is this not just "cdr" ? + (merge-pathnames* + (resolve-relative-location-component + (cdr x) :directory directory :wilden wilden) + (resolve-absolute-location-component + (car x) :directory t :wilden nil))))) ((eql :root) ;; special magic! we encode such paths as relative pathnames, ;; but it means "relative to the root of the source pathname's host and device". @@ -3219,15 +3172,14 @@ :directory t :wilden nil)) ((eql :user-cache) (resolve-location *user-cache* :directory t :wilden nil)) ((eql :system-cache) - (warn "Using the :system-cache is deprecated. ~%~ -Please remove it from your ASDF configuration") - (resolve-location *system-cache* :directory t :wilden nil)) + (error "Using the :system-cache is deprecated. ~%~ +Please remove it from your ASDF configuration")) ((eql :default-directory) (default-directory)))) (s (if (and wilden (not (pathnamep x))) (wilden r) r))) (unless (absolute-pathname-p s) - (error (compatfmt "~@<Not an absolute pathname: ~3i~_~S~@:>") s)) + (error (compatfmt "~@<Invalid designator for an absolute pathname: ~3i~_~S~@:>") x)) s)) (defun* resolve-location (x &key directory wilden) @@ -3239,8 +3191,10 @@ :for (component . morep) :on (cdr x) :for dir = (and (or morep directory) t) :for wild = (and wilden (not morep)) - :do (setf path (resolve-relative-location-component - path component :directory dir :wilden wild)) + :do (setf path (merge-pathnames* + (resolve-relative-location-component + component :directory dir :wilden wild) + path)) :finally (return path)))) (defun* location-designator-p (x) @@ -3523,11 +3477,13 @@ (defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys) (if (absolute-pathname-p output-file) - (apply 'compile-file-pathname (lispize-pathname input-file) keys) + ;; what cfp should be doing, w/ mp* instead of mp + (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys))) + (defaults (make-pathname + :type type :defaults (merge-pathnames* input-file)))) + (merge-pathnames* output-file defaults)) (apply-output-translations - (apply 'compile-file-pathname - (truenamize (lispize-pathname input-file)) - keys)))) + (apply 'compile-file-pathname input-file keys)))) (defun* tmpize-pathname (x) (make-pathname @@ -3728,11 +3684,37 @@ (defparameter *wild-asd* (make-pathname :directory nil :name *wild* :type "asd" :version :newest)) -(defun directory-asd-files (directory) - (ignore-errors - (directory* (merge-pathnames* *wild-asd* directory)))) +(defun* filter-logical-directory-results (directory entries merger) + (if (typep directory 'logical-pathname) + ;; 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 (typep f 'logical-pathname) f) + (let* ((u (ignore-errors (funcall merger f)))) + (and u (equal (ignore-errors (truename u)) f) u))) + :when p :collect p) + entries)) + +(defun* directory-files (directory &optional (pattern *wild-file*)) + (when (wild-pathname-p directory) + (error "Invalid wild in ~S" directory)) + (unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal) + (error "Invalid file pattern ~S" pattern)) + (let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory))))) + (filter-logical-directory-results + directory entries + #'(lambda (f) + (make-pathname :defaults directory :version (pathname-version f) + :name (pathname-name f) :type (pathname-type f)))))) + +(defun* directory-asd-files (directory) + (directory-files directory *wild-asd*)) -(defun subdirectories (directory) +(defun* subdirectories (directory) (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* @@ -3758,19 +3740,29 @@ :when d :collect #+(or abcl allegro xcl) d #+genera (ensure-directory-pathname (first x)) #+(or cmu lispworks scl) x))) - dirs)) + (filter-logical-directory-results + directory dirs + (let ((prefix (normalize-pathname-directory-component + (pathname-directory directory)))) + #'(lambda (d) + (let ((dir (normalize-pathname-directory-component + (pathname-directory d)))) + (and (consp dir) (consp (cdr dir)) + (make-pathname + :defaults directory :name nil :type nil :version nil + :directory (append prefix (last dir)))))))))) -(defun collect-asds-in-directory (directory collect) +(defun* collect-asds-in-directory (directory collect) (map () collect (directory-asd-files directory))) -(defun collect-sub*directories (directory collectp recursep collector) +(defun* collect-sub*directories (directory collectp recursep collector) (when (funcall collectp directory) (funcall collector directory)) (dolist (subdir (subdirectories directory)) (when (funcall recursep subdir) (collect-sub*directories subdir collectp recursep collector)))) -(defun collect-sub*directories-asd-files +(defun* collect-sub*directories-asd-files (directory &key (exclude *default-source-registry-exclusions*) collect) @@ -3985,7 +3977,15 @@ (register-asd-directory directory :recurse recurse :exclude exclude :collect #'(lambda (asd) - (let ((name (pathname-name 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) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.29 src/general-info/release-20c.txt:1.30 --- src/general-info/release-20c.txt:1.29 Sun Aug 21 08:16:01 2011 +++ src/general-info/release-20c.txt Mon Aug 22 21:16:04 2011 @@ -28,7 +28,7 @@ with all features available, except only Unicode is supported. * Changes - - ASDF2 updated to version 2.016. + - ASDF2 updated to version 2.017. - COMPILE-FILE now accepts a :DECODING-ERROR argument that indicates how to handle decoding errors when reading the file. It has the same meaning and effect as the :DECODING-ERROR

1 0

[cmucl-cvs] CMUCL commit: src (3 files)
by Raymond Toy 21 Aug '11

21 Aug '11

Date: Sunday, August 21, 2011 @ 08:16:01 Author: rtoy Path: /project/cmucl/cvsroot/src Modified: compiler/ltv.lisp compiler/main.lisp general-info/release-20c.txt Improve type progagation for LOAD-TIME-VALUE. Patch from Helmut Eller, cmucl-imp 2011-06-11. ------------------------------+ compiler/ltv.lisp | 6 +++--- compiler/main.lisp | 13 ++++++++----- general-info/release-20c.txt | 1 + 3 files changed, 12 insertions(+), 8 deletions(-) Index: src/compiler/ltv.lisp diff -u src/compiler/ltv.lisp:1.4 src/compiler/ltv.lisp:1.5 --- src/compiler/ltv.lisp:1.4 Mon Apr 19 08:08:20 2010 +++ src/compiler/ltv.lisp Sun Aug 21 08:16:01 2011 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/ltv.lisp,v 1.4 2010/04/19 15:08:20 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/compiler/ltv.lisp,v 1.5 2011/08/21 15:16:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -35,10 +35,10 @@ (compile-load-time-value (if read-only-p form `(make-value-cell ,form))) - (declare (ignore type)) (ir1-convert start cont (if read-only-p - `(%load-time-value ',handle) + `(truly-the ,(type-specifier type) + (%load-time-value ',handle)) `(value-cell-ref (%load-time-value ',handle))))) (let ((value (handler-case (eval form) Index: src/compiler/main.lisp diff -u src/compiler/main.lisp:1.160 src/compiler/main.lisp:1.161 --- src/compiler/main.lisp:1.160 Mon Mar 28 05:07:34 2011 +++ src/compiler/main.lisp Sun Aug 21 08:16:01 2011 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/main.lisp,v 1.160 2011/03/28 12:07:34 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/main.lisp,v 1.161 2011/08/21 15:16:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1246,10 +1246,13 @@ (let ((lambda (compile-load-time-stuff form name t))) (values (fasl-dump-load-time-value-lambda lambda *compile-object*) - (let ((type (leaf-type lambda))) - (if (function-type-p type) - (single-value-type (function-type-returns type)) - *wild-type*))))) + (or (let ((return (lambda-return lambda))) + (if return + (single-value-type (return-result-type return)))) + (let ((type (leaf-type lambda))) + (if (function-type-p type) + (single-value-type (function-type-returns type)))) + *wild-type*)))) ;;; COMPILE-MAKE-LOAD-FORM-INIT-FORMS -- internal. ;;; Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.28 src/general-info/release-20c.txt:1.29 --- src/general-info/release-20c.txt:1.28 Sun Aug 21 00:43:39 2011 +++ src/general-info/release-20c.txt Sun Aug 21 08:16:01 2011 @@ -57,6 +57,7 @@ - CMUCL no longer exits if you specify a core file with an executable image. A warning is printed instead and the core file is used. + - Improve type propagation for LOAD-TIME-VALUE. * ANSI compliance fixes: - Fixes for signaling errors with READ-CHAR and READ-BYTE

1 0

[cmucl-cvs] CMUCL commit: src (code/room.lisp general-info/release-20c.txt)
by Raymond Toy 21 Aug '11

21 Aug '11

Date: Sunday, August 21, 2011 @ 00:43:39 Author: rtoy Path: /project/cmucl/cvsroot/src Modified: code/room.lisp general-info/release-20c.txt Reduce consing of SAPs in ROOM. Patch from Helmut Eller, cmucl-imp 2011-08-11. ------------------------------+ code/room.lisp | 4 ++-- general-info/release-20c.txt | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) Index: src/code/room.lisp diff -u src/code/room.lisp:1.40 src/code/room.lisp:1.41 --- src/code/room.lisp:1.40 Tue Apr 20 10:57:45 2010 +++ src/code/room.lisp Sun Aug 21 00:43:38 2011 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/room.lisp,v 1.40 2010/04/20 17:57:45 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/room.lisp,v 1.41 2011/08/21 07:43:38 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -368,7 +368,7 @@ (fixnum (sap+ current size)) (memory-size (sap+ current size))))) (setf current c)))) - (declare (inline next)) + (declare (inline next maybe-finish-mapping)) (loop (maybe-finish-mapping) (maybe-skip-page) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.27 src/general-info/release-20c.txt:1.28 --- src/general-info/release-20c.txt:1.27 Tue Jul 12 10:24:26 2011 +++ src/general-info/release-20c.txt Sun Aug 21 00:43:39 2011 @@ -136,6 +136,7 @@ - Getting documentation of a structure via DOCUMENTATION no longer signals an error in DGETTEXT trying to translate the null documentation string. + - Reduce unnecessary consing of SAPs in ROOM. * Trac Tickets:

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 12 Jul '11

12 Jul '11

Date: Tuesday, July 12, 2011 @ 10:24:26 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Update from logs. -----------------+ release-20c.txt | 3 +++ 1 file changed, 3 insertions(+) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.26 src/general-info/release-20c.txt:1.27 --- src/general-info/release-20c.txt:1.26 Tue Jun 28 17:58:41 2011 +++ src/general-info/release-20c.txt Tue Jul 12 10:24:26 2011 @@ -133,6 +133,9 @@ Fix this by making sure KERNEL:%SQRT is defined. - Opening a file whose name contains "[" with :IF-EXISTS :NEW-VERSION no longer causes an error. + - Getting documentation of a structure via DOCUMENTATION no longer + signals an error in DGETTEXT trying to translate the null + documentation string. * Trac Tickets:

1 0

[cmucl-cvs] CMUCL commit: src/pcl (cmucl-documentation.lisp)
by Raymond Toy 12 Jul '11

12 Jul '11

Date: Tuesday, July 12, 2011 @ 10:19:50 Author: rtoy Path: /project/cmucl/cvsroot/src/pcl Modified: cmucl-documentation.lisp Don't call dgettext with a NIL doc. --------------------------+ cmucl-documentation.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/pcl/cmucl-documentation.lisp diff -u src/pcl/cmucl-documentation.lisp:1.18 src/pcl/cmucl-documentation.lisp:1.19 --- src/pcl/cmucl-documentation.lisp:1.18 Tue Dec 14 13:22:27 2010 +++ src/pcl/cmucl-documentation.lisp Tue Jul 12 10:19:50 2011 @@ -4,7 +4,7 @@ ;;; the public domain, and is provided 'as is'. (file-comment - "$Header: /project/cmucl/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.18 2010/12/14 21:22:27 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/pcl/cmucl-documentation.lisp,v 1.19 2011/07/12 17:19:50 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -237,7 +237,7 @@ (values (info typed-structure textdomain x))) (t nil)))) - (or (intl:dgettext domain doc) + (or (and doc (intl:dgettext domain doc)) doc)))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

cmucl-cvs