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

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 30 Nov '10

30 Nov '10

Date: Tuesday, November 30, 2010 @ 08:51:29 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Clarify entry on realpart/imagpart bug. It's an x86-only problem, and only happens in some situations. -----------------+ release-20c.txt | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.11 src/general-info/release-20c.txt:1.12 --- src/general-info/release-20c.txt:1.11 Mon Nov 29 23:18:43 2010 +++ src/general-info/release-20c.txt Tue Nov 30 08:51:29 2010 @@ -66,8 +66,9 @@ Previously, it skipped over non-BMP codepoints. This also requires a fix in %COMPOSE to handle non-BMP codepoints correctly. The normalization test now passes. - - REALPART and IMAGPART no longer incorrectly returns 0 instead of - the correct part of a complex number. + - On x86, REALPART and IMAGPART no longer incorrectly returns 0 + instead of the correct part of a complex number in some + situations. - The command line parser now correctly handles the case where "--" is the first command option. - build.sh was accidenally loading the site-init file, but it

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 30 Nov '10

30 Nov '10

Date: Monday, November 29, 2010 @ 23:18:43 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Update from commits. -----------------+ release-20c.txt | 2 ++ 1 file changed, 2 insertions(+) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.10 src/general-info/release-20c.txt:1.11 --- src/general-info/release-20c.txt:1.10 Tue Nov 16 14:27:39 2010 +++ src/general-info/release-20c.txt Mon Nov 29 23:18:43 2010 @@ -81,6 +81,8 @@ returned because GET-BEST-AUTHORIZATION was looking for the hostname. - FORMAT signals an warning if ~:; is used inside ~:[. + - SET-SYSTEM-EXTERNAL-FORMAT was not actually setting the filename + encoding if given. * Trac Tickets:

1 0

[cmucl-cvs] CMUCL commit: src/code (extfmts.lisp)
by Raymond Toy 30 Nov '10

30 Nov '10

Date: Monday, November 29, 2010 @ 23:09:42 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: extfmts.lisp o *FILENAME-ENCODING* was never getting set. Fix that. (From Paul Foley.) o While we're here, canonicalize *FILENAME-ENCODING* using the actual external format name. --------------+ extfmts.lisp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) Index: src/code/extfmts.lisp diff -u src/code/extfmts.lisp:1.41 src/code/extfmts.lisp:1.42 --- src/code/extfmts.lisp:1.41 Tue Sep 7 22:58:06 2010 +++ src/code/extfmts.lisp Mon Nov 29 23:09:42 2010 @@ -5,7 +5,7 @@ ;;; domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/extfmts.lisp,v 1.41 2010-09-08 02:58:06 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/extfmts.lisp,v 1.42 2010-11-30 04:09:42 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1102,11 +1102,12 @@ (when filenames (unless (find-external-format filenames) (error (intl:gettext "Can't find external-format ~S.") filenames)) + (setq filenames (ef-name (find-external-format filenames))) (when (and unix::*filename-encoding* (not (eq unix::*filename-encoding* filenames))) (cerror (intl:gettext "Change it anyway.") - (intl:gettext "The external-format for encoding filenames is already set.")) - (setq unix::*filename-encoding* filenames))) + (intl:gettext "The external-format for encoding filenames is already set."))) + (setq unix::*filename-encoding* filenames)) t)

1 0

[cmucl-cvs] CMUCL commit: cross-sparc-branch src/compiler/sparc (parms.lisp)
by Raymond Toy 20 Nov '10

20 Nov '10

Date: Saturday, November 20, 2010 @ 10:45:05 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler/sparc Tag: cross-sparc-branch Modified: parms.lisp Set up TARGET-FOREIGN-LINKAGE-SPACE-START and TARGET-FOREIGN-LINKAGE-ENTRY-SIZE from the backend values. ------------+ parms.lisp | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) Index: src/compiler/sparc/parms.lisp diff -u src/compiler/sparc/parms.lisp:1.61.6.1 src/compiler/sparc/parms.lisp:1.61.6.2 --- src/compiler/sparc/parms.lisp:1.61.6.1 Tue Nov 16 12:29:34 2010 +++ src/compiler/sparc/parms.lisp Sat Nov 20 10:45:05 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/sparc/parms.lisp,v 1.61.6.1 2010-11-16 17:29:34 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/sparc/parms.lisp,v 1.61.6.2 2010-11-20 15:45:05 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -48,8 +48,11 @@ #+mach 4096 #+sunos 8192) (setf (c::backend-foreign-linkage-space-start *target-backend*) + ;; This better match the value in sparc-validate.h! #x0f800000 (c::backend-foreign-linkage-entry-size *target-backend*) + ;; This better agree with what sparc-arch.c thinks it is! Right now, + ;; it's 4 instructions, so 16 bytes. 16) ); eval-when @@ -217,11 +220,10 @@ (defconstant target-static-space-start #x28000000) (defconstant target-dynamic-space-start #x40000000) -;; This better match the value in sparc-validate.h! -(defconstant target-foreign-linkage-space-start #x0f800000) -;; This better agree with what sparc-arch.c thinks it is! Right now, -;; it's 4 instructions, so 16 bytes. -(defconstant target-foreign-linkage-entry-size 16) +(defconstant target-foreign-linkage-space-start + (c:backend-foreign-linkage-space-start *target-backend*)) +(defconstant target-foreign-linkage-entry-size + (c:backend-foreign-linkage-entry-size *target-backend*)) ;;;; Other random constants.

1 0

[cmucl-cvs] CMUCL commit: cross-sparc-branch src/compiler/generic (new-genesis.lisp)
by Raymond Toy 18 Nov '10

18 Nov '10

Date: Wednesday, November 17, 2010 @ 19:25:10 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler/generic Tag: cross-sparc-branch Modified: new-genesis.lisp o Comment out debugging prints. o Add some comments. ------------------+ new-genesis.lisp | 41 ++++++++++++++++++++++++++++++----------- 1 file changed, 30 insertions(+), 11 deletions(-) Index: src/compiler/generic/new-genesis.lisp diff -u src/compiler/generic/new-genesis.lisp:1.91.2.2 src/compiler/generic/new-genesis.lisp:1.91.2.3 --- src/compiler/generic/new-genesis.lisp:1.91.2.2 Tue Nov 16 17:01:49 2010 +++ src/compiler/generic/new-genesis.lisp Wed Nov 17 19:25:10 2010 @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.91.2.2 2010-11-16 22:01:49 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.91.2.3 2010-11-18 00:25:10 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -436,14 +436,17 @@ (setf (aref bytes k) (logand #xffff (char-code (aref string k))))) (unless (eq (c:backend-byte-order c:*backend*) (c:backend-byte-order c:*native-backend*)) - ;; Swap byte order of unicode strings. - (format t "s-t-c: len = ~d, ~S~%" len string) - (format t " codes = ~{~X~^ ~}~%" (map 'list #'char-code string)) + ;; Swap byte order of unicode strings if the backend and + ;; native-backend have different endianness. + #+(or) + (progn + (format t "s-t-c: len = ~d, ~S~%" len string) + (format t " codes = ~{~X~^ ~}~%" (map 'list #'char-code string))) (dotimes (k len) (let ((x (aref bytes k))) (setf (aref bytes k) (maybe-byte-swap-short x)))) - (format t " new codes = ~{~X~^ ~}~%" (coerce bytes 'list)) - ) + #+(or) + (format t " new codes = ~{~X~^ ~}~%" (coerce bytes 'list))) (copy-to-system-area bytes (* vm:vector-data-offset ;; the word size of the native backend which ;; may be different from the target backend @@ -1341,6 +1344,8 @@ (logior (ash (ldb (byte 8 0) n) 8) (ldb (byte 8 8) n))) +;; Destructively byte swap a string, if the backend and the native +;; backend have different endianness. (defun maybe-byte-swap-string (s &optional (len (length s))) (unless (eq (c:backend-byte-order c:*backend*) (c:backend-byte-order c:*native-backend*)) @@ -1353,8 +1358,12 @@ (defun cold-load-symbol (size package) (let ((string (make-string size))) (read-n-bytes *fasl-file* string 0 (* 2 size)) + #+(or) (format t "pre swap cold-load-symbol: ~S to package ~S~%" string package) + ;; Make the string have the correct byte order for the native + ;; backend. (maybe-byte-swap-string string) + #+(or) (format t "post swap cold-load-symbol: ~S to package ~S~%" string package) (cold-intern (intern string package) package))) @@ -1464,8 +1473,13 @@ (let* ((len (clone-arg)) (string (make-string len))) (read-n-bytes *fasl-file* string 0 (* 2 len)) + #+(or) (format t "pre fop-string result = ~{~X~^ ~}~%" (map 'list #'char-code string)) + ;; Make the string have the correct byte order for the native + ;; backend. (This wouldn't be needed if string-to-core had an + ;; option to (maybe-byte-swap-string string) + #+(or) (format t "post fop-string result = ~{~X~^ ~}~%" (map 'list #'char-code string)) (string-to-core string))) @@ -1994,9 +2008,12 @@ #+unicode (progn (read-n-bytes *fasl-file* sym 0 (* 2 len)) - (format t "foreign-fixup: ~S~%" sym) - (format t " codes: ~{~X~^ ~}~%" (map 'list #'char-code sym)) + #+(or) + (progn + (format t "foreign-fixup: ~S~%" sym) + (format t " codes: ~{~X~^ ~}~%" (map 'list #'char-code sym))) (maybe-byte-swap-string sym) + #+(or) (format t " swaps: ~S~%" sym)) (let ((offset (read-arg 4)) (value #+linkage-table (cold-register-foreign-linkage sym :code) @@ -2017,9 +2034,12 @@ #+unicode (progn (read-n-bytes *fasl-file* sym 0 (* 2 len)) - (format t "foreign-data-fixup: ~S~%" sym) - (format t " codes: ~{~X~^ ~}~%" (map 'list #'char-code sym)) + #+(or) + (progn + (format t "foreign-data-fixup: ~S~%" sym) + (format t " codes: ~{~X~^ ~}~%" (map 'list #'char-code sym))) (maybe-byte-swap-string sym) + #+(or) (format t " swaps: ~{~X~^ ~}~%" (map 'list #'char-code sym))) (let ((offset (read-arg 4)) (value (cold-register-foreign-linkage sym :data))) @@ -2484,7 +2504,6 @@ (defun linkage-info-to-core () (let ((result *nil-descriptor*)) (maphash #'(lambda (symbol value) - (format t "linkage-info symbol = ~S~%" symbol) (cold-push (allocate-cons *dynamic* (string-to-core symbol) (number-to-core value))

1 0

[cmucl-cvs] CMUCL commit: cross-sparc-branch src/compiler/x86 (parms.lisp)
by Raymond Toy 18 Nov '10

18 Nov '10

Date: Wednesday, November 17, 2010 @ 19:24:02 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler/x86 Tag: cross-sparc-branch Modified: parms.lisp Set up TARGET-FOREIGN-LINKAGE-SPACE-START and TARGET-FOREIGN-LINKAGE-ENTRY-SIZE from the backend values. ------------+ parms.lisp | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) Index: src/compiler/x86/parms.lisp diff -u src/compiler/x86/parms.lisp:1.40.6.1 src/compiler/x86/parms.lisp:1.40.6.2 --- src/compiler/x86/parms.lisp:1.40.6.1 Tue Nov 16 12:29:35 2010 +++ src/compiler/x86/parms.lisp Wed Nov 17 19:24:02 2010 @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group(a)cs.cmu.edu. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/x86/parms.lisp,v 1.40.6.1 2010-11-16 17:29:35 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/x86/parms.lisp,v 1.40.6.2 2010-11-18 00:24:02 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -219,9 +219,9 @@ #+linux #x58100000 #-linux #x48000000) (defconstant target-foreign-linkage-space-start - #+linux #x58000000 - #-linux #xB0000000) -(defconstant target-foreign-linkage-entry-size 8) ;In bytes. Duh. + (c:backend-foreign-linkage-space-start *target-backend*)) +(defconstant target-foreign-linkage-entry-size + (c:backend-foreign-linkage-entry-size *target-backend*)) ;In bytes. Duh. ;;; Given that NIL is the first thing allocated in static space, we ;;; know its value at compile time:

1 0

[cmucl-cvs] CMUCL commit: cross-sparc-branch src/tools/cross-scripts (cross-x86-sparc.lisp)
by Raymond Toy 18 Nov '10

18 Nov '10

Date: Wednesday, November 17, 2010 @ 19:22:33 Author: rtoy Path: /project/cmucl/cvsroot/src/tools/cross-scripts Tag: cross-sparc-branch Modified: cross-x86-sparc.lisp o Need to remove the :i486 feature from x86. (Include :pentium too?) o Add comments. o Comment out debugging prints. ----------------------+ cross-x86-sparc.lisp | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) Index: src/tools/cross-scripts/cross-x86-sparc.lisp diff -u src/tools/cross-scripts/cross-x86-sparc.lisp:1.1.2.1 src/tools/cross-scripts/cross-x86-sparc.lisp:1.1.2.2 --- src/tools/cross-scripts/cross-x86-sparc.lisp:1.1.2.1 Tue Nov 16 12:29:35 2010 +++ src/tools/cross-scripts/cross-x86-sparc.lisp Wed Nov 17 19:22:33 2010 @@ -36,8 +36,10 @@ ) ;; Features to remove from current *features* here '(:sparc-v8 :sparc-v7 ; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9 - ;; Other architectures we aren't using. - :x86 :x86-bootstrap :sse2 :x87 + ;; Other architectures we aren't using. Particularly important + ;; to get rid of sse2 and x87 so we don't accidentally try to + ;; compile the x87/sse2 float support on sparc, which won't work. + :x86 :x86-bootstrap :sse2 :x87 :i486 :alpha :osf1 :mips ;; Really old stuff that should have been removed long ago. :propagate-fun-type :propagate-float-type :constrain-float-type @@ -51,14 +53,21 @@ :mp)) ;;; Changes needed to bootstrap cross-compiling from x86 to sparc + +;; Set up the linkage space stuff appropriately for sparc. (setf (c::backend-foreign-linkage-space-start c::*target-backend*) #x0f800000 (c::backend-foreign-linkage-entry-size c::*target-backend*) 16) (in-package "LISP") +;; We need the the fops because the cross-compiled fasl file is in +;; big-endian order for sparc. When we read in a string, we need to +;; convert the big-endian string to little-endian for x86 so we can +;; process the symbols and such as expected. (progn (defun maybe-swap-string (f name &optional (len (length name))) + (declare (ignorable f)) (unless (eq (c:backend-byte-order c:*backend*) (c:backend-byte-order c:*native-backend*)) (dotimes (k len) @@ -66,7 +75,7 @@ (setf (aref name k) (code-char (logior (ash (ldb (byte 8 0) code) 8) (ldb (byte 8 8) code)))))) - (format t "~S: new name = ~S~%" f name) + ;;(format t "~S: new name = ~S~%" f (subseq name 0 len)) name)) (macrolet ((frob (name code name-size package) @@ -106,8 +115,7 @@ (define-fop (fop-package 14) (let ((name (pop-stack))) - (format t "xfop-package: ~{~X~^ ~}~%" (map 'list #'char-code name)) - ;; Byte swap name + ;;(format t "xfop-package: ~{~X~^ ~}~%" (map 'list #'char-code name)) (or (find-package name) (error (intl:gettext "The package ~S does not exist.") name)))) @@ -124,9 +132,9 @@ (defun cold-load-symbol (size package) (let ((string (make-string size))) (read-n-bytes *fasl-file* string 0 (* 2 size)) - (format t "xpre swap cold-load-symbol: ~S to package ~S~%" string package) - (maybe-byte-swap-string string) - (format t "xpost swap cold-load-symbol: ~S to package ~S~%" string package) + ;;(format t "xpre swap cold-load-symbol: ~S to package ~S~%" string package) + (maybe-swap-string 'cold-load-symbol string) + ;;(format t "xpost swap cold-load-symbol: ~S to package ~S~%" string package) (cold-intern (intern string package) package))) )

1 0

[cmucl-cvs] CMUCL commit: cross-sparc-branch src/lisp (os-common.c)
by Raymond Toy 16 Nov '10

16 Nov '10

Date: Tuesday, November 16, 2010 @ 17:06:31 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Tag: cross-sparc-branch Modified: os-common.c Add some debugging prints, but not activated. -------------+ os-common.c | 33 ++++++++++++++++++++++++++++++++- 1 file changed, 32 insertions(+), 1 deletion(-) Index: src/lisp/os-common.c diff -u src/lisp/os-common.c:1.31 src/lisp/os-common.c:1.31.10.1 --- src/lisp/os-common.c:1.31 Mon Feb 1 14:27:07 2010 +++ src/lisp/os-common.c Tue Nov 16 17:06:29 2010 @@ -1,6 +1,6 @@ /* - $Header: /project/cmucl/cvsroot/src/lisp/os-common.c,v 1.31 2010-02-01 19:27:07 rtoy Rel $ + $Header: /project/cmucl/cvsroot/src/lisp/os-common.c,v 1.31.10.1 2010-11-16 22:06:29 rtoy Exp $ This code was written as part of the CMU Common Lisp project at Carnegie Mellon University, and has been placed in the public domain. @@ -195,6 +195,23 @@ */ convert_lisp_string(c_symbol_name, symbol_name->data, (symbol_name->length >> 2)); + +#if 0 + fprintf(stderr, "i =%2d: %s\n", i, c_symbol_name); + { + int k; + unsigned short int* wide_string; + + fprintf(stderr, " symbol_name->data = "); + + wide_string = (unsigned short int *) symbol_name->data; + + for (k = 0; k < (symbol_name->length >> 2); ++k) { + fprintf(stderr, "%4x ", wide_string[k]); + } + fprintf(stderr, "\n"); + } +#endif if (i == 0) { #if defined(sparc) if (type != LINKAGE_CODE_TYPE || strcmp(c_symbol_name, "call_into_c")) { @@ -226,6 +243,20 @@ void *target_addr = os_dlsym(c_symbol_name, NIL); if (!target_addr) { +#if 0 + int k; + unsigned short int* wide_string; + + fprintf(stderr, "c_symbol_name = `%s'\n", c_symbol_name); + fprintf(stderr, "symbol_name->data = \n"); + + wide_string = (unsigned short int *) symbol_name->data; + + for (k = 0; k < (symbol_name->length >> 2); ++k) { + fprintf(stderr, "%4x ", wide_string[k]); + } + fprintf(stderr, "\n"); +#endif lose("%s is not defined.\n", c_symbol_name); } arch_make_linkage_entry(i / LINKAGE_DATA_ENTRY_SIZE, target_addr,

1 0

[cmucl-cvs] CMUCL commit: cross-sparc-branch src/compiler/generic (new-genesis.lisp)
by Raymond Toy 16 Nov '10

16 Nov '10

Date: Tuesday, November 16, 2010 @ 17:01:50 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler/generic Tag: cross-sparc-branch Modified: new-genesis.lisp Don't need to do the weird stuff in cold-register-foreign-linkage and make-cold-linkage-vector anymore because I forgot to byte-swap the foreign-fixup stuff. o Add optional length parameter to MAYBE-BYTE-SWAP-STRING so we don't print out the entire string if we're not using it all. o Don't need to do the weird byte-swap in make-cold-linkage-vector. o Remove debugging print from make-cold-linkage-vector. o Swap bytes if necessary in fop-foreign-fixup and fop-foreign-data-fixup. o Remove optional swap-p parameter from cold-register-foreign-linkage because it's not needed anymore. o No need to supply swap-p parameter when registering "call_into_c". ------------------+ new-genesis.lisp | 33 ++++++++++++++++++--------------- 1 file changed, 18 insertions(+), 15 deletions(-) Index: src/compiler/generic/new-genesis.lisp diff -u src/compiler/generic/new-genesis.lisp:1.91.2.1 src/compiler/generic/new-genesis.lisp:1.91.2.2 --- src/compiler/generic/new-genesis.lisp:1.91.2.1 Tue Nov 16 12:29:34 2010 +++ src/compiler/generic/new-genesis.lisp Tue Nov 16 17:01:49 2010 @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.91.2.1 2010-11-16 17:29:34 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.91.2.2 2010-11-16 22:01:49 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1341,10 +1341,10 @@ (logior (ash (ldb (byte 8 0) n) 8) (ldb (byte 8 8) n))) -(defun maybe-byte-swap-string (s) +(defun maybe-byte-swap-string (s &optional (len (length s))) (unless (eq (c:backend-byte-order c:*backend*) (c:backend-byte-order c:*native-backend*)) - (dotimes (k (length s)) + (dotimes (k len) (let ((code (char-code (aref s k)))) (setf (aref s k) (code-char (swap-16 code)))))) s) @@ -1611,9 +1611,6 @@ do (write-indexed data-vec (+ i vm:vector-data-offset) (etypecase vec-elem (string - (format t "make-cold-linkage-vector: string = ~{~X~^ ~}~%" - (map 'list #'char-code vec-elem)) - (maybe-byte-swap-string vec-elem) (string-to-core vec-elem)) (number (number-to-core vec-elem)) @@ -1995,8 +1992,12 @@ #-unicode (read-n-bytes *fasl-file* sym 0 len) #+unicode - (dotimes (k len) - (setf (aref sym k) (load-char-code))) + (progn + (read-n-bytes *fasl-file* sym 0 (* 2 len)) + (format t "foreign-fixup: ~S~%" sym) + (format t " codes: ~{~X~^ ~}~%" (map 'list #'char-code sym)) + (maybe-byte-swap-string sym) + (format t " swaps: ~S~%" sym)) (let ((offset (read-arg 4)) (value #+linkage-table (cold-register-foreign-linkage sym :code) #-linkage-table (lookup-foreign-symbol sym))) @@ -2014,8 +2015,12 @@ #-unicode (read-n-bytes *fasl-file* sym 0 len) #+unicode - (dotimes (k len) - (setf (aref sym k) (load-char-code))) + (progn + (read-n-bytes *fasl-file* sym 0 (* 2 len)) + (format t "foreign-data-fixup: ~S~%" sym) + (format t " codes: ~{~X~^ ~}~%" (map 'list #'char-code sym)) + (maybe-byte-swap-string sym) + (format t " swaps: ~{~X~^ ~}~%" (map 'list #'char-code sym))) (let ((offset (read-arg 4)) (value (cold-register-foreign-linkage sym :data))) (do-cold-fixup code-object offset value kind)) @@ -2213,10 +2218,8 @@ (defvar *cold-foreign-hash* (make-hash-table :test #'equal)) #+linkage-table -(defun cold-register-foreign-linkage (sym type &optional (swap-p nil)) - (let ((entry-num (register-foreign-linkage (if swap-p - (maybe-byte-swap-string (copy-seq sym)) - sym) +(defun cold-register-foreign-linkage (sym type) + (let ((entry-num (register-foreign-linkage sym type *cold-linkage-table* *cold-foreign-hash*))) @@ -2233,7 +2236,7 @@ (cold-register-foreign-linkage "resolve_linkage_tramp" :code) #+(or sparc ppc) (progn - (cold-register-foreign-linkage (vm::extern-alien-name "call_into_c") :code t) + (cold-register-foreign-linkage (vm::extern-alien-name "call_into_c") :code) #-sparc (cold-register-foreign-linkage (vm::extern-alien-name "undefined_tramp") :data) #-sparc

1 0

[cmucl-cvs] CMUCL commit: src/general-info (release-20c.txt)
by Raymond Toy 16 Nov '10

16 Nov '10

Date: Tuesday, November 16, 2010 @ 14:27:39 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Update from logs. -----------------+ release-20c.txt | 13 +++++++++++++ 1 file changed, 13 insertions(+) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.9 src/general-info/release-20c.txt:1.10 --- src/general-info/release-20c.txt:1.9 Tue Nov 2 14:31:33 2010 +++ src/general-info/release-20c.txt Tue Nov 16 14:27:39 2010 @@ -43,6 +43,8 @@ needs to create. - Add src/tools/build-all.sh to automate building all of the variants (x87/sse2, unicode/8-bit). + - LISP::ENUMERATE-MATCHES had a keyword arg named + :VERIFY-EXISTANCE. This has been changed to :VERIFY-EXISTENCE. * ANSI compliance fixes: - Fixes for signaling errors with READ-CHAR and READ-BYTE @@ -68,6 +70,17 @@ the correct part of a complex number. - The command line parser now correctly handles the case where "--" is the first command option. + - build.sh was accidenally loading the site-init file, but it + shouldn't. + - On sparc, the vops to add a float to a complex were broken, + resulting in a complex number with the float as realpart and + garbage for the imaginary part. This is now fixed. + - XLIB::GET-BEST-AUTHORIZATION will now return authorization data + if the protocol is :local, if the xauth file contains just + "localhost/unix:0". Previously, no authorization data was + returned because GET-BEST-AUTHORIZATION was looking for the + hostname. + - FORMAT signals an warning if ~:; is used inside ~:[. * Trac Tickets:

1 0

[cmucl-cvs] CMUCL commit: src/code (format.lisp)
by Raymond Toy 16 Nov '10

16 Nov '10

Date: Tuesday, November 16, 2010 @ 14:15:38 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: format.lisp Signal a warning if ~:[ directive includes ~:;. From a message by Didier Verna, cmucl-imp, 2010-11-11. -------------+ format.lisp | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) Index: src/code/format.lisp diff -u src/code/format.lisp:1.96 src/code/format.lisp:1.97 --- src/code/format.lisp:1.96 Tue Apr 20 13:57:44 2010 +++ src/code/format.lisp Tue Nov 16 14:15:38 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/format.lisp,v 1.96 2010-04-20 17:57:44 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/format.lisp,v 1.97 2010-11-16 19:15:38 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2384,9 +2384,13 @@ (expand-maybe-conditional (car sublists))))) (if colonp (if (= (length sublists) 2) - (expand-bind-defaults () params - (expand-true-false-conditional (car sublists) - (cadr sublists))) + (progn + (when last-semi-with-colon-p + (error 'format-error + :complaint (intl:gettext "~~:; directive not effective in ~~:["))) + (expand-bind-defaults () params + (expand-true-false-conditional (car sublists) + (cadr sublists)))) (error 'format-error :complaint (intl:gettext "Must specify exactly two sections.")))

1 0

[cmucl-cvs] CMUCL commit: src/clx (display.lisp)
by Raymond Toy 16 Nov '10

16 Nov '10

Date: Tuesday, November 16, 2010 @ 14:13:56 Author: rtoy Path: /project/cmucl/cvsroot/src/clx Modified: display.lisp GET-BEST-AUTHORIZATION wasn't handling the case of a :local connection where the xauth file only contained one entry for localhost/unix:0. When the protocol is :local, we explicitly check for localhost. Previously, the host-address was converted the hostname, which isn't "localhost". --------------+ display.lisp | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) Index: src/clx/display.lisp diff -u src/clx/display.lisp:1.15 src/clx/display.lisp:1.16 --- src/clx/display.lisp:1.15 Mon Jul 13 09:54:35 2009 +++ src/clx/display.lisp Tue Nov 16 14:13:55 2010 @@ -19,7 +19,7 @@ ;;; #+cmu -(ext:file-comment "$Id: display.lisp,v 1.15 2009-07-13 13:54:35 rtoy Rel $") +(ext:file-comment "$Id: display.lisp,v 1.16 2010-11-16 19:13:55 rtoy Exp $") (in-package :xlib) @@ -117,7 +117,9 @@ (read-xauth-entry stream) (unless family (return)) (when (and (eql family protocol) - (equal host-address address) + (or (equal host-address address) + (and (eql family :local) + (equal address "localhost"))) (= number display) (let ((pos1 (position name *known-authorizations* :test #'string=)))

1 0

[cmucl-cvs] CMUCL commit: cross-sparc-branch src (6 files)
by Raymond Toy 16 Nov '10

16 Nov '10

Date: Tuesday, November 16, 2010 @ 12:29:35 Author: rtoy Path: /project/cmucl/cvsroot/src Tag: cross-sparc-branch Added: tools/cross-scripts/cross-x86-sparc.lisp Modified: compiler/dump.lisp compiler/generic/new-genesis.lisp compiler/ppc/parms.lisp compiler/sparc/parms.lisp compiler/x86/parms.lisp First cut at getting a cross-compile (Unicode) from x86 to sparc. This needs more work, but the cross-compile does produce a sparc core where the repl works. But currently that sparc core cannot rebuild cmucl. To do this, a version of cmucl from the HEAD branch needs to be created to add the new slots to the backend. Then a new x86 build needs to be done using these sources. Finally, a cross-compile can be done using cross-x86-sparc.lisp as the cross-compile script. compiler/dump.lisp: o I think we actually do need to swap the string bytes when dumping strings to a fasl because the fasl will eventually get loaded by the target system, and the codes need to be in the correct byte order. compiler/generic/new-genesis.lisp: o LOAD-CHAR-CODE should test against C:*BACKEND*, not C:*NATIVE-BACKEND*. o Add MAYBE-BYTE-SWAP-STRING to swap the bytes of the character codes if the *backend* and *native-backend* have different endianness. o Swap the strings read from a fasl. The fasl should have strings in the target endianness, but when we cold-load them, we need the native endianness. (I think). This means swapping bytes in COLD-LOAD-SYMBOL, FOP-UNINTERNED-SYMBOL-SAVE, FOP-UNINTERNED-SMALL-SYMBOL-SAVE, FOP-STRING, FOP-SMALL-STRING. o In MAKE-COLD-LINKAGE-VECTOR, byte swap the string before we store the string to the core. The string in the linkage vector already has the correct endianness, and string-to-core will swap the bytes. (Not sure why the linkage string ares this way, though. This is a hack.) o Add optional swap-p paramter to COLD-REGISTER-FOREIGN-LINKAGE to enable byte swapping of the symbol string. This is a hack to get "call_into_c" into the correct byte order for the target and MAKE-COLD-LINKAGE-VECTOR. o Use the backend foreign-linkage-space-start and foreign-linkage-entry-size for COLD-REGISTER-FOREIGN-LINKAGE. This prevents the wrong addresses leaking into the target. (Previously, the values form the native backend were getting used, which wreaks havoc on the target since the addresses are not even close.) compiler/ppc/parms.lisp: o Set up the backend-foreign-linkage-space-start and backend-foreign-linkage-entry-size with the correct values. compiler/sparc/parms.lisp: o Set up the backend-foreign-linkage-space-start and backend-foreign-linkage-entry-size with the correct values. compiler/x86/parms.lisp: o Set up the backend-foreign-linkage-space-start and backend-foreign-linkage-entry-size with the correct values. tools/cross-scripts/cross-x86-sparc.lisp: o New cross-compile script to do an x86 to sparc cross-compile. Needs work. ------------------------------------------+ compiler/dump.lisp | 20 - compiler/generic/new-genesis.lisp | 61 +++- compiler/ppc/parms.lisp | 7 compiler/sparc/parms.lisp | 6 compiler/x86/parms.lisp | 8 tools/cross-scripts/cross-x86-sparc.lisp | 369 +++++++++++++++++++++++++++++ 6 files changed, 439 insertions(+), 32 deletions(-) Index: src/compiler/dump.lisp diff -u src/compiler/dump.lisp:1.89 src/compiler/dump.lisp:1.89.2.1 --- src/compiler/dump.lisp:1.89 Wed Nov 10 14:51:24 2010 +++ src/compiler/dump.lisp Tue Nov 16 12:29:34 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/dump.lisp,v 1.89 2010-11-10 19:51:24 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/dump.lisp,v 1.89.2.1 2010-11-16 17:29:34 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1635,14 +1635,16 @@ bytes-per-element) (type unsigned-byte elements)) (if (stringp data-vector) - ;; Don't swap string bytes. We get here only if we're - ;; cross-compiling from one arch to a different endian - ;; arch. To be able to load the fasls, we need to keep - ;; strings in the native format. When genesis is done, - ;; genesis will swap string bytes when creating the - ;; core so that the bytes are in the correct order. - (dotimes (index elements) - (setf (aref result index) (char-code (aref data-vector index)))) + (progn + ;;(format t "reverse string data: ~S~%" data-vector) + #+(or) + (dotimes (index elements) + (let ((c (char-code (aref data-vector index)))) + (setf (aref result index) c))) + (dotimes (index elements) + (let ((c (char-code (aref data-vector index)))) + (setf (aref result index) (logior (ash (ldb (byte 8 0) c) 8) + (ldb (byte 8 8) c)))))) (dotimes (index elements) (let ((element (aref data-vector index)) (new-element 0)) Index: src/compiler/generic/new-genesis.lisp diff -u src/compiler/generic/new-genesis.lisp:1.91 src/compiler/generic/new-genesis.lisp:1.91.2.1 --- src/compiler/generic/new-genesis.lisp:1.91 Thu Nov 11 16:48:24 2010 +++ src/compiler/generic/new-genesis.lisp Tue Nov 16 12:29:34 2010 @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.91 2010-11-11 21:48:24 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.91.2.1 2010-11-16 17:29:34 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -431,16 +431,19 @@ vm:simple-string-type)) (bytes (make-array (1+ len) :element-type '(unsigned-byte 16)))) (write-indexed des vm:vector-length-slot (make-fixnum-descriptor len)) - ;;(format t "s-t-c: len = ~d, ~S~%" len string) + (dotimes (k len) (setf (aref bytes k) (logand #xffff (char-code (aref string k))))) (unless (eq (c:backend-byte-order c:*backend*) (c:backend-byte-order c:*native-backend*)) ;; Swap byte order of unicode strings. + (format t "s-t-c: len = ~d, ~S~%" len string) + (format t " codes = ~{~X~^ ~}~%" (map 'list #'char-code string)) (dotimes (k len) (let ((x (aref bytes k))) - (setf (aref bytes k) (+ (ldb (byte 8 8) x) - (ash (ldb (byte 8 0) x) 8)))))) + (setf (aref bytes k) (maybe-byte-swap-short x)))) + (format t " new codes = ~{~X~^ ~}~%" (coerce bytes 'list)) + ) (copy-to-system-area bytes (* vm:vector-data-offset ;; the word size of the native backend which ;; may be different from the target backend @@ -1324,7 +1327,7 @@ #+unicode (defmacro load-char-code () - (ecase (c::backend-byte-order c::*native-backend*) + (ecase (c::backend-byte-order c::*backend*) (:little-endian `(code-char (+ (read-arg 1) (ash (read-arg 1) 8)))) @@ -1332,13 +1335,27 @@ `(code-char (+ (ash (read-arg 1) 8) (read-arg 1)))))) +(declaim (inline swap-16)) +(defun swap-16 (n) + (declare (type (unsigned-byte 16) n)) + (logior (ash (ldb (byte 8 0) n) 8) + (ldb (byte 8 8) n))) + +(defun maybe-byte-swap-string (s) + (unless (eq (c:backend-byte-order c:*backend*) + (c:backend-byte-order c:*native-backend*)) + (dotimes (k (length s)) + (let ((code (char-code (aref s k)))) + (setf (aref s k) (code-char (swap-16 code)))))) + s) + #+unicode (defun cold-load-symbol (size package) (let ((string (make-string size))) - #+nil (read-n-bytes *fasl-file* string 0 (* 2 size)) - (dotimes (k size) - (setf (aref string k) (load-char-code))) + (format t "pre swap cold-load-symbol: ~S to package ~S~%" string package) + (maybe-byte-swap-string string) + (format t "post swap cold-load-symbol: ~S to package ~S~%" string package) (cold-intern (intern string package) package))) (clone-cold-fop (fop-symbol-save) @@ -1378,10 +1395,8 @@ (fop-uninterned-small-symbol-save) (let* ((size (clone-arg)) (name (make-string size))) - #+nil - (read-n-bytes *fasl-file* name 0 size) - (dotimes (k size) - (setf (aref name k) (load-char-code))) + (read-n-bytes *fasl-file* name 0 (* 2 size)) + (maybe-byte-swap-string name) (let ((symbol (allocate-symbol name))) (push-table symbol)))) @@ -1448,10 +1463,10 @@ (fop-small-string) (let* ((len (clone-arg)) (string (make-string len))) - #+nil (read-n-bytes *fasl-file* string 0 (* 2 len)) - (dotimes (k len) - (setf (aref string k) (load-char-code))) + (format t "pre fop-string result = ~{~X~^ ~}~%" (map 'list #'char-code string)) + (maybe-byte-swap-string string) + (format t "post fop-string result = ~{~X~^ ~}~%" (map 'list #'char-code string)) (string-to-core string))) (clone-cold-fop (fop-vector) @@ -1596,6 +1611,9 @@ do (write-indexed data-vec (+ i vm:vector-data-offset) (etypecase vec-elem (string + (format t "make-cold-linkage-vector: string = ~{~X~^ ~}~%" + (map 'list #'char-code vec-elem)) + (maybe-byte-swap-string vec-elem) (string-to-core vec-elem)) (number (number-to-core vec-elem)) @@ -2195,13 +2213,15 @@ (defvar *cold-foreign-hash* (make-hash-table :test #'equal)) #+linkage-table -(defun cold-register-foreign-linkage (sym type) - (let ((entry-num (register-foreign-linkage sym +(defun cold-register-foreign-linkage (sym type &optional (swap-p nil)) + (let ((entry-num (register-foreign-linkage (if swap-p + (maybe-byte-swap-string (copy-seq sym)) + sym) type *cold-linkage-table* *cold-foreign-hash*))) - (+ vm:target-foreign-linkage-space-start - (* entry-num vm:target-foreign-linkage-entry-size)))) + (+ (c:backend-foreign-linkage-space-start c:*backend*) + (* entry-num (c:backend-foreign-linkage-entry-size c:*backend*))))) #+linkage-table (defun init-foreign-linkage () @@ -2213,7 +2233,7 @@ (cold-register-foreign-linkage "resolve_linkage_tramp" :code) #+(or sparc ppc) (progn - (cold-register-foreign-linkage (vm::extern-alien-name "call_into_c") :code) + (cold-register-foreign-linkage (vm::extern-alien-name "call_into_c") :code t) #-sparc (cold-register-foreign-linkage (vm::extern-alien-name "undefined_tramp") :data) #-sparc @@ -2461,6 +2481,7 @@ (defun linkage-info-to-core () (let ((result *nil-descriptor*)) (maphash #'(lambda (symbol value) + (format t "linkage-info symbol = ~S~%" symbol) (cold-push (allocate-cons *dynamic* (string-to-core symbol) (number-to-core value)) Index: src/compiler/ppc/parms.lisp diff -u src/compiler/ppc/parms.lisp:1.19 src/compiler/ppc/parms.lisp:1.19.20.1 --- src/compiler/ppc/parms.lisp:1.19 Thu Jun 11 12:04:00 2009 +++ src/compiler/ppc/parms.lisp Tue Nov 16 12:29:34 2010 @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group(a)cs.cmu.edu. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/ppc/parms.lisp,v 1.19 2009-06-11 16:04:00 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/compiler/ppc/parms.lisp,v 1.19.20.1 2010-11-16 17:29:34 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -37,6 +37,11 @@ (setf (backend-byte-order *target-backend*) :big-endian) (setf (backend-page-size *target-backend*) 4096) +(setf (c::backend-foreign-linkage-space-start *target-backend*) + #x17000000 + (c::backend-foreign-linkage-entry-size *target-backend*) + 32) + ); eval-when (pushnew :new-assembler *features*) Index: src/compiler/sparc/parms.lisp diff -u src/compiler/sparc/parms.lisp:1.61 src/compiler/sparc/parms.lisp:1.61.6.1 --- src/compiler/sparc/parms.lisp:1.61 Mon Apr 19 14:21:31 2010 +++ src/compiler/sparc/parms.lisp Tue Nov 16 12:29:34 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/sparc/parms.lisp,v 1.61 2010-04-19 18:21:31 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/compiler/sparc/parms.lisp,v 1.61.6.1 2010-11-16 17:29:34 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -47,6 +47,10 @@ (setf (backend-page-size *target-backend*) #+mach 4096 #+sunos 8192) +(setf (c::backend-foreign-linkage-space-start *target-backend*) + #x0f800000 + (c::backend-foreign-linkage-entry-size *target-backend*) + 16) ); eval-when (pushnew :new-assembler *features*) Index: src/compiler/x86/parms.lisp diff -u src/compiler/x86/parms.lisp:1.40 src/compiler/x86/parms.lisp:1.40.6.1 --- src/compiler/x86/parms.lisp:1.40 Wed Jul 14 09:14:53 2010 +++ src/compiler/x86/parms.lisp Tue Nov 16 12:29:35 2010 @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group(a)cs.cmu.edu. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/x86/parms.lisp,v 1.40 2010-07-14 13:14:53 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/compiler/x86/parms.lisp,v 1.40.6.1 2010-11-16 17:29:35 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -62,6 +62,12 @@ |# (setf (backend-page-size *target-backend*) 4096) + +(setf (c::backend-foreign-linkage-space-start *target-backend*) + #+linux #x58000000 + #-linux #xB0000000 + (c::backend-foreign-linkage-entry-size *target-backend*) + 8) ); eval-when Index: src/tools/cross-scripts/cross-x86-sparc.lisp diff -u /dev/null src/tools/cross-scripts/cross-x86-sparc.lisp:1.1.2.1 --- /dev/null Tue Nov 16 12:29:35 2010 +++ src/tools/cross-scripts/cross-x86-sparc.lisp Tue Nov 16 12:29:35 2010 @@ -0,0 +1,369 @@ +;;; Cross-compile script to build a sparc core using x86 as the +;;; compiling system. This needs work! + +(in-package :cl-user) + +;;; Rename the X86 package and backend so that new-backend does the +;;; right thing. +(rename-package "X86" "OLD-X86" '("OLD-VM")) +(setf (c:backend-name c:*native-backend*) "OLD-X86") + +(c::new-backend "SPARC" + ;; Features to add here + '(:sparc + :sparc-v9 ; For Ultrasparc processors + :complex-fp-vops ; Some slightly faster FP vops on complex numbers + :linkage-table + :stack-checking ; Throw error if we run out of stack + :heap-overflow-check ; Throw error if we run out of + ; heap (This requires gencgc!) + :gencgc ; Generational GC + :relative-package-names ; Relative package names from Allegro + :conservative-float-type + :hash-new + :random-mt19937 ; MT-19937 generator + :cmu ; Announce this is CMUCL + :cmu20 :cmu20b ; Current version identifier + :modular-arith ; Modular arithmetic + :double-double ; Double-double float support + :executable + + :solaris + :svr4 + :sun4 + :sunos + :unix + ) + ;; Features to remove from current *features* here + '(:sparc-v8 :sparc-v7 ; Choose only one of :sparc-v7, :sparc-v8, :sparc-v9 + ;; Other architectures we aren't using. + :x86 :x86-bootstrap :sse2 :x87 + :alpha :osf1 :mips + ;; Really old stuff that should have been removed long ago. + :propagate-fun-type :propagate-float-type :constrain-float-type + ;; Other OSes were not using + :openbsd :freebsd :glibc2 :linux :mach-o :darwin :bsd + + :pentium + :long-float + :new-random + :small + :mp)) + +;;; Changes needed to bootstrap cross-compiling from x86 to sparc +(setf (c::backend-foreign-linkage-space-start c::*target-backend*) + #x0f800000 + (c::backend-foreign-linkage-entry-size c::*target-backend*) + 16) + +(in-package "LISP") +(progn +(defun maybe-swap-string (f name &optional (len (length name))) + (unless (eq (c:backend-byte-order c:*backend*) + (c:backend-byte-order c:*native-backend*)) + (dotimes (k len) + (let ((code (char-code (aref name k)))) + (setf (aref name k) + (code-char (logior (ash (ldb (byte 8 0) code) 8) + (ldb (byte 8 8) code)))))) + (format t "~S: new name = ~S~%" f name) + name)) + +(macrolet ((frob (name code name-size package) + (let ((n-package (gensym "PACKAGE-")) + (n-size (gensym "SIZE-")) + (n-buffer (gensym "BUFFER-")) + (k (gensym "IDX-"))) + `(define-fop (,name ,code) + (prepare-for-fast-read-byte *fasl-file* + (let ((,n-package ,package) + (,n-size (fast-read-u-integer ,name-size))) + (when (> ,n-size *load-symbol-buffer-size*) + (setq *load-symbol-buffer* + (make-string (setq *load-symbol-buffer-size* + (* ,n-size 2))))) + (done-with-fast-read-byte) + (let ((,n-buffer *load-symbol-buffer*)) + (read-n-bytes *fasl-file* ,n-buffer 0 + (* old-vm:char-bytes ,n-size)) + (maybe-swap-string ',name ,n-buffer ,n-size) + (push-table (intern* ,n-buffer ,n-size ,n-package))))))))) + (frob fop-symbol-save 6 4 *package*) + (frob fop-small-symbol-save 7 1 *package*) + (frob fop-lisp-symbol-save 75 4 *lisp-package*) + (frob fop-lisp-small-symbol-save 76 1 *lisp-package*) + (frob fop-keyword-symbol-save 77 4 *keyword-package*) + (frob fop-keyword-small-symbol-save 78 1 *keyword-package*) + + (frob fop-symbol-in-package-save 8 4 + (svref *current-fop-table* (fast-read-u-integer 4))) + (frob fop-small-symbol-in-package-save 9 1 + (svref *current-fop-table* (fast-read-u-integer 4))) + (frob fop-symbol-in-byte-package-save 10 4 + (svref *current-fop-table* (fast-read-u-integer 1))) + (frob fop-small-symbol-in-byte-package-save 11 1 + (svref *current-fop-table* (fast-read-u-integer 1)))) + +(define-fop (fop-package 14) + (let ((name (pop-stack))) + (format t "xfop-package: ~{~X~^ ~}~%" (map 'list #'char-code name)) + ;; Byte swap name + (or (find-package name) + (error (intl:gettext "The package ~S does not exist.") name)))) + +(clone-fop (fop-string 37) + (fop-small-string 38) + (let* ((arg (clone-arg)) + (res (make-string arg))) + (read-n-bytes *fasl-file* res 0 + (* old-vm:char-bytes arg)) + (maybe-swap-string 'fop-string res) + res)) + +#+unicode +(defun cold-load-symbol (size package) + (let ((string (make-string size))) + (read-n-bytes *fasl-file* string 0 (* 2 size)) + (format t "xpre swap cold-load-symbol: ~S to package ~S~%" string package) + (maybe-byte-swap-string string) + (format t "xpost swap cold-load-symbol: ~S to package ~S~%" string package) + (cold-intern (intern string package) package))) +) + + +;;; End changes needed to bootstrap cross-compiling from x86 to sparc + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + ;;(format t "extern-alien-name: ~S~%" name) + ;;(lisp::maybe-swap-string 'extern-alien-name (copy-seq name)) + name) +(export 'extern-alien-name) +#+(or) +(defun fixup-code-object (code offset fixup kind) + (declare (type index offset)) + (unless (zerop (rem offset vm::word-bytes)) + (error (intl:gettext "Unaligned instruction? offset=#x~X.") offset)) + (system:without-gcing + (let ((sap (truly-the system-area-pointer + (%primitive c::code-instructions code)))) + (ecase kind + (:call + (error (intl:gettext "Can't deal with CALL fixups, yet."))) + (:sethi + (setf (ldb (byte 22 0) (sap-ref-32 sap offset)) + (ldb (byte 22 10) fixup))) + (:add + (setf (ldb (byte 10 0) (sap-ref-32 sap offset)) + (ldb (byte 10 0) fixup))))))) +(export 'fixup-code-object) +#+(or) +(defun sanctify-for-execution (component) + (without-gcing + (alien-funcall (extern-alien "os_flush_icache" + (function void + system-area-pointer + unsigned-long)) + (code-instructions component) + (* (code-header-ref component code-code-size-slot) + word-bytes))) + nil) +(export 'sanctify-for-execution) + +;;; Compile the new backend. +(pushnew :bootstrap *features*) +(pushnew :building-cross-compiler *features*) +(load "target:tools/comcom") + +;;; Load the new backend. +(setf (search-list "c:") + '("target:compiler/")) +(setf (search-list "vm:") + '("c:sparc/" "c:generic/")) +(setf (search-list "assem:") + '("target:assembly/" "target:assembly/sparc/")) + +;; Load the backend of the compiler. + +(in-package "C") + +(load "vm:vm-macs") +(load "vm:parms") +(load "vm:objdef") +(load "vm:interr") +(load "assem:support") + +(load "target:compiler/srctran") +(load "vm:vm-typetran") +(load "target:compiler/float-tran") +(load "target:compiler/saptran") + +(load "vm:macros") +(load "vm:utils") + +(load "vm:vm") +(load "vm:insts") +(load "vm:primtype") +(load "vm:move") +(load "vm:sap") +(load "vm:system") +(load "vm:char") +(load "vm:float") + +(load "vm:memory") +(load "vm:static-fn") +(load "vm:arith") +(load "vm:cell") +(load "vm:subprim") +(load "vm:debug") +(load "vm:c-call") +(load "vm:print") +(load "vm:alloc") +(load "vm:call") +(load "vm:nlx") +(load "vm:values") +(load "vm:array") +(load "vm:pred") +(load "vm:type-vops") + +(load "assem:assem-rtns") + +(load "assem:array") +(load "assem:arith") +(load "assem:alloc") + +(load "c:pseudo-vops") + +(check-move-function-consistency) + +(load "vm:new-genesis") + +;;; OK, the cross compiler backend is loaded. + +(setf *features* (remove :building-cross-compiler *features*)) + +;;; Info environment hacks. +(macrolet ((frob (&rest syms) + `(progn ,@(mapcar #'(lambda (sym) + `(defconstant ,sym + (symbol-value + (find-symbol ,(symbol-name sym) + :vm)))) + syms)))) + (frob OLD-VM:BYTE-BITS OLD-VM:WORD-BITS + OLD-VM:CHAR-BITS + OLD-VM:LOWTAG-BITS + #+long-float OLD-VM:SIMPLE-ARRAY-LONG-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-SINGLE-FLOAT-TYPE + #+long-float OLD-VM:SIMPLE-ARRAY-COMPLEX-LONG-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-COMPLEX-SINGLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-2-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-4-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-8-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-16-TYPE + OLD-VM:SIMPLE-ARRAY-UNSIGNED-BYTE-32-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-8-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-16-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-30-TYPE + OLD-VM:SIMPLE-ARRAY-SIGNED-BYTE-32-TYPE + OLD-VM:SIMPLE-BIT-VECTOR-TYPE + OLD-VM:SIMPLE-STRING-TYPE OLD-VM:SIMPLE-VECTOR-TYPE + OLD-VM:SIMPLE-ARRAY-TYPE OLD-VM:VECTOR-DATA-OFFSET + OLD-VM:DOUBLE-FLOAT-DIGITS + old-vm:single-float-digits + OLD-VM:DOUBLE-FLOAT-EXPONENT-BYTE + OLD-VM:DOUBLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-VM:DOUBLE-FLOAT-SIGNIFICAND-BYTE + OLD-VM:SINGLE-FLOAT-EXPONENT-BYTE + OLD-VM:SINGLE-FLOAT-NORMAL-EXPONENT-MAX + OLD-VM:SINGLE-FLOAT-SIGNIFICAND-BYTE + ) + #+double-double + (frob OLD-VM:SIMPLE-ARRAY-COMPLEX-DOUBLE-DOUBLE-FLOAT-TYPE + OLD-VM:SIMPLE-ARRAY-DOUBLE-DOUBLE-FLOAT-TYPE) + ) + +(let ((function (symbol-function 'kernel:error-number-or-lose))) + (let ((*info-environment* (c:backend-info-environment c:*target-backend*))) + (setf (symbol-function 'kernel:error-number-or-lose) function) + (setf (info function kind 'kernel:error-number-or-lose) :function) + (setf (info function where-from 'kernel:error-number-or-lose) :defined))) + +(defun fix-class (name) + (let* ((new-value (find-class name)) + (new-layout (kernel::%class-layout new-value)) + (new-cell (kernel::find-class-cell name)) + (*info-environment* (c:backend-info-environment c:*target-backend*))) + (remhash name kernel::*forward-referenced-layouts*) + (kernel::%note-type-defined name) + (setf (info type kind name) :instance) + (setf (info type class name) new-cell) + (setf (info type compiler-layout name) new-layout) + new-value)) +(fix-class 'c::vop-parse) +(fix-class 'c::operand-parse) + +#+random-mt19937 +(declaim (notinline kernel:random-chunk)) + +(setf c:*backend* c:*target-backend*) + +;;; Extern-alien-name for the new backend. +(in-package :vm) +(defun extern-alien-name (name) + (declare (type simple-string name)) + ;;(format t "extern-alien-name: ~S~%" name) + ;;(lisp::maybe-swap-string 'extern-alien-name (copy-seq name)) + name) +(export 'extern-alien-name) +#+(or) +(defun fixup-code-object (code offset fixup kind) + (declare (type index offset)) + (unless (zerop (rem offset vm::word-bytes)) + (error (intl:gettext "Unaligned instruction? offset=#x~X.") offset)) + (system:without-gcing + (let ((sap (truly-the system-area-pointer + (%primitive c::code-instructions code)))) + (ecase kind + (:call + (error (intl:gettext "Can't deal with CALL fixups, yet."))) + (:sethi + (setf (ldb (byte 22 0) (sap-ref-32 sap offset)) + (ldb (byte 22 10) fixup))) + (:add + (setf (ldb (byte 10 0) (sap-ref-32 sap offset)) + (ldb (byte 10 0) fixup))))))) +(export 'fixup-code-object) +#+(or) +(defun sanctify-for-execution (component) + (without-gcing + (alien-funcall (extern-alien "os_flush_icache" + (function void + system-area-pointer + unsigned-long)) + (code-instructions component) + (* (code-header-ref component code-code-size-slot) + word-bytes))) + nil) +(export 'sanctify-for-execution) + +(in-package :cl-user) + +;;; Don't load compiler parts from the target compilation + +(defparameter *load-stuff* nil) + +;; hack, hack, hack: Make old-x86::any-reg the same as +;; x86::any-reg as an SC. Do this by adding old-x86::any-reg +;; to the hash table with the same value as x86::any-reg. + +(let ((ht (c::backend-sc-names c::*target-backend*))) + (setf (gethash 'old-vm::any-reg ht) + (gethash 'vm::any-reg ht))) + + +;;(pushnew :debug *features*)

1 0

[cmucl-cvs] CMUCL commit: src/code (unix.lisp)
by Raymond Toy 12 Nov '10

12 Nov '10

Date: Friday, November 12, 2010 @ 11:53:17 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: unix.lisp Fix padding for stat64. st-pad2 was the wrong size to pad st-size to a 64-bit boundary. Add st-pad3 to make sure st-blocks is on a 64-bit boundary. Only a problem when cross-compiling from a different arch. The native compile correctly padded the fields. -----------+ unix.lisp | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) Index: src/code/unix.lisp diff -u src/code/unix.lisp:1.130 src/code/unix.lisp:1.131 --- src/code/unix.lisp:1.130 Tue Apr 20 13:57:45 2010 +++ src/code/unix.lisp Fri Nov 12 11:53:17 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/unix.lisp,v 1.130 2010-04-20 17:57:45 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/unix.lisp,v 1.131 2010-11-12 16:53:17 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -567,19 +567,20 @@ (def-alien-type nil (struct stat64 (st-dev dev-t) - (st-pad1 (array long 3)) + (st-pad1 (array long 3)) ; Pad so ino is 64-bit aligned (st-ino ino64-t) (st-mode unsigned-long) (st-nlink short) (st-uid uid-t) (st-gid gid-t) (st-rdev dev-t) - (st-pad2 (array long 2)) + (st-pad2 (array long 3)) ; Pad so size is 64-bit aligned (st-size off64-t) (st-atime (struct timestruc-t)) (st-mtime (struct timestruc-t)) (st-ctime (struct timestruc-t)) (st-blksize long) + (st-pad3 (array long 1)) ; Pad so blocks is 64-bit aligned (st-blocks blkcnt64-t) (st-fstype (array char 16)) (st-pad4 (array long 8))))

1 0

[cmucl-cvs] CMUCL commit: src/lisp (solaris-os.c)
by Raymond Toy 12 Nov '10

12 Nov '10

Date: Friday, November 12, 2010 @ 07:57:32 Author: rtoy Path: /project/cmucl/cvsroot/src/lisp Modified: solaris-os.c Print out the PC when we get a real protection violation. --------------+ solaris-os.c | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) Index: src/lisp/solaris-os.c diff -u src/lisp/solaris-os.c:1.25 src/lisp/solaris-os.c:1.26 --- src/lisp/solaris-os.c:1.25 Mon Feb 1 11:04:43 2010 +++ src/lisp/solaris-os.c Fri Nov 12 07:57:32 2010 @@ -1,5 +1,5 @@ /* - * $Header: /project/cmucl/cvsroot/src/lisp/solaris-os.c,v 1.25 2010-02-01 16:04:43 rtoy Rel $ + * $Header: /project/cmucl/cvsroot/src/lisp/solaris-os.c,v 1.26 2010-11-12 12:57:32 rtoy Exp $ * * OS-dependent routines. This file (along with os.h) exports an * OS-independent interface to the operating system VM facilities. @@ -260,7 +260,9 @@ } /* a *real* protection fault */ - fprintf(stderr, "segv_handler: Real protection violation: %p\n", addr); + fprintf(stderr, "segv_handler: Real protection violation: %p, PC = %p\n", + addr, + context->uc_mcontext.gregs[1]); segv_handle_now(signal, code, context); } #else

1 0

[cmucl-cvs] CMUCL commit: src/compiler/generic (new-genesis.lisp)
by Raymond Toy 11 Nov '10

11 Nov '10

Date: Thursday, November 11, 2010 @ 16:48:24 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler/generic Modified: new-genesis.lisp When storing strings to the core file, swap the bytes of Unicode strings if the byte order of the backend and the native backend are different. ------------------+ new-genesis.lisp | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) Index: src/compiler/generic/new-genesis.lisp diff -u src/compiler/generic/new-genesis.lisp:1.90 src/compiler/generic/new-genesis.lisp:1.91 --- src/compiler/generic/new-genesis.lisp:1.90 Mon Jul 19 19:08:37 2010 +++ src/compiler/generic/new-genesis.lisp Thu Nov 11 16:48:24 2010 @@ -4,7 +4,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.90 2010-07-19 23:08:37 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.91 2010-11-11 21:48:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -434,6 +434,13 @@ ;;(format t "s-t-c: len = ~d, ~S~%" len string) (dotimes (k len) (setf (aref bytes k) (logand #xffff (char-code (aref string k))))) + (unless (eq (c:backend-byte-order c:*backend*) + (c:backend-byte-order c:*native-backend*)) + ;; Swap byte order of unicode strings. + (dotimes (k len) + (let ((x (aref bytes k))) + (setf (aref bytes k) (+ (ldb (byte 8 8) x) + (ash (ldb (byte 8 0) x) 8)))))) (copy-to-system-area bytes (* vm:vector-data-offset ;; the word size of the native backend which ;; may be different from the target backend

1 0

[cmucl-cvs] CMUCL commit: src/compiler/sparc (float.lisp)
by Raymond Toy 11 Nov '10

11 Nov '10

Date: Thursday, November 11, 2010 @ 07:59:51 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler/sparc Modified: float.lisp Vops for adding a real to a complex was totally messed up. The real part of the result was the real, and the imaginary part of the result was garbage. ------------+ float.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/compiler/sparc/float.lisp diff -u src/compiler/sparc/float.lisp:1.63 src/compiler/sparc/float.lisp:1.64 --- src/compiler/sparc/float.lisp:1.63 Fri Mar 19 11:19:01 2010 +++ src/compiler/sparc/float.lisp Thu Nov 11 07:59:51 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/sparc/float.lisp,v 1.63 2010-03-19 15:19:01 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/compiler/sparc/float.lisp,v 1.64 2010-11-11 12:59:51 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2084,7 +2084,7 @@ (inst ,load zero zero-val (- (* ,slot vm:word-bytes) vm:other-pointer-type)) (inst ,fop rr xr y) - (inst ,fop rr xr zero))))))) + (inst ,fop ri xi zero))))))) (frob single fadds 1) (frob double faddd 2))

1 0

[cmucl-cvs] CMUCL commit: src (4 files)
by Raymond Toy 10 Nov '10

10 Nov '10

Date: Wednesday, November 10, 2010 @ 14:51:24 Author: rtoy Path: /project/cmucl/cvsroot/src Added: bootfiles/20b/boot-2010-11-1-cross.lisp Modified: code/exports.lisp compiler/backend.lisp compiler/dump.lisp Add new slots to the backend to hold the foreign linkage space start and entry size. Not yet used anywhere. This change needs a cross-compile; use boot-2010-11-1-cross.lisp as the cross-compile script. compiler/backend.lisp: o Add the two new slots to the backend. compiler/dump.lisp: o DUMP-DATA-MAYBE-BYTE-SWAPPING needs to handle (unicode) strings o DUMP-DATA-MAYBE-BYTE-SWAPPING should not swap bytes of a string. Genesis will make that happen. code/exports.lisp: o Export BACKEND-FOREIGN-LINKAGE-SPACE-START and BACKEND-FOREIGN-LINKAGE-ENTRY-SIZE. bootfiles/20b/boot-2010-11-1-cross.lisp: o Cross-compile script for this change. -----------------------------------------+ bootfiles/20b/boot-2010-11-1-cross.lisp | 10 ++++++++++ code/exports.lisp | 7 +++++-- compiler/backend.lisp | 11 +++++++++-- compiler/dump.lisp | 29 +++++++++++++++++++---------- 4 files changed, 43 insertions(+), 14 deletions(-) Index: src/bootfiles/20b/boot-2010-11-1-cross.lisp diff -u /dev/null src/bootfiles/20b/boot-2010-11-1-cross.lisp:1.1 --- /dev/null Wed Nov 10 14:51:24 2010 +++ src/bootfiles/20b/boot-2010-11-1-cross.lisp Wed Nov 10 14:51:23 2010 @@ -0,0 +1,10 @@ +;;; Adding slots to the backend requires a cross-compile. +;;; +;;; Answer CLOBBER-IT for the restart about changing the size of the +;;; backend structure. + +#+x86 +(load "target:tools/cross-scripts/cross-x86-x86") + +#+sparc +(load "target:tools/cross-scripts/cross-sparc-sparc") Index: src/code/exports.lisp diff -u src/code/exports.lisp:1.301 src/code/exports.lisp:1.302 --- src/code/exports.lisp:1.301 Fri Sep 17 19:29:00 2010 +++ src/code/exports.lisp Wed Nov 10 14:51:23 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.301 2010-09-17 23:29:00 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.302 2010-11-10 19:51:23 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1666,7 +1666,10 @@ "BACKEND-ASSEMBLER-RESOURCES" "BACKEND-BYTE-ORDER" "BACKEND-DISASSEM-PARAMS" "BACKEND-FASL-FILE-IMPLEMENTATION" "BACKEND-FASL-FILE-TYPE" "BACKEND-FASL-FILE-VERSION" - "BACKEND-FEATURES" "BACKEND-INFO-ENVIRONMENT" + "BACKEND-FEATURES" + "BACKEND-FOREIGN-LINKAGE-SPACE-START" + "BACKEND-FOREIGN-LINKAGE-ENTRY-SIZE" + "BACKEND-INFO-ENVIRONMENT" "BACKEND-INSTRUCTION-FLAVORS" "BACKEND-INSTRUCTION-FORMATS" "BACKEND-NAME" "BACKEND-REGISTER-SAVE-PENALTY" "BACKEND-SPECIAL-ARG-TYPES" "BACKEND-VERSION" "BIND" "BRANCH" Index: src/compiler/backend.lisp diff -u src/compiler/backend.lisp:1.35 src/compiler/backend.lisp:1.36 --- src/compiler/backend.lisp:1.35 Tue Apr 20 13:57:46 2010 +++ src/compiler/backend.lisp Wed Nov 10 14:51:24 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/backend.lisp,v 1.35 2010-04-20 17:57:46 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/compiler/backend.lisp,v 1.36 2010-11-10 19:51:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -26,6 +26,8 @@ backend-assembler-resources backend-special-arg-types backend-disassem-params backend-internal-errors backend-assembler-params backend-page-size + backend-foreign-linkage-space-start + backend-foreign-linkage-entry-size ;; The various backends need to call these support routines def-vm-support-routine make-stack-pointer-tn primitive-type @@ -226,7 +228,12 @@ (assembler-params nil :type t) ;; The maximum number of bytes per page on this system. Used by genesis. - (page-size 0 :type index)) + (page-size 0 :type index) + + ;; The foreign linkage space start and size + + (foreign-linkage-space-start 0 :type (unsigned-byte 32)) + (foreign-linkage-entry-size 0 :type index)) (defprinter backend Index: src/compiler/dump.lisp diff -u src/compiler/dump.lisp:1.88 src/compiler/dump.lisp:1.89 --- src/compiler/dump.lisp:1.88 Tue Oct 12 17:52:44 2010 +++ src/compiler/dump.lisp Wed Nov 10 14:51:24 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/compiler/dump.lisp,v 1.88 2010-10-12 21:52:44 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/dump.lisp,v 1.89 2010-11-10 19:51:24 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1634,15 +1634,24 @@ (declare (type (integer 1 #.most-positive-fixnum) bytes-per-element) (type unsigned-byte elements)) - (dotimes (index elements) - (let ((element (aref data-vector index)) - (new-element 0)) - (dotimes (i bytes-per-element) - (setf new-element - (logior (ash new-element vm:byte-bits) - (ldb (byte vm:byte-bits 0) element))) - (setf element (ash element (- vm:byte-bits)))) - (setf (aref result index) new-element))) + (if (stringp data-vector) + ;; Don't swap string bytes. We get here only if we're + ;; cross-compiling from one arch to a different endian + ;; arch. To be able to load the fasls, we need to keep + ;; strings in the native format. When genesis is done, + ;; genesis will swap string bytes when creating the + ;; core so that the bytes are in the correct order. + (dotimes (index elements) + (setf (aref result index) (char-code (aref data-vector index)))) + (dotimes (index elements) + (let ((element (aref data-vector index)) + (new-element 0)) + (dotimes (i bytes-per-element) + (setf new-element + (logior (ash new-element vm:byte-bits) + (ldb (byte vm:byte-bits 0) element))) + (setf element (ash element (- vm:byte-bits)))) + (setf (aref result index) new-element)))) (dump-bytes result bytes file))) (t (let* ((elements-per-byte (/ vm:byte-bits element-size))

1 0

[cmucl-cvs] CMUCL commit: src/bootfiles/20b [new]
by Raymond Toy 10 Nov '10

10 Nov '10

Date: Wednesday, November 10, 2010 @ 14:50:04 Author: rtoy Path: /project/cmucl/cvsroot/src/bootfiles/20b Directory /project/cmucl/cvsroot/src/bootfiles/20b added to the repository

1 0

[cmucl-cvs] CMUCL commit: src/tools (build.sh)
by Raymond Toy 10 Nov '10

10 Nov '10

Date: Wednesday, November 10, 2010 @ 14:17:55 Author: rtoy Path: /project/cmucl/cvsroot/src/tools Modified: build.sh Update bootfiles version from 20a to 20b. There won't be anymore bootfiles for 20a. ----------+ build.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/tools/build.sh diff -u src/tools/build.sh:1.37 src/tools/build.sh:1.38 --- src/tools/build.sh:1.37 Wed Nov 3 11:11:57 2010 +++ src/tools/build.sh Wed Nov 10 14:17:55 2010 @@ -32,14 +32,14 @@ # # For more information see src/BUILDING. # -# $Header: /project/cmucl/cvsroot/src/tools/build.sh,v 1.37 2010-11-03 15:11:57 rtoy Exp $ +# $Header: /project/cmucl/cvsroot/src/tools/build.sh,v 1.38 2010-11-10 19:17:55 rtoy Exp $ # ENABLE2="yes" ENABLE3="yes" ENABLE4="yes" -version=20a +version=20b SRCDIR=src TOOLDIR=$SRCDIR/tools VERSION="CVS Head `date '+%Y-%m-%d %H:%M:%S'`"

1 0

[cmucl-cvs] CMUCL commit: src/code (filesys.lisp)
by Raymond Toy 08 Nov '10

08 Nov '10

Date: Monday, November 8, 2010 @ 17:29:00 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: filesys.lisp Fix typo in ENUMERATE-MATCHES. It's verify-existence, not verify-existance. --------------+ filesys.lisp | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) Index: src/code/filesys.lisp diff -u src/code/filesys.lisp:1.112 src/code/filesys.lisp:1.113 --- src/code/filesys.lisp:1.112 Mon Jun 7 18:52:17 2010 +++ src/code/filesys.lisp Mon Nov 8 17:28:59 2010 @@ -6,7 +6,7 @@ ;;; Scott Fahlman or slisp-group(a)cs.cmu.edu. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/filesys.lisp,v 1.112 2010-06-07 22:52:17 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/filesys.lisp,v 1.113 2010-11-08 22:28:59 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -660,18 +660,18 @@ ;;;; Wildcard matching stuff. (defmacro enumerate-matches ((var pathname &optional result - &key (verify-existance t) (follow-links t)) + &key (verify-existence t) (follow-links t)) &body body) (let ((body-name (gensym))) `(block nil (flet ((,body-name (,var) ,@body)) (%enumerate-matches (pathname ,pathname) - ,verify-existance ,follow-links + ,verify-existence ,follow-links #',body-name) ,result)))) -(defun %enumerate-matches (pathname verify-existance follow-links function) +(defun %enumerate-matches (pathname verify-existence follow-links function) (when (pathname-type pathname) (unless (pathname-name pathname) (error (intl:gettext "Cannot supply a type without a name:~% ~S") pathname))) @@ -680,20 +680,20 @@ (ecase (car directory) (:absolute (%enumerate-directories "/" (cdr directory) pathname - verify-existance follow-links + verify-existence follow-links nil function)) (:relative (%enumerate-directories "" (cdr directory) pathname - verify-existance follow-links + verify-existence follow-links nil function))) - (%enumerate-files "" pathname verify-existance function)))) + (%enumerate-files "" pathname verify-existence function)))) ;;; %enumerate-directories -- Internal ;;; ;;; The directory node and device numbers are maintained for the current path ;;; during the search for the detection of path loops upon :wild-inferiors. ;;; -(defun %enumerate-directories (head tail pathname verify-existance +(defun %enumerate-directories (head tail pathname verify-existence follow-links nodes function) (declare (simple-string head)) (macrolet ((unix-xstat (name) @@ -727,11 +727,11 @@ (with-directory-node-noted (head) (%enumerate-directories (concatenate 'string head "/") (cdr tail) pathname - verify-existance follow-links + verify-existence follow-links nodes function)))) ((member :wild-inferiors) (%enumerate-directories head (rest tail) pathname - verify-existance follow-links + verify-existence follow-links nodes function) (do-directory-entries (name head) (let ((subdir (concatenate 'string head name))) @@ -746,7 +746,7 @@ (let ((nodes (cons (cons dev ino) nodes)) (subdir (concatenate 'string subdir "/"))) (%enumerate-directories subdir tail pathname - verify-existance follow-links + verify-existence follow-links nodes function)))))))) ((or pattern (member :wild)) (do-directory-entries (name head) @@ -760,24 +760,24 @@ (let ((nodes (cons (cons dev ino) nodes)) (subdir (concatenate 'string subdir "/"))) (%enumerate-directories subdir (rest tail) pathname - verify-existance follow-links + verify-existence follow-links nodes function)))))))) ((member :up) (let ((head (concatenate 'string head ".."))) (with-directory-node-noted (head) (%enumerate-directories (concatenate 'string head "/") (rest tail) pathname - verify-existance follow-links + verify-existence follow-links nodes function)))))) - (%enumerate-files head pathname verify-existance function)))) + (%enumerate-files head pathname verify-existence function)))) -(defun %enumerate-files (directory pathname verify-existance function) +(defun %enumerate-files (directory pathname verify-existence function) (declare (simple-string directory)) (let ((name (%pathname-name pathname)) (type (%pathname-type pathname)) (version (%pathname-version pathname))) (cond ((member name '(nil :unspecific)) - (when (or (not verify-existance) + (when (or (not verify-existence) (unix:unix-file-kind directory)) (funcall function directory))) ((or (pattern-p name) @@ -822,7 +822,7 @@ (setf file (concatenate 'string file ".~" (quick-integer-to-string version) "~"))) - (when (or (not verify-existance) + (when (or (not verify-existence) (unix:unix-file-kind file t)) (funcall function file))))))) @@ -868,7 +868,7 @@ (enumerate-search-list (pathname path) (collect ((names)) - (enumerate-matches (name pathname nil :verify-existance for-input + (enumerate-matches (name pathname nil :verify-existence for-input :follow-links t) (when (or (not executable-only) (and (eq (unix:unix-file-kind name) :file)

1 0

[cmucl-cvs] CMUCL commit: src/i18n/locale (3 files)
by Raymond Toy 08 Nov '10

08 Nov '10

Date: Monday, November 8, 2010 @ 09:02:41 Author: rtoy Path: /project/cmucl/cvsroot/src/i18n/locale Modified: cmucl.pot en(a)piglatin/LC_MESSAGES/cmucl.po ko/LC_MESSAGES/cmucl.po Regenerated from current sources. ----------------------------------+ cmucl.pot | 11 ++++------- en(a)piglatin/LC_MESSAGES/cmucl.po | 37 ++++++++++++++++++++++--------------- ko/LC_MESSAGES/cmucl.po | 23 ++++++++++++++--------- 3 files changed, 40 insertions(+), 31 deletions(-) Index: src/i18n/locale/cmucl.pot diff -u src/i18n/locale/cmucl.pot:1.16 src/i18n/locale/cmucl.pot:1.17 --- src/i18n/locale/cmucl.pot:1.16 Wed Oct 27 08:50:04 2010 +++ src/i18n/locale/cmucl.pot Mon Nov 8 09:02:40 2010 @@ -5554,10 +5554,6 @@ msgstr "" #: src/code/misc.lisp -msgid "" -msgstr "" - -#: src/code/misc.lisp msgid "Returns a string describing the implementation version." msgstr "" @@ -6574,12 +6570,13 @@ " read-eval-print loop. If the function returns the lisp will exit.\n" " \n" " :load-init-file\n" -" If true, then look for an init.lisp or init.fasl file when the core\n" -" file is resumed.\n" +" If true, then look for an init file when the core file is resumed.\n" +" Look for home:init first and then home:.cmucl-init. No error if\n" +" there is no init file.\n" "\n" " :site-init\n" " If true, then the name of the site init file to load. The default is\n" -" library:site-init. No error if this does not exist.\n" +" library:site-init. No error if this does not exist.\n" "\n" " :print-herald\n" " If true (the default), print out the lisp system herald when " Index: src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po diff -u src/i18n/locale/en@piglatin/LC_MESSAGES/cmucl.po:1.11 src/i18n/locale/en@piglatin/LC_MESSAGES/cmucl.po:1.12 --- src/i18n/locale/en@piglatin/LC_MESSAGES/cmucl.po:1.11 Sun Sep 26 20:15:51 2010 +++ src/i18n/locale/en(a)piglatin/LC_MESSAGES/cmucl.po Mon Nov 8 09:02:40 2010 @@ -7874,15 +7874,15 @@ msgstr "Eturnsray away ingstray escribingday ethay implementationway ypetay." #: src/code/misc.lisp +msgid " Unicode" +msgstr " Unicodeway" + +#: src/code/misc.lisp msgid "Returns a string describing the implementation version." msgstr "" "Eturnsray away ingstray escribingday ethay implementationway ersionvay." #: src/code/misc.lisp -msgid " Unicode" -msgstr " Unicodeway" - -#: src/code/misc.lisp msgid "Returns a string giving the name of the local machine." msgstr "" "Eturnsray away ingstray ivinggay ethay amenay ofway ethay ocallay achinemay." @@ -9418,12 +9418,13 @@ " read-eval-print loop. If the function returns the lisp will exit.\n" " \n" " :load-init-file\n" -" If true, then look for an init.lisp or init.fasl file when the core\n" -" file is resumed.\n" +" If true, then look for an init file when the core file is resumed.\n" +" Look for home:init first and then home:.cmucl-init. No error if\n" +" there is no init file.\n" "\n" " :site-init\n" " If true, then the name of the site init file to load. The default is\n" -" library:site-init. No error if this does not exist.\n" +" library:site-init. No error if this does not exist.\n" "\n" " :print-herald\n" " If true (the default), print out the lisp system herald when " @@ -9481,14 +9482,16 @@ "isplay illway exitway.\n" " \n" " :oadlay-initway-ilefay\n" -" Ifway uetray, enthay ooklay orfay anway initway.isplay orway initway." -"aslfay ilefay enwhay ethay orecay\n" -" ilefay isway esumedray.\n" +" Ifway uetray, enthay ooklay orfay anway initway ilefay enwhay ethay " +"orecay ilefay isway esumedray.\n" +" Ooklay orfay omehay:initway irstfay andway enthay omehay:.muclcay-" +"initway. Onay errorway ifway\n" +" erethay isway onay initway ilefay.\n" "\n" " :itesay-initway\n" " Ifway uetray, enthay ethay amenay ofway ethay itesay initway ilefay " "otay oadlay. Ethay efaultday isway\n" -" ibrarylay:itesay-initway. Onay errorway ifway isthay oesday otnay " +" ibrarylay:itesay-initway. Onay errorway ifway isthay oesday otnay " "existway.\n" "\n" " :intpray-eraldhay\n" @@ -13079,6 +13082,14 @@ msgstr "Invalidway ositionpay ivengay otay ilefay-ositionpay: ~S" #: src/code/fd-stream.lisp +msgid "Use Unicode replacement character instead" +msgstr "Useway Unicodeway eplacementray aracterchay insteadway" + +#: src/code/fd-stream.lisp +msgid "Use question mark character instead" +msgstr "Useway estionquay arkmay aracterchay insteadway" + +#: src/code/fd-stream.lisp msgid "" "Create a stream for the given unix file descriptor.\n" " If input is non-nil, allow input operations.\n" @@ -13130,10 +13141,6 @@ msgstr "** Osedclay ~Away~%" #: src/code/fd-stream.lisp -msgid "Use Unicode replacement character instead" -msgstr "Useway Unicodeway eplacementray aracterchay insteadway" - -#: src/code/fd-stream.lisp msgid "" "This is a string that OPEN tacks on the end of a file namestring to produce\n" " a name for the :if-exists :rename-and-delete and :rename options. Also,\n" Index: src/i18n/locale/ko/LC_MESSAGES/cmucl.po diff -u src/i18n/locale/ko/LC_MESSAGES/cmucl.po:1.13 src/i18n/locale/ko/LC_MESSAGES/cmucl.po:1.14 --- src/i18n/locale/ko/LC_MESSAGES/cmucl.po:1.13 Sun Sep 26 19:47:45 2010 +++ src/i18n/locale/ko/LC_MESSAGES/cmucl.po Mon Nov 8 09:02:41 2010 @@ -5546,11 +5546,11 @@ msgstr "" #: src/code/misc.lisp -msgid "Returns a string describing the implementation version." +msgid " Unicode" msgstr "" #: src/code/misc.lisp -msgid " Unicode" +msgid "Returns a string describing the implementation version." msgstr "" #: src/code/misc.lisp @@ -6588,12 +6588,13 @@ " read-eval-print loop. If the function returns the lisp will exit.\n" " \n" " :load-init-file\n" -" If true, then look for an init.lisp or init.fasl file when the core\n" -" file is resumed.\n" +" If true, then look for an init file when the core file is resumed.\n" +" Look for home:init first and then home:.cmucl-init. No error if\n" +" there is no init file.\n" "\n" " :site-init\n" " If true, then the name of the site init file to load. The default is\n" -" library:site-init. No error if this does not exist.\n" +" library:site-init. No error if this does not exist.\n" "\n" " :print-herald\n" " If true (the default), print out the lisp system herald when " @@ -9171,6 +9172,14 @@ msgstr "" #: src/code/fd-stream.lisp +msgid "Use Unicode replacement character instead" +msgstr "" + +#: src/code/fd-stream.lisp +msgid "Use question mark character instead" +msgstr "" + +#: src/code/fd-stream.lisp msgid "" "Create a stream for the given unix file descriptor.\n" " If input is non-nil, allow input operations.\n" @@ -9199,10 +9208,6 @@ msgstr "" #: src/code/fd-stream.lisp -msgid "Use Unicode replacement character instead" -msgstr "" - -#: src/code/fd-stream.lisp msgid "" "This is a string that OPEN tacks on the end of a file namestring to produce\n" " a name for the :if-exists :rename-and-delete and :rename options. Also,\n"

1 0

[cmucl-cvs] CMUCL commit: src/code (misc.lisp)
by Raymond Toy 08 Nov '10

08 Nov '10

Date: Monday, November 8, 2010 @ 08:45:27 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: misc.lisp Oops. Don't need to translate "" (in lisp-implementation-version). -----------+ misc.lisp | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/code/misc.lisp diff -u src/code/misc.lisp:1.42 src/code/misc.lisp:1.43 --- src/code/misc.lisp:1.42 Wed Oct 13 14:00:44 2010 +++ src/code/misc.lisp Mon Nov 8 08:45:27 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/misc.lisp,v 1.42 2010-10-13 18:00:44 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/code/misc.lisp,v 1.43 2010-11-08 13:45:27 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -182,7 +182,7 @@ (defun lisp-implementation-version () "Returns a string describing the implementation version." (format nil "~A (~X~A)" *lisp-implementation-version* c:byte-fasl-file-version - #+unicode _" Unicode" #-unicode _"")) + #+unicode _" Unicode" #-unicode "")) (defun machine-instance () "Returns a string giving the name of the local machine."

1 0

[cmucl-cvs] CMUCL commit: src/code (save.lisp)
by Raymond Toy 04 Nov '10

04 Nov '10

Date: Thursday, November 4, 2010 @ 10:05:02 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: save.lisp Correct the docstring for SAVE for the :LOAD-INIT-FILE argument. -----------+ save.lisp | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) Index: src/code/save.lisp diff -u src/code/save.lisp:1.72 src/code/save.lisp:1.73 --- src/code/save.lisp:1.72 Wed Oct 13 14:00:44 2010 +++ src/code/save.lisp Thu Nov 4 10:05:01 2010 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /project/cmucl/cvsroot/src/code/save.lisp,v 1.72 2010-10-13 18:00:44 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/code/save.lisp,v 1.73 2010-11-04 14:05:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -177,12 +177,13 @@ read-eval-print loop. If the function returns the lisp will exit. :load-init-file - If true, then look for an init.lisp or init.fasl file when the core - file is resumed. + If true, then look for an init file when the core file is resumed. + Look for home:init first and then home:.cmucl-init. No error if + there is no init file. :site-init If true, then the name of the site init file to load. The default is - library:site-init. No error if this does not exist. + library:site-init. No error if this does not exist. :print-herald If true (the default), print out the lisp system herald when starting.

1 0

[cmucl-cvs] CMUCL commit: src/contrib/asdf (asdf.lisp)
by Raymond Toy 04 Nov '10

04 Nov '10

Date: Thursday, November 4, 2010 @ 10:04:11 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf Modified: asdf.lisp Update to 2.010. -----------+ asdf.lisp | 232 +++++++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 152 insertions(+), 80 deletions(-) Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.9 src/contrib/asdf/asdf.lisp:1.10 --- src/contrib/asdf/asdf.lisp:1.9 Wed Oct 6 19:26:55 2010 +++ src/contrib/asdf/asdf.lisp Thu Nov 4 10:04:10 2010 @@ -71,14 +71,13 @@ (eval-when (:load-toplevel :compile-toplevel :execute) (defvar *asdf-version* nil) (defvar *upgraded-p* nil) - (let* ((asdf-version ;; the 1+ helps the version bumping script discriminate - (subseq "VERSION:2.009" (1+ (length "VERSION")))) ; same as 2.134 + (let* ((asdf-version "2.010") ;; same as 2.146 (existing-asdf (fboundp 'find-system)) (existing-version *asdf-version*) (already-there (equal asdf-version existing-version))) (unless (and existing-asdf already-there) (when existing-asdf - (format *trace-output* + (format *error-output* "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" existing-version asdf-version)) (labels @@ -170,9 +169,9 @@ :shadow ',shadow :unintern ',(append #-(or gcl ecl) redefined-functions unintern) :fmakunbound ',(append fmakunbound)))) - (unlink-package :asdf-utilities) (pkgdcl :asdf + :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only. :use (:common-lisp) :redefined-functions (#:perform #:explain #:output-files #:operation-done-p @@ -305,6 +304,7 @@ #:split-string #:component-name-to-pathname-components #:split-name-type + #:subdirectories #:truenamize #:while-collecting))) (setf *asdf-version* asdf-version @@ -533,7 +533,18 @@ (let* ((specified (pathname specified)) (defaults (pathname defaults)) (directory (pathname-directory specified)) - #-(or sbcl cmu) (directory (if (stringp directory) `(:absolute ,directory) directory)) + (directory + (cond + #-(or sbcl cmu) + ((stringp directory) `(:absolute ,directory) directory) + #+gcl + ((and (consp directory) (stringp (first directory))) + `(:absolute ,@directory)) + ((or (null directory) + (and (consp directory) (member (first directory) '(:absolute :relative)))) + directory) + (t + (error "Unrecognized directory component ~S in pathname ~S" directory specified)))) (name (or (pathname-name specified) (pathname-name defaults))) (type (or (pathname-type specified) (pathname-type defaults))) (version (or (pathname-version specified) (pathname-version defaults)))) @@ -542,7 +553,7 @@ (unspecific-handler (p) (if (typep p 'logical-pathname) #'ununspecific #'identity))) (multiple-value-bind (host device directory unspecific-handler) - (#-gcl ecase #+gcl case (first directory) + (ecase (first directory) ((nil) (values (pathname-host defaults) (pathname-device defaults) @@ -559,13 +570,6 @@ (if (pathname-directory defaults) (append (pathname-directory defaults) (cdr directory)) directory) - (unspecific-handler defaults))) - #+gcl - (t - (assert (stringp (first directory))) - (values (pathname-host defaults) - (pathname-device defaults) - (append (pathname-directory defaults) directory) (unspecific-handler defaults)))) (make-pathname :host host :device device :directory directory :name (funcall unspecific-handler name) @@ -620,7 +624,7 @@ (values filename unspecific) (values name type))))) -(defun* component-name-to-pathname-components (s &optional force-directory) +(defun* component-name-to-pathname-components (s &key force-directory force-relative) "Splits the path string S, returning three values: A flag that is either :absolute or :relative, indicating how the rest of the values are to be interpreted. @@ -637,12 +641,17 @@ e.g., $:file \"foo/bar\"$, which will be unpacked to relative pathnames." (check-type s string) + (when (find #\: s) + (error "a portable ASDF pathname designator cannot include a #\: character: ~S" s)) (let* ((components (split-string s :separator "/")) (last-comp (car (last components)))) (multiple-value-bind (relative components) (if (equal (first components) "") (if (equal (first-char s) #\/) - (values :absolute (cdr components)) + (progn + (when force-relative + (error "absolute pathname designator not allowed: ~S" s)) + (values :absolute (cdr components))) (values :relative nil)) (values :relative components)) (setf components (remove "" components :test #'equal)) @@ -686,11 +695,14 @@ Note that this does _not_ check to see that PATHNAME points to an actually-existing directory." - (flet ((check-one (x) - (member x '(nil :unspecific "") :test 'equal))) - (and (check-one (pathname-name pathname)) - (check-one (pathname-type pathname)) - t))) + (when pathname + (let ((pathname (pathname pathname))) + (flet ((check-one (x) + (member x '(nil :unspecific "") :test 'equal))) + (and (not (wild-pathname-p pathname)) + (check-one (pathname-name pathname)) + (check-one (pathname-type pathname)) + t))))) (defun* ensure-directory-pathname (pathspec) "Converts the non-wild pathname designator PATHSPEC to directory form." @@ -700,7 +712,7 @@ ((not (pathnamep pathspec)) (error "Invalid pathname designator ~S" pathspec)) ((wild-pathname-p pathspec) - (error "Can't reliably convert wild pathnames.")) + (error "Can't reliably convert wild pathname ~S" pathspec)) ((directory-pathname-p pathspec) pathspec) (t @@ -773,7 +785,7 @@ (string (probe-file* (parse-namestring p))) (pathname (unless (wild-pathname-p p) #.(or #+(or allegro clozure cmu ecl sbcl scl) '(probe-file p) - #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(,it p)) + #+clisp (aif (find-symbol (string :probe-pathname) :ext) `(ignore-errors (,it p))) '(ignore-errors (truename p))))))) (defun* truenamize (p) @@ -839,7 +851,7 @@ (eql x separator))) root-namestring))) (multiple-value-bind (relative path filename) - (component-name-to-pathname-components root-string t) + (component-name-to-pathname-components root-string :force-directory t) (declare (ignore relative filename)) (let ((new-base (make-pathname :defaults root @@ -921,13 +933,29 @@ ((name :accessor component-name :initarg :name :documentation "Component name: designator for a string composed of portable pathname characters") (version :accessor component-version :initarg :version) - (in-order-to :initform nil :initarg :in-order-to - :accessor component-in-order-to) ;; This one is used by POIU. Maybe in the future by ASDF instead of in-order-to? ;; POIU is a parallel (multi-process build) extension of ASDF. See ;; http://www.cliki.net/poiu (load-dependencies :accessor component-load-dependencies :initform nil) - ;; XXX crap name, but it's an official API name! + ;; In the ASDF object model, dependencies exist between *actions* + ;; (an action is a pair of operation and component). They are represented + ;; alists of operations to dependencies (other actions) in each component. + ;; There are two kinds of dependencies, each stored in its own slot: + ;; in-order-to and do-first dependencies. These two kinds are related to + ;; the fact that some actions modify the filesystem, + ;; whereas other actions modify the current image, and + ;; this implies a difference in how to interpret timestamps. + ;; in-order-to dependencies will trigger re-performing the action + ;; when the timestamp of some dependency + ;; makes the timestamp of current action out-of-date; + ;; do-first dependencies do not trigger such re-performing. + ;; Therefore, a FASL must be recompiled if it is obsoleted + ;; by any of its FASL dependencies (in-order-to); but + ;; it needn't be recompiled just because one of these dependencies + ;; hasn't yet been loaded in the current image (do-first). + ;; The names are crap, but they have been the official API since Dan Barlow's ASDF 1.52! + (in-order-to :initform nil :initarg :in-order-to + :accessor component-in-order-to) (do-first :initform nil :initarg :do-first :accessor component-do-first) ;; methods defined using the "inline" style inside a defsystem form: @@ -1060,7 +1088,8 @@ (licence :accessor system-licence :initarg :licence :accessor system-license :initarg :license) (source-file :reader system-source-file :initarg :source-file - :writer %set-system-source-file))) + :writer %set-system-source-file) + (defsystem-depends-on :reader system-defsystem-depends-on :initarg :defsystem-depends-on))) ;;;; ------------------------------------------------------------------------- ;;;; version-satisfies @@ -1284,22 +1313,21 @@ (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) -(defun* find-system-fallback (requested fallback &optional source-file) +(defun* find-system-fallback (requested fallback &rest keys &key source-file &allow-other-keys) (setf fallback (coerce-name fallback) source-file (or source-file *compile-file-truename* *load-truename*) requested (coerce-name requested)) (when (equal requested fallback) (let* ((registered (cdr (gethash fallback *defined-systems*))) (system (or registered - (make-instance - 'system :name fallback - :source-file source-file)))) + (apply 'make-instance 'system + :name fallback :source-file source-file keys)))) (unless registered (register-system fallback system)) (throw 'find-system system)))) (defun* sysdef-find-asdf (name) - (find-system-fallback name "asdf")) + (find-system-fallback name "asdf")) ;; :version *asdf-version* wouldn't be updated when ASDF is updated. ;;;; ------------------------------------------------------------------------- @@ -1370,7 +1398,8 @@ (merge-component-name-type (string-downcase name) :type type :defaults defaults)) (string (multiple-value-bind (relative path filename) - (component-name-to-pathname-components name (eq type :directory)) + (component-name-to-pathname-components name :force-directory (eq type :directory) + :force-relative t) (multiple-value-bind (name type) (cond ((or (eq type :directory) (null filename)) @@ -1600,8 +1629,8 @@ (do-traverse op dep-c collect))) (defun* do-one-dep (operation c collect required-op required-c required-v) - ;; this function is a thin, error-handling wrapper around - ;; %do-one-dep. Returns a partial plan per that function. + ;; this function is a thin, error-handling wrapper around %do-one-dep. + ;; Collects a partial plan per that function. (loop (restart-case (return (%do-one-dep operation c collect @@ -1612,13 +1641,6 @@ (component-find-path required-c))) :test (lambda (c) - #| - (print (list :c1 c (typep c 'missing-dependency))) - (when (typep c 'missing-dependency) - (print (list :c2 (missing-requires c) required-c - (equalp (missing-requires c) - required-c)))) - |# (or (null c) (and (typep c 'missing-dependency) (equalp (missing-requires c) @@ -1832,7 +1854,8 @@ (setf (gethash (type-of operation) (component-operation-times c)) (get-universal-time))) -(declaim (ftype (function ((or pathname string) &rest t &key &allow-other-keys) +(declaim (ftype (function ((or pathname string) + &rest t &key (:output-file t) &allow-other-keys) (values t t t)) compile-file*)) @@ -2152,7 +2175,7 @@ (destructuring-bind (&key (pathname nil pathname-arg-p) (class 'system) defsystem-depends-on &allow-other-keys) options - (let ((component-options (remove-keys '(:defsystem-depends-on :class) options))) + (let ((component-options (remove-keys '(:class) options))) `(progn ;; system must be registered before we parse the body, otherwise ;; we recur when trying to find an existing system of the same name @@ -2457,23 +2480,33 @@ ;;; Initially stolen from SLIME's SWANK, hacked since. (defparameter *implementation-features* - '(:allegro :lispworks :sbcl :clozure :digitool :cmu :clisp - :corman :cormanlisp :armedbear :gcl :ecl :scl)) + '((:acl :allegro) + (:lw :lispworks) + (:digitool) ; before clozure, so it won't get preempted by ccl + (:ccl :clozure) + (:corman :cormanlisp) + (:abcl :armedbear) + :sbcl :cmu :clisp :gcl :ecl :scl)) (defparameter *os-features* - '((:windows :mswindows :win32 :mingw32) + '((:win :windows :mswindows :win32 :mingw32) ;; shorten things on windows (:solaris :sunos) - :linux ;; for GCL at least, must appear before :bsd. - :macosx :darwin :apple + (:linux :linux-target) ;; for GCL at least, must appear before :bsd. + (:macosx :darwin :darwin-target :apple) :freebsd :netbsd :openbsd :bsd :unix)) (defparameter *architecture-features* - '((:x86-64 :amd64 :x86_64 :x8664-target) - (:x86 :i686 :i586 :pentium3 :i486 :i386 :pc386 :iapx386 :x8632-target :pentium4) - :hppa64 :hppa :ppc64 (:ppc32 :ppc :powerpc) :sparc64 :sparc - :java-1.4 :java-1.5 :java-1.6 :java-1.7)) - + '((:amd64 :x86-64 :x86_64 :x8664-target) + (: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))) (defun* lisp-version-string () (let ((s (lisp-implementation-version))) @@ -2492,7 +2525,7 @@ (if (member :64bit *features*) "-64bit" "")) #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) #+clisp (subseq s 0 (position #\space s)) - #+clozure (format nil "~d.~d-fasl~d" + #+clozure (format nil "~d.~d-f~d" ; shorten for windows ccl::*openmcl-major-version* ccl::*openmcl-minor-version* (logand ccl::fasl-version #xFF)) @@ -2689,10 +2722,6 @@ (setf *output-translations* '()) (values)) -(defparameter *wild-asd* - (make-pathname :directory '(:relative :wild-inferiors) - :name :wild :type "asd" :version :newest)) - (declaim (ftype (function (t &key (:directory boolean) (:wilden boolean)) (values (or null pathname) &optional)) resolve-location)) @@ -2872,7 +2901,7 @@ ;; These are for convenience, and can be overridden by the user: #+abcl (#p"/___jar___file___root___/**/*.*" (:user-cache #p"**/*.*")) #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname)) - ;; If we want to enable the user cache by default, here would be the place: + ;; We enable the user cache by default, and here is the place we do: :enable-user-cache)) (defparameter *output-translations-file* #p"asdf-output-translations.conf") @@ -3051,8 +3080,8 @@ (when (and x (probe-file x)) (delete-file x))) -(defun* compile-file* (input-file &rest keys &key &allow-other-keys) - (let* ((output-file (apply 'compile-file-pathname* input-file keys)) +(defun* compile-file* (input-file &rest keys &key output-file &allow-other-keys) + (let* ((output-file (or output-file (apply 'compile-file-pathname* input-file keys))) (tmp-file (tmpize-pathname output-file)) (status :error)) (multiple-value-bind (output-truename warnings-p failure-p) @@ -3102,7 +3131,8 @@ (include-per-user-information nil) (map-all-source-files (or #+(or ecl clisp) t nil)) (source-to-target-mappings nil)) - (when (and (null map-all-source-files) #-(or ecl clisp) nil) + #+(or ecl clisp) + (when (null map-all-source-files) (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) (wild-inferiors (make-pathname :directory '(:relative :wild-inferiors))) @@ -3206,7 +3236,8 @@ ;; Using ack 1.2 exclusions (defvar *default-source-registry-exclusions* - '(".bzr" ".cdv" "~.dep" "~.dot" "~.nib" "~.plst" + '(".bzr" ".cdv" + ;; "~.dep" "~.dot" "~.nib" "~.plst" ; we don't support ack wildcards ".git" ".hg" ".pc" ".svn" "CVS" "RCS" "SCCS" "_darcs" "_sgbak" "autom4te.cache" "cover_db" "_build" "debian")) ;; debian often build stuff under the debian directory... BAD. @@ -3234,6 +3265,61 @@ (setf *source-registry* '()) (values)) +(defparameter *wild-asd* + (make-pathname :directory nil :name :wild :type "asd" :version :newest)) + +(defun directory-has-asd-files-p (directory) + (and (ignore-errors + (directory (merge-pathnames* *wild-asd* directory) + #+sbcl #+sbcl :resolve-symlinks nil + #+ccl #+ccl :follow-links nil + #+clisp #+clisp :circle t)) + t)) + +(defun subdirectories (directory) + (let* ((directory (ensure-directory-pathname directory)) + #-cormanlisp + (wild (merge-pathnames* + #-(or abcl allegro lispworks scl) + (make-pathname :directory '(:relative :wild) :name nil :type nil :version nil) + #+(or abcl allegro lispworks scl) "*.*" + directory)) + (dirs + #-cormanlisp + (ignore-errors + (directory wild . + #.(or #+allegro '(:directories-are-files nil :follow-symbolic-links nil) + #+ccl '(:follow-links nil :directories t :files nil) + #+clisp '(:circle t :if-does-not-exist :ignore) + #+(or cmu scl) '(:follow-links nil :truenamep nil) + #+digitool '(:directories t) + #+sbcl '(:resolve-symlinks nil)))) + #+cormanlisp (cl::directory-subdirs directory)) + #+(or abcl allegro lispworks scl) + (dirs (remove-if-not #+abcl #'extensions:probe-directory + #+allegro #'excl:probe-directory + #+lispworks #'lw:file-directory-p + #-(or abcl allegro lispworks) #'directory-pathname-p + dirs))) + dirs)) + +(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-with-asd + (directory &key + (exclude *default-source-registry-exclusions*) + collect) + (collect-sub*directories + directory + #'directory-has-asd-files-p + #'(lambda (x) (not (member (car (last (pathname-directory x))) exclude :test #'equal))) + collect)) + (defun* validate-source-registry-directive (directive) (unless (or (member directive '(:default-registry (:default-registry)) :test 'equal) @@ -3297,22 +3383,8 @@ (defun* register-asd-directory (directory &key recurse exclude collect) (if (not recurse) (funcall collect directory) - (let* ((files - (handler-case - (directory (merge-pathnames* *wild-asd* directory) - #+sbcl #+sbcl :resolve-symlinks nil - #+clisp #+clisp :circle t) - (error (c) - (warn "Error while scanning system definitions under directory ~S:~%~A" - directory c) - nil))) - (dirs (remove-duplicates (mapcar #'pathname-directory-pathname files) - :test #'equal :from-end t))) - (loop - :for dir :in dirs - :unless (loop :for x :in exclude - :thereis (find x (pathname-directory dir) :test #'equal)) - :do (funcall collect dir))))) + (collect-sub*directories-with-asd + directory :exclude exclude :collect collect))) (defparameter *default-source-registries* '(environment-source-registry

1 0