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

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2011-12-10-g771b7ee
by Raymond Toy 23 Dec '11

23 Dec '11

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 771b7ee43d15c24563557b102ec15f466ece13cb (commit) from f1874509af0afa2aedd12e9cc61654e0bc0a4519 (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 771b7ee43d15c24563557b102ec15f466ece13cb Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Fri Dec 23 08:18:28 2011 -0800 Fix more compiler warnings. Linux-os.c: o Fix warning about pointer to int warning. lisp.c: o Linux needs time.h to define tzset. o Fix warning about unused result from getwcd. If getcwd fails, we now just exit with a message because we can't find anything. diff --git a/src/lisp/Linux-os.c b/src/lisp/Linux-os.c index f4b96ef..20731e2 100644 --- a/src/lisp/Linux-os.c +++ b/src/lisp/Linux-os.c @@ -65,7 +65,7 @@ int personality (unsigned long); #endif void -check_personality(struct utsname *name, const char *argv[], const char *envp[]) +check_personality(struct utsname *name, char *const *argv, char *const *envp) { /* KLUDGE: Disable memory randomization on new Linux kernels * by setting a personality flag and re-executing. (We need @@ -428,7 +428,7 @@ sigsegv_handler(HANDLER_ARGS) tramp_signal = signal; tramp_code = *code; tramp_context = *context; - SC_PC(context) = sigsegv_handler_tramp; + SC_PC(context) = (unsigned long) sigsegv_handler_tramp; return; } #endif diff --git a/src/lisp/lisp.c b/src/lisp/lisp.c index d719c8d..2eb000f 100644 --- a/src/lisp/lisp.c +++ b/src/lisp/lisp.c @@ -40,6 +40,10 @@ #include <sys/utsname.h> #endif +#if defined(__linux__) +#include <time.h> +#endif + /* SIGINT handler that invokes the monitor. */ @@ -94,6 +98,16 @@ static char *cmucllib_search_list[] = { NULL }; +void +getcwd_or_die(char* buf, size_t size) +{ + char *result = getcwd(buf, size); + + if (result == NULL) { + perror("Cannot get cwd"); + exit(1); + } +} /* Set this to see how we're doing our search */ int debug_lisp_search = FALSE; @@ -154,7 +168,7 @@ default_cmucllib(const char *argv0arg) * append argv[0], after stripping off the executable name. */ cwd = malloc(FILENAME_MAX + strlen(argv0_dir) + 100); - getcwd(cwd, FILENAME_MAX); + getcwd_or_die(cwd, FILENAME_MAX); strcat(cwd, "/"); if (*argv0_dir != '\0') { strcat(cwd, argv0_dir); @@ -353,7 +367,7 @@ prepend_core_path(const char *lib, const char *corefile) * We have a relative path for the corefile. Prepend our current * directory to get the full path. */ - getcwd(cwd, FILENAME_MAX); + getcwd_or_die(cwd, FILENAME_MAX); path = malloc(FILENAME_MAX + strlen(corefile) + 2); strcpy(path, cwd); strcat(path, "/"); ----------------------------------------------------------------------- Summary of changes: src/lisp/Linux-os.c | 4 ++-- src/lisp/lisp.c | 18 ++++++++++++++++-- 2 files changed, 18 insertions(+), 4 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2011-12-9-gf187450
by Raymond Toy 22 Dec '11

22 Dec '11

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 f1874509af0afa2aedd12e9cc61654e0bc0a4519 (commit) via 0b7015bbe5cd76450e861da44b8692174c546a1a (commit) via 9f4256ad2b60bb21806f1edb0cd34099b984b523 (commit) from 43c8a8204942f7286daad33ed5bcf4dcbe9f4c7d (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 f1874509af0afa2aedd12e9cc61654e0bc0a4519 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Dec 22 13:43:42 2011 -0800 Prevent ldb from endless printing the prompt if EOF is reached. diff --git a/src/lisp/monitor.c b/src/lisp/monitor.c index b47a6b1..64e44f5 100644 --- a/src/lisp/monitor.c +++ b/src/lisp/monitor.c @@ -469,7 +469,14 @@ sub_monitor(void) if (line == NULL) { if (isatty(0)) { putchar('\n'); - continue; + /* + * We can no longer read anything from stdin, so + * just exit this loop instead of spewing an + * endless stream of prompts. This also means we + * can't use ldb anymore because stdin is + * unreadable. + */ + break; } else { fprintf(stderr, "\nEOF on something other than a tty.\n"); exit(1); commit 0b7015bbe5cd76450e861da44b8692174c546a1a Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Dec 22 10:45:24 2011 -0800 It's ok to include elf.h on Darwin. Need definition of map_core_sections to get rid of compiler warning. diff --git a/src/lisp/lisp.c b/src/lisp/lisp.c index 0bd6aff..d719c8d 100644 --- a/src/lisp/lisp.c +++ b/src/lisp/lisp.c @@ -33,10 +33,8 @@ #include "save.h" #include "lispregs.h" #if defined(FEATURE_EXECUTABLE) -#if !defined(DARWIN) #include "elf.h" #endif -#endif #ifdef __linux__ #include <sys/utsname.h> commit 9f4256ad2b60bb21806f1edb0cd34099b984b523 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Dec 22 10:23:41 2011 -0800 Fix compiler warning about not using result of fgets. diff --git a/src/lisp/monitor.c b/src/lisp/monitor.c index 806e503..b47a6b1 100644 --- a/src/lisp/monitor.c +++ b/src/lisp/monitor.c @@ -312,12 +312,14 @@ static void quit(char **ptr) { char buf[10]; + char *result; printf("Really quit? [y] "); fflush(stdout); - fgets(buf, sizeof(buf), stdin); - if (buf[0] == 'y' || buf[0] == 'Y' || buf[0] == '\n') + result = fgets(buf, sizeof(buf), stdin); + if (result && (buf[0] == 'y' || buf[0] == 'Y' || buf[0] == '\n')) { exit(0); + } } static void diff --git a/src/lisp/print.c b/src/lisp/print.c index cdf4b56..9f8fa10 100644 --- a/src/lisp/print.c +++ b/src/lisp/print.c @@ -154,12 +154,13 @@ continue_p(boolean newline) putchar('\n'); if (cur_lines >= max_lines) { + char *result; printf("More? [y] "); fflush(stdout); - fgets(buffer, sizeof(buffer), stdin); + result = fgets(buffer, sizeof(buffer), stdin); - if (buffer[0] == 'n' || buffer[0] == 'N') + if (result == NULL || buffer[0] == 'n' || buffer[0] == 'N') throw_to_monitor(); else cur_lines = 0; ----------------------------------------------------------------------- Summary of changes: src/lisp/lisp.c | 2 -- src/lisp/monitor.c | 15 ++++++++++++--- src/lisp/print.c | 5 +++-- 3 files changed, 15 insertions(+), 7 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2011-12-6-g43c8a82
by Raymond Toy 22 Dec '11

22 Dec '11

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 43c8a8204942f7286daad33ed5bcf4dcbe9f4c7d (commit) from 57ca5217c749f67c8acd7e2049a5e79f4bd6baf1 (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 43c8a8204942f7286daad33ed5bcf4dcbe9f4c7d Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Dec 21 22:51:42 2011 -0800 Make stack 16-byte aligned. lisp/x86-assem.S: o Make sure the stack is 16-byte aligned in the alloc_overflow_foo and alloc_to_foo routines. These eventually call into C code, and the stack is required to be 16-byte aligned on Darwin. We apply this to all x86 implementations since it's harmless. o Did not update the alloc_8/16_to_foo routines because they are going to be deleted. x86/macros.lisp: o Don't call the alloc_8/16_to_foo routines when we're not doing inline allocation. I don't think there's much to be gained with these special functions and maintainence is a pain with assembly code. diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp index ea9c897..731bcf4 100644 --- a/src/compiler/x86/macros.lisp +++ b/src/compiler/x86/macros.lisp @@ -181,65 +181,29 @@ ;; special entry point. The size may be a register or a constant. (ecase (tn-offset alloc-tn) (#.eax-offset - (case size - (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_eax") - :foreign))) - (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_eax") - :foreign))) - (t - (load-size alloc-tn eax-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_eax") - :foreign))))) + (load-size alloc-tn eax-tn size) + (inst call (make-fixup (extern-alien-name "alloc_to_eax") + :foreign))) (#.ecx-offset - (case size - (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ecx") - :foreign))) - (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ecx") - :foreign))) - (t - (load-size alloc-tn ecx-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_ecx") - :foreign))))) + (load-size alloc-tn ecx-tn size) + (inst call (make-fixup (extern-alien-name "alloc_to_ecx") + :foreign))) (#.edx-offset - (case size - (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edx") - :foreign))) - (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edx") - :foreign))) - (t - (load-size alloc-tn edx-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_edx") - :foreign))))) + (load-size alloc-tn edx-tn size) + (inst call (make-fixup (extern-alien-name "alloc_to_edx") + :foreign))) (#.ebx-offset - (case size - (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_ebx") - :foreign))) - (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_ebx") - :foreign))) - (t - (load-size alloc-tn ebx-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_ebx") - :foreign))))) + (load-size alloc-tn ebx-tn size) + (inst call (make-fixup (extern-alien-name "alloc_to_ebx") + :foreign))) (#.esi-offset - (case size - (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_esi") - :foreign))) - (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_esi") - :foreign))) - (t - (load-size alloc-tn esi-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_esi") - :foreign))))) + (load-size alloc-tn esi-tn size) + (inst call (make-fixup (extern-alien-name "alloc_to_esi") + :foreign))) (#.edi-offset - (case size - (8 (inst call (make-fixup (extern-alien-name "alloc_8_to_edi") - :foreign))) - (16 (inst call (make-fixup (extern-alien-name "alloc_16_to_edi") - :foreign))) - (t - (load-size alloc-tn edi-tn size) - (inst call (make-fixup (extern-alien-name "alloc_to_edi") - :foreign)))))) + (load-size alloc-tn edi-tn size) + (inst call (make-fixup (extern-alien-name "alloc_to_edi") + :foreign)))) (values)) ;;; diff --git a/src/lisp/x86-assem.S b/src/lisp/x86-assem.S index 178e913..5557060 100644 --- a/src/lisp/x86-assem.S +++ b/src/lisp/x86-assem.S @@ -63,6 +63,22 @@ GNAME(x): ; #define align_16byte 4 #endif +/* + * Allocate |bytes| on the stack, and make sure the stack pointer is + * aligned on a 16-byte boundary. (Needed on Darwin, and harmless on + * others that don't need such alignment.) + */ +#define STACK_PROLOGUE(bytes) \ + pushl %ebp ; \ + mov %esp, %ebp ; \ + subl $##bytes, %esp ; \ + andl $-16, %esp ; + +/* Undo STACK_PROLOGUE */ +#define STACK_EPILOGUE \ + movl %ebp, %esp ; \ + popl %ebp ; + .text .globl GNAME(foreign_function_call_active) @@ -453,13 +469,14 @@ ENDFUNC(fastcopy16) So only eax, ecx, and edx need special care here. */ FUNCDEF(alloc_to_eax) - pushl %ecx # Save ecx and edx as C could destroy them. - pushl %edx - pushl %eax # Push the size + STACK_PROLOGUE(12) + movl %ecx, 8(%esp) # Save ecx and edx as C could destroy them. + movl %edx, 4(%esp) + movl %eax, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. - popl %edx # Restore ecx and edx. - popl %ecx + movl 4(%esp), %edx # Restore ecx and edx. + movl 8(%esp), %ecx + STACK_EPILOGUE ret ENDFUNC(alloc_to_eax) @@ -473,7 +490,7 @@ FUNCDEF(alloc_8_to_eax) popl %ecx ret ENDFUNC(alloc_8_to_eax) - + FUNCDEF(alloc_16_to_eax) pushl %ecx # Save ecx and edx as C could destroy them. pushl %edx @@ -486,14 +503,15 @@ FUNCDEF(alloc_16_to_eax) ENDFUNC(alloc_16_to_eax) FUNCDEF(alloc_to_ecx) - pushl %eax # Save eax and edx as C could destroy them. - pushl %edx - pushl %ecx # Push the size + STACK_PROLOGUE(12) + movl %eax, 8(%esp) # Save eax and edx as C could destroy them. + movl %edx, 4(%esp) + movl %ecx, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. movl %eax,%ecx # setup the destination. - popl %edx # Restore eax and edx. - popl %eax + movl 4(%esp), %edx # Restore eax and edx. + movl 8(%esp), %eax + STACK_EPILOGUE ret ENDFUNC(alloc_to_ecx) @@ -522,14 +540,15 @@ FUNCDEF(alloc_16_to_ecx) ENDFUNC(alloc_16_to_ecx) FUNCDEF(alloc_to_edx) - pushl %eax # Save eax and ecx as C could destroy them. - pushl %ecx - pushl %edx # Push the size + STACK_PROLOGUE(12) + movl %eax, 8(%esp) # Save eax and ecx as C could destroy them. + movl %ecx, 4(%esp) + movl %edx, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. movl %eax,%edx # setup the destination. - popl %ecx # Restore eax and ecx. - popl %eax + movl 4(%esp), %ecx # Restore eax and ecx. + movl 8(%esp), %eax + STACK_EPILOGUE ret ENDFUNC(alloc_to_edx) @@ -558,16 +577,17 @@ FUNCDEF(alloc_16_to_edx) ENDFUNC(alloc_16_to_edx) FUNCDEF(alloc_to_ebx) - pushl %eax # Save eax, ecx, and edx as C could destroy them. - pushl %ecx - pushl %edx - pushl %ebx # Push the size + STACK_PROLOGUE(16) + movl %eax, 12(%esp) # Save eax, ecx, and edx as C could destroy them. + movl %ecx, 8(%esp) + movl %edx, 4(%esp) + movl %ebx, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. movl %eax,%ebx # setup the destination. - popl %edx # Restore eax, ecx and edx. - popl %ecx - popl %eax + movl 4(%esp), %edx # Restore eax, ecx and edx. + movl 8(%esp), %ecx + movl 12(%esp), %eax + STACK_EPILOGUE ret ENDFUNC(alloc_to_ebx) @@ -600,16 +620,17 @@ FUNCDEF(alloc_16_to_ebx) ENDFUNC(alloc_16_to_ebx) FUNCDEF(alloc_to_esi) - pushl %eax # Save eax, ecx, and edx as C could destroy them. - pushl %ecx - pushl %edx - pushl %esi # Push the size + STACK_PROLOGUE(16) + movl %eax, 12(%esp) # Save eax, ecx, and edx as C could destroy them. + movl %ecx, 8(%esp) + movl %edx, 4(%esp) + movl %esi, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. movl %eax,%esi # setup the destination. - popl %edx # Restore eax, ecx and edx. - popl %ecx - popl %eax + movl 4(%esp), %edx # Restore eax, ecx and edx. + movl 8(%esp), %ecx + movl 12(%esp), %eax + STACK_EPILOGUE ret ENDFUNC(alloc_to_esi) @@ -642,16 +663,17 @@ FUNCDEF(alloc_16_to_esi) ENDFUNC(alloc_16_to_esi) FUNCDEF(alloc_to_edi) - pushl %eax # Save eax, ecx, and edx as C could destroy them. - pushl %ecx - pushl %edx - pushl %edi # Push the size + STACK_PROLOGUE(16) + movl %eax, 12(%esp) # Save eax, ecx, and edx as C could destroy them. + movl %ecx, 8(%esp) + movl %edx, 4(%esp) + movl %edi, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. movl %eax,%edi # setup the destination. - popl %edx # Restore eax, ecx and edx. - popl %ecx - popl %eax + movl 4(%esp), %edx # Restore eax, ecx and edx. + movl 8(%esp), %ecx + movl 12(%esp), %eax + STACK_EPILOGUE ret ENDFUNC(alloc_to_edi) @@ -683,7 +705,6 @@ FUNCDEF(alloc_16_to_edi) ret ENDFUNC(alloc_16_to_edi) - #ifdef GENCGC /* Called from lisp when an inline allocation overflows. @@ -694,15 +715,16 @@ ENDFUNC(alloc_16_to_edi) /* This routine handles an overflow with eax=crfp+size. So the size=eax-crfp. */ FUNCDEF(alloc_overflow_eax) - pushl %ecx # Save ecx - pushl %edx # Save edx + STACK_PROLOGUE(12) + movl %ecx, 8(%esp) # Save ecx + movl %edx, 4(%esp) # Save edx /* Calculate the size for the allocation. */ subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%eax - pushl %eax # Push the size + movl %eax, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. - popl %edx # Restore edx. - popl %ecx # Restore ecx. + movl 4(%esp), %edx # Restore edx. + movl 8(%esp), %ecx # Restore ecx. + STACK_EPILOGUE addl $6,(%esp) # Adjust the return address to skip the next inst. ret ENDFUNC(alloc_overflow_eax) @@ -710,16 +732,17 @@ ENDFUNC(alloc_overflow_eax) /* This routine handles an overflow with ecx=crfp+size. So the size=ecx-crfp. */ FUNCDEF(alloc_overflow_ecx) - pushl %eax # Save eax - pushl %edx # Save edx + STACK_PROLOGUE(12) + movl %eax, 8(%esp) # Save eax + movl %edx, 4(%esp) # Save edx /* Calculate the size for the allocation. */ subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%ecx - pushl %ecx # Push the size + movl %ecx, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. movl %eax,%ecx # setup the destination. - popl %edx # Restore edx. - popl %eax # Restore eax. + movl 4(%esp), %edx # Restore edx. + movl 8(%esp), %eax # Restore eax. + STACK_EPILOGUE addl $6,(%esp) # Adjust the return address to skip the next inst. ret ENDFUNC(alloc_overflow_ecx) @@ -727,16 +750,17 @@ ENDFUNC(alloc_overflow_ecx) /* This routine handles an overflow with edx=crfp+size. So the size=edx-crfp. */ FUNCDEF(alloc_overflow_edx) - pushl %eax # Save eax - pushl %ecx # Save ecx + STACK_PROLOGUE(12) + movl %eax, 8(%esp) # Save eax + movl %ecx, 4(%esp) # Save ecx /* Calculate the size for the allocation. */ subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%edx - pushl %edx # Push the size + movl %edx, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. movl %eax,%edx # setup the destination. - popl %ecx # Restore ecx. - popl %eax # Restore eax. + movl 4(%esp), %ecx # Restore ecx. + movl 8(%esp), %eax # Restore eax. + STACK_EPILOGUE addl $6,(%esp) # Adjust the return address to skip the next inst. ret ENDFUNC(alloc_overflow_edx) @@ -744,18 +768,19 @@ ENDFUNC(alloc_overflow_edx) /* This routine handles an overflow with ebx=crfp+size. So the size=ebx-crfp. */ FUNCDEF(alloc_overflow_ebx) - pushl %eax # Save eax - pushl %ecx # Save ecx - pushl %edx # Save edx + STACK_PROLOGUE(16) + movl %eax, 12(%esp) # Save eax + movl %ecx, 8(%esp) # Save ecx + movl %edx, 4(%esp) # Save edx /* Calculate the size for the allocation. */ subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%ebx - pushl %ebx # Push the size + movl %ebx, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. movl %eax,%ebx # setup the destination. - popl %edx # Restore edx. - popl %ecx # Restore ecx. - popl %eax # Restore eax. + movl 4(%esp), %edx # Restore edx. + movl 8(%esp), %ecx # Restore ecx. + movl 12(%esp), %eax # Restore eax. + STACK_EPILOGUE addl $6,(%esp) # Adjust the return address to skip the next inst. ret ENDFUNC(alloc_overflow_ebx) @@ -763,18 +788,19 @@ ENDFUNC(alloc_overflow_ebx) /* This routine handles an overflow with esi=crfp+size. So the size=esi-crfp. */ FUNCDEF(alloc_overflow_esi) - pushl %eax # Save eax - pushl %ecx # Save ecx - pushl %edx # Save edx + STACK_PROLOGUE(16) + movl %eax, 12(%esp) # Save eax + movl %ecx, 8(%esp) # Save ecx + movl %edx, 4(%esp) # Save edx /* Calculate the size for the allocation. */ subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%esi - pushl %esi # Push the size + movl %esi, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. movl %eax,%esi # setup the destination. - popl %edx # Restore edx. - popl %ecx # Restore ecx. - popl %eax # Restore eax. + movl 4(%esp), %edx # Restore edx. + movl 8(%esp), %ecx # Restore ecx. + movl 12(%esp), %eax # Restore eax. + STACK_EPILOGUE addl $6,(%esp) # Adjust the return address to skip the next inst. ret ENDFUNC(alloc_overflow_esi) @@ -782,18 +808,19 @@ ENDFUNC(alloc_overflow_esi) /* This routine handles an overflow with edi=crfp+size. So the size=edi-crfp. */ FUNCDEF(alloc_overflow_edi) - pushl %eax # Save eax - pushl %ecx # Save ecx - pushl %edx # Save edx + STACK_PROLOGUE(16) + movl %eax, 12(%esp) # Save eax + movl %ecx, 8(%esp) # Save ecx + movl %edx, 4(%esp) # Save edx /* Calculate the size for the allocation. */ subl CURRENT_REGION_FREE_POINTER + SYMBOL_VALUE_OFFSET,%edi - pushl %edi # Push the size + movl %edi, (%esp) # Push the size call GNAME(alloc) - addl $4,%esp # pop the size arg. movl %eax,%edi # setup the destination. - popl %edx # Restore edx. - popl %ecx # Restore ecx. - popl %eax # Restore eax. + movl 4(%esp), %edx # Restore edx. + movl 8(%esp), %ecx # Restore ecx. + movl 12(%esp), %eax # Restore eax. + STACK_EPILOGUE addl $6,(%esp) # Adjust the return address to skip the next inst. ret ENDFUNC(alloc_overflow_edi) ----------------------------------------------------------------------- Summary of changes: src/compiler/x86/macros.lisp | 72 ++++----------- src/lisp/x86-assem.S | 199 ++++++++++++++++++++++++------------------ 2 files changed, 131 insertions(+), 140 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2011-12-5-g57ca521
by Raymond Toy 22 Dec '11

22 Dec '11

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 57ca5217c749f67c8acd7e2049a5e79f4bd6baf1 (commit) from 2326ebcf3d776a14a7e3ad61edfaf5bca40ebbbc (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 57ca5217c749f67c8acd7e2049a5e79f4bd6baf1 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Dec 21 21:51:45 2011 -0800 Fix a few compiler warnings. diff --git a/src/lisp/Darwin-os.c b/src/lisp/Darwin-os.c index 1304d10..9cd0aa6 100644 --- a/src/lisp/Darwin-os.c +++ b/src/lisp/Darwin-os.c @@ -499,7 +499,7 @@ sigbus_handler(HANDLER_ARGS) /* a *real* protection fault */ fprintf(stderr, "sigbus_handler: Real protection violation at %p, PC = %p\n", - fault_addr, SC_PC(context)); + fault_addr, (void *) SC_PC(context)); sigbus_handle_now(signal, code, context); #ifdef __ppc__ /* Work around G5 bug; fix courtesy gbyers via chandler */ diff --git a/src/lisp/coreparse.c b/src/lisp/coreparse.c index cf1ee43..bdba500 100644 --- a/src/lisp/coreparse.c +++ b/src/lisp/coreparse.c @@ -63,7 +63,7 @@ process_directory(int fd, long *ptr, int count) case STATIC_SPACE_ID: static_space = (lispobj *) addr; if (len >= static_space_size) { - fprintf(stderr, "Error: Static space size (%d) exceeds allocated space (%d)!\n", + fprintf(stderr, "Error: Static space size (%ld) exceeds allocated space (%ld)!\n", len, static_space_size); exit(1); } @@ -71,7 +71,7 @@ process_directory(int fd, long *ptr, int count) case READ_ONLY_SPACE_ID: /* Don't care about read only space */ if (len >= read_only_space_size) { - fprintf(stderr, "Error: Read only space size (%d) exceeds allocated space (%d)!\n", + fprintf(stderr, "Error: Read only space size (%ld) exceeds allocated space (%lu)!\n", len, read_only_space_size); exit(1); } ----------------------------------------------------------------------- Summary of changes: src/lisp/Darwin-os.c | 2 +- src/lisp/coreparse.c | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2011-12-4-g2326ebc
by Raymond Toy 21 Dec '11

21 Dec '11

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 2326ebcf3d776a14a7e3ad61edfaf5bca40ebbbc (commit) from d56fecd7db290133ca12fa1a12843327af191ed7 (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 2326ebcf3d776a14a7e3ad61edfaf5bca40ebbbc Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Tue Dec 20 22:13:36 2011 -0800 Print out more digits for double-floats in ldb printer. diff --git a/src/lisp/print.c b/src/lisp/print.c index f1e84d4..cdf4b56 100644 --- a/src/lisp/print.c +++ b/src/lisp/print.c @@ -552,7 +552,7 @@ print_otherptr(lispobj obj) case type_DoubleFloat: NEWLINE; - printf("%g", ((struct double_float *) PTR(obj))->value); + printf("%.15lg", ((struct double_float *) PTR(obj))->value); break; #ifdef type_LongFloat @@ -565,7 +565,7 @@ print_otherptr(lispobj obj) #ifdef type_DoubleDoubleFloat case type_DoubleDoubleFloat: NEWLINE; - printf("%g %g", ((struct double_double_float *) PTR(obj))->hi, + printf("%.15lg %.15lg", ((struct double_double_float *) PTR(obj))->hi, ((struct double_double_float *) PTR(obj))->lo); break; #endif @@ -582,9 +582,9 @@ print_otherptr(lispobj obj) #ifdef type_ComplexDoubleFloat case type_ComplexDoubleFloat: NEWLINE; - printf("%g", ((struct complex_double_float *) PTR(obj))->real); + printf("%.15lg", ((struct complex_double_float *) PTR(obj))->real); NEWLINE; - printf("%g", ((struct complex_double_float *) PTR(obj))->imag); + printf("%.15lg", ((struct complex_double_float *) PTR(obj))->imag); break; #endif @@ -600,10 +600,10 @@ print_otherptr(lispobj obj) #ifdef type_ComplexDoubleDoubleFloat case type_ComplexDoubleDoubleFloat: NEWLINE; - printf("%g %g", ((struct complex_double_double_float *) PTR(obj))->real_hi, + printf("%.15lg %.15lg", ((struct complex_double_double_float *) PTR(obj))->real_hi, ((struct complex_double_double_float *) PTR(obj))->real_lo); NEWLINE; - printf("%g %g", ((struct complex_double_double_float *) PTR(obj))->imag_hi, + printf("%.15lg %.15lg", ((struct complex_double_double_float *) PTR(obj))->imag_hi, ((struct complex_double_double_float *) PTR(obj))->imag_lo); break; #endif ----------------------------------------------------------------------- Summary of changes: src/lisp/print.c | 12 ++++++------ 1 files changed, 6 insertions(+), 6 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2011-12-3-gd56fecd
by Raymond Toy 16 Dec '11

16 Dec '11

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 d56fecd7db290133ca12fa1a12843327af191ed7 (commit) from 71e768a8693790dd13b0b8908a010d100c5dc370 (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 d56fecd7db290133ca12fa1a12843327af191ed7 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Wed Dec 14 10:49:11 2011 -0800 Use gcc-4.2 explicitly in case Xcode4 is installed. diff --git a/src/lisp/Config.x86_darwin b/src/lisp/Config.x86_darwin index 404521f..e1daf4f 100644 --- a/src/lisp/Config.x86_darwin +++ b/src/lisp/Config.x86_darwin @@ -2,6 +2,12 @@ include Config.x86_common +# Use gcc-4.2 on Darwin in case someone has Xcode 4 installed. +# Currently there are bugs in cmucl that cause errors when using gcc +# from Xcode 4. Xcode 3 (for OSX 10.5 and 10.6) has gcc-4.2, so this +# shouldn't be a problem. +CC = gcc-4.2 + # Compile code that will run on OSX 10.4 (Tiger) MIN_VER = -mmacosx-version-min=10.4 ----------------------------------------------------------------------- Summary of changes: src/lisp/Config.x86_darwin | 6 ++++++ 1 files changed, 6 insertions(+), 0 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2011-12-2-g71e768a
by Raymond Toy 08 Dec '11

08 Dec '11

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 71e768a8693790dd13b0b8908a010d100c5dc370 (commit) from a4e33b7683a15bccdf944729b5c1fcb5a81970cf (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 71e768a8693790dd13b0b8908a010d100c5dc370 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Dec 8 10:27:30 2011 -0800 Include the bin directory so we include the build scripts in the src distribution. diff --git a/bin/make-src-dist.sh b/bin/make-src-dist.sh index a65aad8..1e1c016 100755 --- a/bin/make-src-dist.sh +++ b/bin/make-src-dist.sh @@ -51,8 +51,8 @@ fi GTAR_OPTIONS="--exclude=.git --exclude='*.pot.~*~'" if [ -z "$INSTALL_DIR" ]; then echo " Compressing with $ZIP" - ${GTAR:-tar} ${GTAR_OPTIONS} -cf - src | ${ZIP} > cmucl-src-$VERSION.tar.$ZIPEXT + ${GTAR:-tar} ${GTAR_OPTIONS} -cf - bin src | ${ZIP} > cmucl-src-$VERSION.tar.$ZIPEXT else # Install in the specified directory - ${GTAR:-tar} ${GTAR_OPTIONS} -cf - src | (cd $INSTALL_DIR; ${GTAR:-tar} xf -) + ${GTAR:-tar} ${GTAR_OPTIONS} -cf - bin src | (cd $INSTALL_DIR; ${GTAR:-tar} xf -) fi ----------------------------------------------------------------------- Summary of changes: bin/make-src-dist.sh | 4 ++-- 1 files changed, 2 insertions(+), 2 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. snapshot-2011-12-1-ga4e33b7
by Raymond Toy 08 Dec '11

08 Dec '11

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 a4e33b7683a15bccdf944729b5c1fcb5a81970cf (commit) from 576ae2a5a8f79bf983ac3da8237854b2b21dd8c6 (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 a4e33b7683a15bccdf944729b5c1fcb5a81970cf Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Thu Dec 8 10:22:32 2011 -0800 Fix ticket:50 Check if "" (and "/") is in the list of directories and signal an error so that we use the #P(...) syntax to print out the pathname readably. Update the pot and po files accordingly. diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp index ab2f564..308b8b5 100644 --- a/src/code/filesys.lisp +++ b/src/code/filesys.lisp @@ -488,7 +488,14 @@ (error (intl:gettext ":BACK cannot be represented in namestrings."))) ((member :wild-inferiors) (pieces "**/")) - ((or simple-string pattern (eql :wild)) + (simple-string + (when (zerop (length dir)) + (error (intl:gettext "Cannot represent \"\" in namestrings."))) + (when (string-equal dir "/") + (error (intl:gettext "Cannot represent an explicit directory separator in namestrings."))) + (pieces (unparse-unix-piece dir)) + (pieces "/")) + ((or pattern (eql :wild)) (pieces (unparse-unix-piece dir)) (pieces "/")) (t diff --git a/src/i18n/locale/cmucl.pot b/src/i18n/locale/cmucl.pot index 92ace3d..a1087ca 100644 --- a/src/i18n/locale/cmucl.pot +++ b/src/i18n/locale/cmucl.pot @@ -9026,7 +9026,15 @@ msgid "" "Convert String to octets using the specified External-format. The\n" " string is bounded by Start (defaulting to 0) and End (defaulting to\n" " the end of the string. If Buffer is given, the octets are stored\n" -" there. If not, a new buffer is created." +" there. If not, a new buffer is created. Buffer-start specifies\n" +" where in the buffer the first octet will be placed.\n" +"\n" +" Three values are returned: The buffer, the number of valid octets\n" +" written, and the number of characters converted. Note that the\n" +" actual number of octets written may be greater than the returned\n" +" value, These represent the partial octets of the next character to\n" +" be converted, but there was not enough room to hold the complete set\n" +" of octets." msgstr "" #: src/code/extfmts.lisp @@ -9807,6 +9815,14 @@ msgid ":BACK cannot be represented in namestrings." msgstr "" #: src/code/filesys.lisp +msgid "Cannot represent \"\" in namestrings." +msgstr "" + +#: src/code/filesys.lisp +msgid "Cannot represent an explicit directory separator in namestrings." +msgstr "" + +#: src/code/filesys.lisp msgid "Cannot specify a directory separator in a pathname name: ~S" msgstr "" diff --git a/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po b/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po index 78da94f..37c3afe 100644 --- a/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po @@ -12874,15 +12874,16 @@ msgid "" "Convert String to octets using the specified External-format. The\n" " string is bounded by Start (defaulting to 0) and End (defaulting to\n" " the end of the string. If Buffer is given, the octets are stored\n" -" there. If not, a new buffer is created." +" there. If not, a new buffer is created. Buffer-start specifies\n" +" where in the buffer the first octet will be placed.\n" +"\n" +" Three values are returned: The buffer, the number of valid octets\n" +" written, and the number of characters converted. Note that the\n" +" actual number of octets written may be greater than the returned\n" +" value, These represent the partial octets of the next character to\n" +" be converted, but there was not enough room to hold the complete set\n" +" of octets." msgstr "" -"Onvertcay Ingstray otay octetsway usingway ethay ecifiedspay Externalway-" -"ormatfay. Ethay\n" -" ingstray isway oundedbay ybay Tartsay (efaultingday otay 0) andway Endway " -"(efaultingday otay\n" -" ethay endway ofway ethay ingstray. Ifway Ufferbay isway ivengay, ethay " -"octetsway areway toredsay\n" -" erethay. Ifway otnay, away ewnay ufferbay isway eatedcray." #: src/code/extfmts.lisp msgid "" @@ -13990,6 +13991,18 @@ msgid ":BACK cannot be represented in namestrings." msgstr ":BACK annotcay ebay epresentedray inway amestringsnay." #: src/code/filesys.lisp +#, fuzzy +msgid "Cannot represent \"\" in namestrings." +msgstr ":BACK annotcay ebay epresentedray inway amestringsnay." + +#: src/code/filesys.lisp +#, fuzzy +msgid "Cannot represent an explicit directory separator in namestrings." +msgstr "" +"Annotcay ecifyspay away irectoryday eparatorsay inway away athnamepay " +"amenay: ~S" + +#: src/code/filesys.lisp msgid "Cannot specify a directory separator in a pathname name: ~S" msgstr "" "Annotcay ecifyspay away irectoryday eparatorsay inway away athnamepay " @@ -30436,6 +30449,20 @@ msgstr "" "eplacementray aracterchay." #~ msgid "" +#~ "Convert String to octets using the specified External-format. The\n" +#~ " string is bounded by Start (defaulting to 0) and End (defaulting to\n" +#~ " the end of the string. If Buffer is given, the octets are stored\n" +#~ " there. If not, a new buffer is created." +#~ msgstr "" +#~ "Onvertcay Ingstray otay octetsway usingway ethay ecifiedspay Externalway-" +#~ "ormatfay. Ethay\n" +#~ " ingstray isway oundedbay ybay Tartsay (efaultingday otay 0) andway " +#~ "Endway (efaultingday otay\n" +#~ " ethay endway ofway ethay ingstray. Ifway Ufferbay isway ivengay, ethay " +#~ "octetsway areway toredsay\n" +#~ " erethay. Ifway otnay, away ewnay ufferbay isway eatedcray." + +#~ msgid "" #~ "Return a pathname describing what file COMPILE-FILE would write to given\n" #~ " these arguments." #~ msgstr "" diff --git a/src/i18n/locale/ko/LC_MESSAGES/cmucl.po b/src/i18n/locale/ko/LC_MESSAGES/cmucl.po index a806bec..12d0955 100644 --- a/src/i18n/locale/ko/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/ko/LC_MESSAGES/cmucl.po @@ -9046,7 +9046,15 @@ msgid "" "Convert String to octets using the specified External-format. The\n" " string is bounded by Start (defaulting to 0) and End (defaulting to\n" " the end of the string. If Buffer is given, the octets are stored\n" -" there. If not, a new buffer is created." +" there. If not, a new buffer is created. Buffer-start specifies\n" +" where in the buffer the first octet will be placed.\n" +"\n" +" Three values are returned: The buffer, the number of valid octets\n" +" written, and the number of characters converted. Note that the\n" +" actual number of octets written may be greater than the returned\n" +" value, These represent the partial octets of the next character to\n" +" be converted, but there was not enough room to hold the complete set\n" +" of octets." msgstr "" #: src/code/extfmts.lisp @@ -9830,6 +9838,14 @@ msgid ":BACK cannot be represented in namestrings." msgstr "" #: src/code/filesys.lisp +msgid "Cannot represent \"\" in namestrings." +msgstr "" + +#: src/code/filesys.lisp +msgid "Cannot represent an explicit directory separator in namestrings." +msgstr "" + +#: src/code/filesys.lisp msgid "Cannot specify a directory separator in a pathname name: ~S" msgstr "" ----------------------------------------------------------------------- Summary of changes: src/code/filesys.lisp | 9 ++++- src/i18n/locale/cmucl.pot | 18 +++++++++- src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po | 43 ++++++++++++++++++---- src/i18n/locale/ko/LC_MESSAGES/cmucl.po | 18 +++++++++- 4 files changed, 77 insertions(+), 11 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp annotated tag snapshot-2011-12 created. snapshot-2011-12
by Raymond Toy 02 Dec '11

02 Dec '11

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-2011-12 has been created at 54235a700500e9a439d266cd984bcfd489dbc885 (tag) tagging 576ae2a5a8f79bf983ac3da8237854b2b21dd8c6 (commit) replaces release-20c tagged by Raymond Toy on Thu Dec 1 20:52:56 2011 -0800 - Log ----------------------------------------------------------------- Snapshot 2011-12 Raymond Toy (24): Ignore files generated by tex. Update asdf to version 2.018. Merge branch 'RELEASE-20C-BRANCH' Merge commit 'release-20c' Change bootfile directory from 20b to 20c. Initial version for 20d release notes. STRING-TO-OCTETS returns the buffer, the number of octets written and Update from change log. Rearrange directory structure. Moved more sripts to bin from src/tools. Update paths for the new location of the scripts. Update paths. Ignore darwin build directories. If -b is not given, try to choose a suitable name from the OS type. Ignore linux and sparc build directories. Exit after print the usage message. Move rebuild-lisp.sh to bin. Move cross-build-world.sh to bin. Move make-dist.sh, make-extra-dist.sh, make-main-dist.sh and Update paths to new locations. Don't add .git directory to src tarball! If compression or version is Forgot to compiler that DECODE-FLOAT can return +/- 1w0 for the sign. Remove hppa-assem.s. It's not referenced anywhere. Update to asdf 2.019; update release info. ----------------------------------------------------------------------- hooks/post-receive -- CMU Common Lisp

1 0

[cmucl-cvs] [git] CMU Common Lisp branch master updated. release-20c-24-g576ae2a
by Raymond Toy 01 Dec '11

01 Dec '11

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 576ae2a5a8f79bf983ac3da8237854b2b21dd8c6 (commit) from eea87468f7479a152a34ff2ad8f6fd53a011c36b (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 576ae2a5a8f79bf983ac3da8237854b2b21dd8c6 Author: Raymond Toy <toy.raymond(a)gmail.com> Date: Mon Nov 28 20:39:27 2011 -0800 Update to asdf 2.019; update release info. diff --git a/src/contrib/asdf/asdf.lisp b/src/contrib/asdf/asdf.lisp index 26ff427..a95826b 100644 --- a/src/contrib/asdf/asdf.lisp +++ b/src/contrib/asdf/asdf.lisp @@ -1,5 +1,5 @@ ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp -*- -;;; This is ASDF 2.018: Another System Definition Facility. +;;; This is ASDF 2.019: Another System Definition Facility. ;;; ;;; Feedback, bug reports, and patches are all welcome: ;;; please mail to <asdf-devel(a)common-lisp.net>. @@ -56,7 +56,7 @@ (eval-when (:compile-toplevel :load-toplevel :execute) ;;; Implementation-dependent tweaks - ;; (declaim (optimize (speed 2) (debug 2) (safety 3))) ; NO: rely on the implementation defaults. + ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; NO: trust implementation defaults. #+allegro (setf excl::*autoload-package-name-alist* (remove "asdf" excl::*autoload-package-name-alist* @@ -86,6 +86,8 @@ (find-symbol (string s) p)) ;; Strip out formatting that is not supported on Genera. ;; Has to be inside the eval-when to make Lispworks happy (!) + (defun strcat (&rest strings) + (apply 'concatenate 'string strings)) (defmacro compatfmt (format) #-(or gcl genera) format #+(or gcl genera) @@ -94,10 +96,8 @@ '(("~3i~_" . "")) #+genera '(("~@<" . "") ("; ~@;" . "; ") ("~@:>" . "") ("~:>" . ""))) :do (loop :for found = (search unsupported format) :while found :do - (setf format - (concatenate 'simple-string - (subseq format 0 found) replacement - (subseq format (+ found (length unsupported))))))) + (setf format (strcat (subseq format 0 found) replacement + (subseq format (+ found (length unsupported))))))) format) (let* (;; For bug reporting sanity, please always bump this version when you modify this file. ;; Please also modify asdf.asd to reflect this change. The script bin/bump-version @@ -107,7 +107,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.018") + (asdf-version "2.019") (existing-asdf (find-class 'component nil)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) @@ -185,7 +185,7 @@ (push sym bothly-exported-symbols) (push sym formerly-exported-symbols))) (loop :for sym :in export :do - (unless (member sym bothly-exported-symbols :test 'string-equal) + (unless (member sym bothly-exported-symbols :test 'equal) (push sym newly-exported-symbols))) (loop :for user :in (package-used-by-list package) :for shadowing = (package-shadowing-symbols user) :do @@ -226,23 +226,19 @@ #:compile-file* #:source-file-type) :unintern (#:*asdf-revision* #:around #:asdf-method-combination - #:split #:make-collector + #:split #:make-collector #:do-dep #:do-one-dep + #:resolve-relative-location-component #:resolve-absolute-location-component #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function :export - (#:defsystem #:oos #:operate #:find-system #:run-shell-command + (#:defsystem #:oos #:operate #:find-system #:locate-system #:run-shell-command #:system-definition-pathname #:with-system-definitions - #:search-for-system-definition #:find-component ; miscellaneous - #:compile-system #:load-system #:test-system #:clear-system - #:compile-op #:load-op #:load-source-op - #:test-op - #:operation ; operations - #:feature ; sort-of operation - #:version ; metaphorically sort-of an operation - #:version-satisfies + #:search-for-system-definition #:find-component #:component-find-path + #:compile-system #:load-system #:load-systems #:test-system #:clear-system + #:operation #:compile-op #:load-op #:load-source-op #:test-op + #:feature #:version #:version-satisfies #:upgrade-asdf #:implementation-identifier #:implementation-type - - #:input-files #:output-files #:output-file #:perform ; operation methods + #:input-files #:output-files #:output-file #:perform #:operation-done-p #:explain #:component #:source-file @@ -334,11 +330,19 @@ #:process-source-registry #:system-registered-p #:asdf-message + #:user-output-translations-pathname + #:system-output-translations-pathname + #:user-output-translations-directory-pathname + #:system-output-translations-directory-pathname + #:user-source-registry + #:system-source-registry + #:user-source-registry-directory + #:system-source-registry-directory ;; Utilities #:absolute-pathname-p ;; #:aif #:it - ;; #:appendf + ;; #:appendf #:orf #:coerce-name #:directory-pathname-p ;; #:ends-with @@ -346,9 +350,7 @@ #:getenv ;; #:length=n-p ;; #:find-symbol* - #:merge-pathnames* - #:coerce-pathname - #:subpathname + #:merge-pathnames* #:coerce-pathname #:subpathname #:pathname-directory-pathname #:read-file-forms ;; #:remove-keys @@ -411,6 +413,7 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when condition-arguments condition-form condition-format condition-location coerce-name) + (ftype (function (&optional t) (values)) initialize-source-registry) #-(or cormanlisp gcl-pre2.7) (ftype (function (t t) t) (setf module-components-by-name))) @@ -419,8 +422,8 @@ Note that ASDF ALWAYS raises an error if it fails to create an output file when #+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)))) @@ -520,6 +523,9 @@ and NIL NAME, TYPE and VERSION components" :do (pop reldir) (pop defrev) :finally (return (cons defabs (append (reverse defrev) reldir))))))))))) +(defun* ununspecific (x) + (if (eq x :unspecific) nil x)) + (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, @@ -538,9 +544,7 @@ Also, if either argument is NIL, then the other argument is returned unmodified. (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) - (labels ((ununspecific (x) - (if (eq x :unspecific) nil x)) - (unspecific-handler (p) + (labels ((unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) (ecase (first directory) @@ -891,24 +895,21 @@ with given pathname and if it exists return its truename." (host (pathname-host pathname)) (port (ext:pathname-port pathname)) (directory (pathname-directory pathname))) - (flet ((not-unspecific (component) - (and (not (eq component :unspecific)) component))) - (cond ((or (not-unspecific port) - (and (not-unspecific host) (plusp (length host))) - (not-unspecific scheme)) - (let ((prefix "")) - (when (not-unspecific port) - (setf prefix (format nil ":~D" port))) - (when (and (not-unspecific host) (plusp (length host))) - (setf prefix (concatenate 'string host prefix))) - (setf prefix (concatenate 'string ":" prefix)) - (when (not-unspecific scheme) - (setf prefix (concatenate 'string scheme prefix))) - (assert (and directory (eq (first directory) :absolute))) - (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) - :defaults pathname))) - (t - pathname))))) + (if (or (ununspecific port) + (and (ununspecific host) (plusp (length host))) + (ununspecific scheme)) + (let ((prefix "")) + (when (ununspecific port) + (setf prefix (format nil ":~D" port))) + (when (and (ununspecific host) (plusp (length host))) + (setf prefix (strcat host prefix))) + (setf prefix (strcat ":" prefix)) + (when (ununspecific scheme) + (setf prefix (strcat scheme prefix))) + (assert (and directory (eq (first directory) :absolute))) + (make-pathname :directory `(:absolute ,prefix ,@(rest directory)) + :defaults pathname))) + pathname)) ;;;; ------------------------------------------------------------------------- ;;;; ASDF Interface, in terms of generic functions. @@ -1171,45 +1172,6 @@ processed in order by OPERATE.")) (properties :accessor component-properties :initarg :properties :initform nil))) -;;; I believe that the following could probably be more efficiently done -;;; by a primary method that invokes SHARED-INITIALIZE in a way that would -;;; appropriately pass the slots to have their initforms re-applied, but I -;;; do not know how to write such a method. [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj component) &rest initargs - &key (version nil version-suppliedp) - (description nil description-suppliedp) - (long-description nil - long-description-suppliedp) - (load-dependencies nil - ld-suppliedp) - in-order-to - do-first - inline-methods - parent - properties) - "We reuse component objects from previously-existing systems, so we need to -make sure we clear them thoroughly." - (declare (ignore initargs load-dependencies - long-description description version)) - ;; this is a cache and should be cleared - (slot-makunbound obj 'absolute-pathname) - ;; component operation times are no longer valid when the component changes - (clrhash (component-operation-times obj)) - (unless version-suppliedp (slot-makunbound obj 'version)) - (unless description-suppliedp - (slot-makunbound obj 'description)) - (unless long-description-suppliedp - (slot-makunbound obj 'long-description)) - ;; replicate the logic of the initforms... - (unless ld-suppliedp - (setf (component-load-dependencies obj) nil)) - (setf (component-in-order-to obj) in-order-to - (component-do-first obj) do-first - (component-inline-methods obj) inline-methods - (slot-value obj 'parent) parent - (slot-value obj 'properties) properties)) - - (defun* component-find-path (component) (reverse (loop :for c = component :then (component-parent c) @@ -1282,21 +1244,6 @@ make sure we clear them thoroughly." :initarg :default-component-class :accessor module-default-component-class))) -;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT -;;; [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj module) &rest initargs &key) - "Clear MODULE's slots so it can be reused." - (slot-makunbound obj 'components-by-name) - ;; this may be a more elegant approach than in the - ;; COMPONENT method [2011/09/02:rpg] - (loop :for (initarg slot-name default) :in - `((:components components nil) - (:if-component-dep-fails if-component-dep-fails :fail) - (:default-component-class default-component-class - ,*default-component-class*)) - :unless (member initarg initargs) - :do (setf (slot-value obj slot-name) default))) - (defun* component-parent-pathname (component) ;; No default anymore (in particular, no *default-pathname-defaults*). ;; If you force component to have a NULL pathname, you better arrange @@ -1330,7 +1277,12 @@ make sure we clear them thoroughly." (acons property new-value (slot-value c 'properties))))) new-value) -(defclass system (module) +(defclass proto-system () ; slots to keep when resetting a system + ;; To preserve identity for all objects, we'd need keep the components slots + ;; but also to modify parse-component-form to reset the recycled objects. + ((name) #|(components) (components-by-names)|#)) + +(defclass system (module proto-system) (;; description and long-description are now available for all component's, ;; but now also inherited from component, but we add the legacy accessor (description :accessor system-description :initarg :description) @@ -1343,24 +1295,6 @@ make sure we clear them thoroughly." :writer %set-system-source-file) (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) -;;; see comment with REINITIALIZE-INSTANCE method on COMPONENT -;;; [2011/09/02:rpg] -(defmethod reinitialize-instance :after ((obj system) &rest initargs &key) - "Clear SYSTEM's slots so it can be reused." - ;; note that SYSTEM-SOURCE-FILE is very specially handled, - ;; by DO-DEFSYSTEM, so we need to *PRESERVE* its value and - ;; not squash it. SYSTEM COMPONENTS are handled very specially, - ;; because they are always, effectively, reused, since the system component - ;; is made early in DO-DEFSYSTEM, instead of being made later, in - ;; PARSE-COMPONENT-FORM [2011/09/02:rpg] - (loop :for (initarg slot-name) :in - `((:author author) - (:maintainer maintainer) - (:licence licence) - (:defsystem-depends-on defsystem-depends-on)) - :unless (member initarg initargs) - :do (slot-makunbound obj slot-name))) - ;;;; ------------------------------------------------------------------------- ;;;; version-satisfies @@ -1448,11 +1382,10 @@ NB: ignores leading zeroes, and so doesn't distinguish between 2.003 and 2.3" (file-position s (+ start network-volume-offset #x14)))) - (concatenate 'string - (read-null-terminated-string s) - (progn - (file-position s (+ start remaining-offset)) - (read-null-terminated-string s)))))) + (strcat (read-null-terminated-string s) + (progn + (file-position s (+ start remaining-offset)) + (read-null-terminated-string s)))))) (defun* parse-windows-shortcut (pathname) (with-open-file (s pathname :element-type '(unsigned-byte 8)) @@ -1539,15 +1472,25 @@ called with an object of type asdf:system." ;;; for the sake of keeping things reasonably neat, we adopt a ;;; convention that functions in this list are prefixed SYSDEF- -(defparameter *system-definition-search-functions* - '(sysdef-central-registry-search - sysdef-source-registry-search - sysdef-find-asdf)) +(defvar *system-definition-search-functions* '()) + +(setf *system-definition-search-functions* + (append + ;; Remove known-incompatible sysdef functions from ancient sbcl asdf. + (remove 'contrib-sysdef-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, + ;; but then it will be the responsibility of whoever does that + ;; 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-find-asdf)))) (defun* search-for-system-definition (system) - (let ((system-name (coerce-name system))) - (some #'(lambda (x) (funcall x system-name)) - (cons 'find-system-if-being-defined *system-definition-search-functions*)))) + (some (let ((name (coerce-name system))) #'(lambda (x) (funcall x name))) + (cons 'find-system-if-being-defined + *system-definition-search-functions*))) (defvar *central-registry* nil "A list of 'system directory designators' ASDF uses to find systems. @@ -1597,7 +1540,7 @@ Going forward, we recommend new users should be using the source-registry. (let ((shortcut (make-pathname :defaults defaults :version :newest :case :local - :name (concatenate 'string name ".asd") + :name (strcat name ".asd") :type "lnk"))) (when (probe-file* shortcut) (let ((target (parse-windows-shortcut shortcut))) @@ -1671,6 +1614,7 @@ Going forward, we recommend new users should be using the source-registry. 0))) (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~@:>")))) @@ -1690,7 +1634,7 @@ Going forward, we recommend new users should be using the source-registry. (let ((*systems-being-defined* (make-hash-table :test 'equal))) (funcall thunk)))) -(defmacro with-system-definitions (() &body body) +(defmacro with-system-definitions ((&optional) &body body) `(call-with-system-definitions #'(lambda () ,@body))) (defun* load-sysdef (name pathname) @@ -1711,17 +1655,27 @@ Going forward, we recommend new users should be using the source-registry. (load pathname))) (delete-package package))))) -(defmethod find-system ((name string) &optional (error-p t)) - (with-system-definitions () - (let* ((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)) +(defun* locate-system (name) + "Given a system NAME designator, try to locate where to load the system from. +Returns four values: FOUND-SYSTEM PATHNAME PREVIOUS PREVIOUS-TIME +FOUNDP is true when a new was found, either a new unregistered one or a previously registered one. +FOUND-SYSTEM when not null is a SYSTEM object that may be REGISTER-SYSTEM'ed as is +PATHNAME when not null is a path from where to load the system, 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 (or (and (typep found '(or pathname string)) (pathname found)) - (and found-system (system-source-file found-system)) - (and previous (system-source-file previous))))) + (found-system (and (typep found 'system) found)) + (pathname (or (and (typep found '(or pathname string)) (pathname found)) + (and found-system (system-source-file found-system)) + (and previous (system-source-file previous)))) + (foundp (and (or found-system pathname previous) t))) + (check-type found (or null pathname system)) + (when foundp (setf pathname (resolve-symlinks* pathname)) (when (and pathname (not (absolute-pathname-p pathname))) (setf pathname (ensure-pathname-absolute pathname)) @@ -1731,23 +1685,37 @@ Going forward, we recommend new users should be using the source-registry. (system-source-file previous) pathname))) (%set-system-source-file pathname previous) (setf previous-time nil)) - (when (and found-system (not previous)) - (register-system found-system)) - (when (and pathname - (or (not previous-time) - ;; don't reload if it's already been loaded, - ;; or its filestamp is in the future which means some clock is skewed - ;; and trying to load might cause an infinite loop. - (< previous-time (safe-file-write-date pathname) (get-universal-time)))) - (load-sysdef name pathname)) - (let ((in-memory (system-registered-p name))) ; try again after loading from disk - (cond - (in-memory - (when pathname - (setf (car in-memory) (safe-file-write-date pathname))) - (cdr in-memory)) - (error-p - (error 'missing-component :requires name))))))) + (values foundp found-system pathname previous previous-time)))) + +(defmethod find-system ((name string) &optional (error-p t)) + (with-system-definitions () + (loop + (restart-case + (multiple-value-bind (foundp found-system pathname previous previous-time) + (locate-system name) + (declare (ignore foundp)) + (when (and found-system (not previous)) + (register-system found-system)) + (when (and pathname + (or (not previous-time) + ;; don't reload if it's already been loaded, + ;; or its filestamp is in the future which means some clock is skewed + ;; and trying to load might cause an infinite loop. + (< previous-time (safe-file-write-date pathname) (get-universal-time)))) + (load-sysdef name pathname)) + (let ((in-memory (system-registered-p name))) ; try again after loading from disk if needed + (return + (cond + (in-memory + (when pathname + (setf (car in-memory) (safe-file-write-date pathname))) + (cdr in-memory)) + (error-p + (error 'missing-component :requires name)))))) + (reinitialize-source-registry-and-retry () + :report (lambda (s) + (format s "~@<Retry finding system ~A after reinitializing the source-registry.~@:>" name)) + (initialize-source-registry)))))) (defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) @@ -1873,12 +1841,9 @@ Host, device and version components are taken from DEFAULTS." (and pathname (merge-pathnames* (coerce-pathname subpath :type type) (pathname-directory-pathname pathname)))) -(defun* try-subpathname (pathname subpath &key type) - (let* ((sp (and pathname (probe-file* pathname) - (subpathname pathname subpath :type type))) - (ts (and sp (probe-file* sp)))) - (and ts (values sp ts)))) - +(defun subpathname* (pathname subpath &key type) + (and pathname + (subpathname (ensure-directory-pathname pathname) subpath :type type))) ;;;; ------------------------------------------------------------------------- ;;;; Operations @@ -1982,10 +1947,9 @@ class specifier, not an operation." (cdr (assoc (type-of o) (component-in-order-to c)))) (defmethod component-self-dependencies ((o operation) (c component)) - (let ((all-deps (component-depends-on o c))) - (remove-if-not #'(lambda (x) - (member (component-name c) (cdr x) :test #'string=)) - all-deps))) + (remove-if-not + #'(lambda (x) (member (component-name c) (cdr x) :test #'string=)) + (component-depends-on o c))) (defmethod input-files ((operation operation) (c component)) (let ((parent (component-parent c)) @@ -2357,10 +2321,18 @@ recursive calls to traverse.") ((component-parent c) (around-compile-hook (component-parent c))))) +(defun ensure-function (fun &key (package :asdf)) + (etypecase fun + ((or symbol function) fun) + (cons (eval `(function ,fun))) + (string (eval `(function ,(with-standard-io-syntax + (let ((*package* (find-package package))) + (read-from-string fun)))))))) + (defmethod call-with-around-compile-hook ((c component) thunk) (let ((hook (around-compile-hook c))) (if hook - (funcall hook thunk) + (funcall (ensure-function hook) thunk) (funcall thunk)))) (defvar *compile-op-compile-file-function* 'compile-file* @@ -2546,31 +2518,38 @@ recursive calls to traverse.") (defgeneric* operate (operation-class system &key &allow-other-keys)) (defgeneric* perform-plan (plan &key)) +;;;; Separating this into a different function makes it more forward-compatible +(defun* cleanup-upgraded-asdf (old-version) + (let ((new-version (asdf:asdf-version))) + (unless (equal old-version new-version) + (cond + ((version-satisfies new-version old-version) + (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + ((version-satisfies old-version new-version) + (warn (compatfmt "~&~@<; ~@;Downgraded ASDF from version ~A to version ~A~@:>~%") + old-version new-version)) + (t + (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") + old-version new-version))) + (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) + ;; 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*) + (dolist (s l) (find-system s nil)))) + t)))) + ;;;; Try to upgrade of ASDF. If a different version was used, return T. ;;;; We need do that before we operate on anything that depends on ASDF. (defun* upgrade-asdf () (let ((version (asdf:asdf-version))) (handler-bind (((or style-warning warning) #'muffle-warning)) (operate 'load-op :asdf :verbose nil)) - (let ((new-version (asdf:asdf-version))) - (block nil - (cond - ((equal version new-version) - (return nil)) - ((version-satisfies new-version version) - (asdf-message (compatfmt "~&~@<; ~@;Upgraded ASDF from version ~A to version ~A~@:>~%") - version new-version)) - ((version-satisfies version new-version) - (warn (compatfmt "~&~@<Downgraded ASDF from version ~A to version ~A~@:>~%") - version new-version)) - (t - (asdf-message (compatfmt "~&~@<; ~@;Changed ASDF from version ~A to incompatible version ~A~@:>~%") - version new-version))) - (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) - t))))) + (cleanup-upgraded-asdf version))) (defmethod perform-plan ((steps list) &key) (let ((*package* *package*) @@ -2634,7 +2613,7 @@ created with the same initargs as the original one. ")) (setf (documentation 'oos 'function) (format nil - "Short for _operate on system_ and an alias for the OPERATE function. ~&~&~a" + "Short for _operate on system_ and an alias for the OPERATE function.~%~%~a" operate-docstring)) (setf (documentation 'operate 'function) operate-docstring)) @@ -2646,6 +2625,9 @@ See OPERATE for details." (apply 'operate 'load-op system args) t) +(defun* load-systems (&rest systems) + (map () 'load-system systems)) + (defun* compile-system (system &rest args &key force verbose version &allow-other-keys) "Shorthand for `(operate 'asdf:compile-op system)`. See OPERATE @@ -2702,7 +2684,7 @@ Returns the new tree (which probably shares structure with the old one)" (if first-op-tree (progn (aif (assoc op2 (cdr first-op-tree)) - (if (find c (cdr it)) + (if (find c (cdr it) :test #'equal) nil (setf (cdr it) (cons c (cdr it)))) (setf (cdr first-op-tree) @@ -2724,8 +2706,7 @@ Returns the new tree (which probably shares structure with the old one)" (defvar *serial-depends-on* nil) (defun* sysdef-error-component (msg type name value) - (sysdef-error (concatenate 'string msg - (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) + (sysdef-error (strcat msg (compatfmt "~&~@<The value specified for ~(~A~) ~A is ~S~@:>")) type name value)) (defun* check-component-input (type name weakly-depends-on @@ -2802,29 +2783,22 @@ Returns the new tree (which probably shares structure with the old one)" (warn (compatfmt "~@<Invalid version ~S for component ~S~@[ of ~S~]~@:>") version name parent))) - (let* ((other-args (remove-keys - '(components pathname default-component-class - perform explain output-files operation-done-p - weakly-depends-on - depends-on serial in-order-to) - rest)) + (let* ((args (list* :name (coerce-name name) + :pathname pathname + :parent parent + (remove-keys + '(components pathname default-component-class + perform explain output-files operation-done-p + weakly-depends-on depends-on serial in-order-to) + rest))) (ret (find-component parent name))) (when weakly-depends-on (appendf depends-on (remove-if (complement #'find-system) weakly-depends-on))) (when *serial-depends-on* (push *serial-depends-on* depends-on)) - (if ret - (apply 'reinitialize-instance ret - :name (coerce-name name) - :pathname pathname - :parent parent - other-args) - (setf ret - (apply 'make-instance (class-for-type parent type) - :name (coerce-name name) - :pathname pathname - :parent parent - other-args))) + (if ret ; preserve identity + (apply 'reinitialize-instance ret args) + (setf ret (apply 'make-instance (class-for-type parent type) args))) (component-pathname ret) ; eagerly compute the absolute pathname (when (typep ret 'module) (setf (module-default-component-class ret) @@ -2856,6 +2830,10 @@ Returns the new tree (which probably shares structure with the old one)" (%refresh-component-inline-methods ret rest) ret))) +(defun* reset-system (system &rest keys &key &allow-other-keys) + (change-class (change-class system 'proto-system) 'system) + (apply 'reinitialize-instance system keys)) + (defun* do-defsystem (name &rest options &key pathname (class 'system) defsystem-depends-on &allow-other-keys) @@ -2868,14 +2846,14 @@ Returns the new tree (which probably shares structure with the old one)" (with-system-definitions () (let* ((name (coerce-name name)) (registered (system-registered-p name)) - (system (cdr (or registered - (register-system (make-instance 'system :name name))))) + (registered! (if registered + (rplaca registered (get-universal-time)) + (register-system (make-instance 'system :name name)))) + (system (reset-system (cdr registered!) + :name name :source-file (load-pathname))) (component-options (remove-keys '(:class) options))) - (%set-system-source-file (load-pathname) system) (setf (gethash name *systems-being-defined*) system) - (when registered - (setf (car registered) (get-universal-time))) - (map () 'load-system defsystem-depends-on) + (apply 'load-systems defsystem-depends-on) ;; We change-class (when necessary) AFTER we load the defsystem-dep's ;; since the class might not be defined as part of those. (let ((class (class-for-type nil class))) @@ -2960,7 +2938,7 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." (ccl:run-program (cond ((os-unix-p) "/bin/sh") - ((os-windows-p) (format nil "CMD /C ~A" command)) ; BEWARE! + ((os-windows-p) (strcat "CMD /C " command)) ; BEWARE! (t (error "Unsupported OS"))) (if (os-unix-p) (list "-c" command) '()) :input nil :output *verbose-out* :wait t))) @@ -2972,6 +2950,9 @@ output to *VERBOSE-OUT*. Returns the shell's exit code." (list "-c" command) :input nil :output *verbose-out*)) + #+cormanlisp + (win32:system command) + #+ecl ;; courtesy of Juan Jose Garcia Ripoll (ext:system command) @@ -3162,20 +3143,23 @@ located." (defun* user-configuration-directories () (let ((dirs - `(,(try-subpathname (getenv "XDG_CONFIG_HOME") "common-lisp/") - ,@(loop :with dirs = (getenv "XDG_CONFIG_DIRS") - :for dir :in (split-string dirs :separator ":") - :collect (try-subpathname dir "common-lisp/")) + `(,@(when (os-unix-p) + (cons + (subpathname* (getenv "XDG_CONFIG_HOME") "common-lisp/") + (loop :with dirs = (getenv "XDG_CONFIG_DIRS") + :for dir :in (split-string dirs :separator ":") + :collect (subpathname* dir "common-lisp/")))) ,@(when (os-windows-p) - `(,(try-subpathname (or #+lispworks (sys:get-folder-path :local-appdata) - (getenv "LOCALAPPDATA")) - "common-lisp/config/") + `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata) + (getenv "LOCALAPPDATA")) + "common-lisp/config/") ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData - ,(try-subpathname (or #+lispworks (sys:get-folder-path :appdata) - (getenv "APPDATA")) - "common-lisp/config/"))) - ,(try-subpathname (user-homedir) ".config/common-lisp/")))) - (remove-duplicates (remove-if #'null dirs) :from-end t :test 'equal))) + ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata) + (getenv "APPDATA")) + "common-lisp/config/"))) + ,(subpathname (user-homedir) ".config/common-lisp/")))) + (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) + :from-end t :test 'equal))) (defun* system-configuration-directories () (cond @@ -3183,19 +3167,23 @@ located." ((os-windows-p) (aif ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData - (try-subpathname (or #+lispworks (sys:get-folder-path :common-appdata) - (getenv "ALLUSERSAPPDATA") - (subpathname (getenv "ALLUSERSPROFILE") "Application Data/")) - "common-lisp/config/") + (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata) + (getenv "ALLUSERSAPPDATA") + (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/")) + "common-lisp/config/") (list it))))) -(defun* in-first-directory (dirs x) - (loop :for dir :in dirs - :thereis (and dir (probe-file* (merge-pathnames* x (ensure-directory-pathname dir)))))) -(defun* in-user-configuration-directory (x) - (in-first-directory (user-configuration-directories) x)) -(defun* in-system-configuration-directory (x) - (in-first-directory (system-configuration-directories) x)) +(defun* in-first-directory (dirs x &key (direction :input)) + (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)))))) + +(defun* in-user-configuration-directory (x &key (direction :input)) + (in-first-directory (user-configuration-directories) x :direction direction)) +(defun* in-system-configuration-directory (x &key (direction :input)) + (in-first-directory (system-configuration-directories) x :direction direction)) (defun* configuration-inheritance-directive-p (x) (let ((kw '(:inherit-configuration :ignore-inherited-configuration))) @@ -3549,14 +3537,14 @@ Please remove it from your ASDF configuration")) (defparameter *output-translations-file* (coerce-pathname "asdf-output-translations.conf")) (defparameter *output-translations-directory* (coerce-pathname "asdf-output-translations.conf.d/")) -(defun* user-output-translations-pathname () - (in-user-configuration-directory *output-translations-file*)) -(defun* system-output-translations-pathname () - (in-system-configuration-directory *output-translations-file*)) -(defun* user-output-translations-directory-pathname () - (in-user-configuration-directory *output-translations-directory*)) -(defun* system-output-translations-directory-pathname () - (in-system-configuration-directory *output-translations-directory*)) +(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")) @@ -3679,8 +3667,8 @@ effectively disabling the output translation facility." (translate-pathname path absolute-source destination)))) (defun* apply-output-translations (path) + #+cormanlisp (truenamize path) #-cormanlisp (etypecase path - #+cormanlisp (t (truenamize path)) (logical-pathname path) ((or pathname string) @@ -3721,7 +3709,7 @@ effectively disabling the output translation facility." (defun* tmpize-pathname (x) (make-pathname - :name (format nil "ASDF-TMP-~A" (pathname-name x)) + :name (strcat "ASDF-TMP-" (pathname-name x)) :defaults x)) (defun* delete-file-if-exists (x) @@ -3852,6 +3840,7 @@ with a different configuration, so the configuration would be re-read then." (loop :for f :in entries :for p = (or (and (typep f 'logical-pathname) f) (let* ((u (ignore-errors (funcall merger f)))) + ;; The first u avoids a cumbersome (truename u) error (and u (equal (ignore-errors (truename u)) f) u))) :when p :collect p) entries)) @@ -3865,8 +3854,9 @@ with a different configuration, so the configuration would be re-read then." (filter-logical-directory-results directory entries #'(lambda (f) - (make-pathname :defaults directory :version (pathname-version f) - :name (pathname-name f) :type (pathname-type f)))))) + (make-pathname :defaults directory + :name (pathname-name f) :type (ununspecific (pathname-type f)) + :version (ununspecific (pathname-version f))))))) (defun* directory-asd-files (directory) (directory-files directory *wild-asd*)) @@ -3875,9 +3865,9 @@ with a different configuration, so the configuration would be re-read then." (let* ((directory (ensure-directory-pathname directory)) #-(or abcl cormanlisp genera xcl) (wild (merge-pathnames* - #-(or abcl allegro cmu lispworks scl xcl) + #-(or abcl allegro cmu lispworks sbcl scl xcl) *wild-directory* - #+(or abcl allegro cmu lispworks scl xcl) "*.*" + #+(or abcl allegro cmu lispworks sbcl scl xcl) "*.*" directory)) (dirs #-(or abcl cormanlisp genera xcl) @@ -3887,16 +3877,16 @@ with a different configuration, so the configuration would be re-read then." #+(or abcl xcl) (system:list-directory directory) #+cormanlisp (cl::directory-subdirs directory) #+genera (fs:directory-list directory)) - #+(or abcl allegro cmu genera lispworks scl xcl) + #+(or abcl allegro cmu genera lispworks sbcl scl xcl) (dirs (loop :for x :in dirs :for d = #+(or abcl xcl) (extensions:probe-directory x) #+allegro (excl:probe-directory x) - #+(or cmu scl) (directory-pathname-p x) + #+(or cmu sbcl scl) (directory-pathname-p x) #+genera (getf (cdr x) :directory) #+lispworks (lw:file-directory-p x) :when d :collect #+(or abcl allegro xcl) d #+genera (ensure-directory-pathname (first x)) - #+(or cmu lispworks scl) x))) + #+(or cmu lispworks sbcl scl) x))) (filter-logical-directory-results directory dirs (let ((prefix (normalize-pathname-directory-component @@ -4021,12 +4011,12 @@ with a different configuration, so the configuration would be re-read then." #+scl (:tree #p"file://modules/"))) (defun* default-source-registry () `(:source-registry - #+sbcl (:directory ,(try-subpathname (user-homedir) ".sbcl/systems/")) + #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) (:directory ,(default-directory)) ,@(loop :for dir :in `(,@(when (os-unix-p) `(,(or (getenv "XDG_DATA_HOME") - (try-subpathname (user-homedir) ".local/share/")) + (subpathname (user-homedir) ".local/share/")) ,@(split-string (or (getenv "XDG_DATA_DIRS") "/usr/local/share:/usr/share") :separator ":"))) @@ -4037,18 +4027,18 @@ with a different configuration, so the configuration would be re-read then." (getenv "APPDATA")) ,(or #+lispworks (sys:get-folder-path :common-appdata) (getenv "ALLUSERSAPPDATA") - (try-subpathname (getenv "ALLUSERSPROFILE") "Application Data/"))))) - :collect `(:directory ,(try-subpathname dir "common-lisp/systems/")) - :collect `(:tree ,(try-subpathname dir "common-lisp/source/"))) + (subpathname* (getenv "ALLUSERSPROFILE") "Application Data/"))))) + :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) + :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) :inherit-configuration)) -(defun* user-source-registry () - (in-user-configuration-directory *source-registry-file*)) -(defun* system-source-registry () - (in-system-configuration-directory *source-registry-file*)) -(defun* user-source-registry-directory () - (in-user-configuration-directory *source-registry-directory*)) -(defun* system-source-registry-directory () - (in-system-configuration-directory *source-registry-directory*)) +(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")) @@ -4126,8 +4116,7 @@ with a different configuration, so the configuration would be re-read then." (collect (list directory :recurse recurse :exclude exclude))))) :test 'equal :from-end t))) -;; Will read the configuration and initialize all internal variables, -;; and return the new configuration. +;; 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 diff --git a/src/general-info/release-20d.txt b/src/general-info/release-20d.txt index 0c926f7..d73037c 100644 --- a/src/general-info/release-20d.txt +++ b/src/general-info/release-20d.txt @@ -23,7 +23,7 @@ New in this release: * Feature enhancements * Changes - * ASDF2 updated to version 2.018. + * ASDF2 updated to version 2.019. * Behavior of STRING-TO-OCTETS has changed. This is an incompatible change from the previous version but should be more useful when a buffer is given which is not large enough to hold @@ -33,6 +33,8 @@ New in this release: * ANSI compliance fixes: * Bugfixes: + * DECODE-FLOAT was not correctly declared and could not be + compiled to handle double-double-floats. * Trac Tickets: ----------------------------------------------------------------------- Summary of changes: src/contrib/asdf/asdf.lisp | 539 +++++++++++++++++++------------------- src/general-info/release-20d.txt | 4 +- 2 files changed, 267 insertions(+), 276 deletions(-) hooks/post-receive -- CMU Common Lisp

1 0