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

[cmucl-cvs] CMUCL commit: src (2 files)
by Raymond Toy 14 Dec '10

14 Dec '10

Date: Monday, December 13, 2010 @ 19:26:43 Author: rtoy Path: /project/cmucl/cvsroot/src Added: bootfiles/20b/boot-2010-12.lisp Modified: compiler/generic/new-genesis.lisp compiler/generic/new-genesis.lisp: o More cleanups. Basically back to rev 1.93 with a couple more cleanups, but this works on sparc. bootfiles/20b/boot-2010-12.lisp: o Use this to bootstrap the necessary values in the compiler backend for the foreign-linkage-space. -----------------------------------+ bootfiles/20b/boot-2010-12.lisp | 23 +++++++++++ compiler/generic/new-genesis.lisp | 71 ++++++------------------------------ 2 files changed, 36 insertions(+), 58 deletions(-) Index: src/bootfiles/20b/boot-2010-12.lisp diff -u /dev/null src/bootfiles/20b/boot-2010-12.lisp:1.1 --- /dev/null Mon Dec 13 19:26:43 2010 +++ src/bootfiles/20b/boot-2010-12.lisp Mon Dec 13 19:26:42 2010 @@ -0,0 +1,23 @@ +;; Setup backend-foreign-linkage-space-start/entry-size for each +;; architecture. + +#+x86 +(setf (c::backend-foreign-linkage-space-start c:*target-backend*) + #+linux #x58000000 + #-linux #xB0000000 + (c::backend-foreign-linkage-entry-size c:*target-backend*) + 8) + +#+sparc +(setf (c::backend-foreign-linkage-space-start c:*target-backend*) + ;; This better match the value in sparc-validate.h! + #x0f800000 + (c::backend-foreign-linkage-entry-size c:*target-backend*) + ;; This better agree with what sparc-arch.c thinks it is! Right now, + ;; it's 4 instructions, so 16 bytes. + 16) +#+ppc +(setf (c::backend-foreign-linkage-space-start c:*target-backend*) + #x17000000 + (c::backend-foreign-linkage-entry-size c:*target-backend*) + 32) \ No newline at end of file Index: src/compiler/generic/new-genesis.lisp diff -u src/compiler/generic/new-genesis.lisp:1.94 src/compiler/generic/new-genesis.lisp:1.95 --- src/compiler/generic/new-genesis.lisp:1.94 Sat Dec 11 10:07:08 2010 +++ src/compiler/generic/new-genesis.lisp Mon Dec 13 19:26:43 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.94 2010-12-11 15:07:08 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.95 2010-12-14 00:26:43 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -1321,42 +1321,24 @@ ;; Destructively byte swap a string, if the backend and the native ;; backend have different endianness. (declaim (inline maybe-byte-swap-string)) -#+unicode (defun maybe-byte-swap-string (s &optional (len (length s))) + #-unicode + (declare (ignore len)) + #+unicode (unless (eq (c:backend-byte-order c:*backend*) (c:backend-byte-order c:*native-backend*)) (dotimes (k len) (let ((code (char-code (aref s k)))) (setf (aref s k) (code-char (swap-16 code)))))) s) -#-unicode -(defun maybe-byte-swap-string (s &optional len) - (declare (ignore s len)) - s) ;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns ;;; that symbol in the given Package. ;;; -#-unicode -(defun cold-load-symbol (size package) - (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 size) - (cold-intern (intern string package) package))) - -#+unicode -(defmacro load-char-code () - (ecase (c::backend-byte-order c::*native-backend*) - (:little-endian - `(code-char (+ (read-arg 1) - (ash (read-arg 1) 8)))) - (:big-endian - `(code-char (+ (ash (read-arg 1) 8) - (read-arg 1)))))) -#+unicode (defun cold-load-symbol (size package) (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 (* 2 size)) + (read-n-bytes *fasl-file* string 0 (* vm:char-bytes size)) (maybe-byte-swap-string string) (cold-intern (intern string package) package))) @@ -1383,21 +1365,11 @@ (fop-keyword-small-symbol-save) (push-table (cold-load-symbol (clone-arg) *keyword-package*))) -#-unicode (clone-cold-fop (fop-uninterned-symbol-save) (fop-uninterned-small-symbol-save) (let* ((size (clone-arg)) (name (make-string size))) - (read-n-bytes *fasl-file* name 0 size) - (let ((symbol (allocate-symbol name))) - (push-table symbol)))) - -#+unicode -(clone-cold-fop (fop-uninterned-symbol-save) - (fop-uninterned-small-symbol-save) - (let* ((size (clone-arg)) - (name (make-string size))) - (read-n-bytes *fasl-file* name 0 (* 2 size)) + (read-n-bytes *fasl-file* name 0 (* vm:char-bytes size)) (maybe-byte-swap-string name) (let ((symbol (allocate-symbol name))) (push-table symbol)))) @@ -1452,20 +1424,11 @@ ;;; Loading vectors... -#-unicode (clone-cold-fop (fop-string) (fop-small-string) (let* ((len (clone-arg)) (string (make-string len))) - (read-n-bytes *fasl-file* string 0 len) - (string-to-core string))) - -#+unicode -(clone-cold-fop (fop-string) - (fop-small-string) - (let* ((len (clone-arg)) - (string (make-string len))) - (read-n-bytes *fasl-file* string 0 (* 2 len)) + (read-n-bytes *fasl-file* string 0 (* vm:char-bytes len)) (maybe-byte-swap-string string) (string-to-core string))) @@ -1989,12 +1952,8 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - #-unicode - (read-n-bytes *fasl-file* sym 0 len) - #+unicode - (progn - (read-n-bytes *fasl-file* sym 0 (* 2 len)) - (maybe-byte-swap-string sym)) + (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) + (maybe-byte-swap-string sym) (let ((offset (read-arg 4)) (value #+linkage-table (cold-register-foreign-linkage sym :code) @@ -2010,12 +1969,8 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - #-unicode - (read-n-bytes *fasl-file* sym 0 len) - #+unicode - (progn - (read-n-bytes *fasl-file* sym 0 (* 2 len)) - (maybe-byte-swap-string sym)) + (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) + (maybe-byte-swap-string sym) (let ((offset (read-arg 4)) (value (cold-register-foreign-linkage sym :data))) (do-cold-fixup code-object offset value kind)) @@ -2218,8 +2173,8 @@ 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 ()

1 0

[cmucl-cvs] CMUCL commit: src/code (intl.lisp)
by Raymond Toy 13 Dec '10

13 Dec '10

Date: Sunday, December 12, 2010 @ 19:19:38 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: intl.lisp Revert previous change. Instead of caching probe-file, have LOAD-DOMAIN return an appropriate entry instead of returning NIL. This still gets rid of all the stats. Solution from Paul Foley. -----------+ intl.lisp | 77 ++++++++++++++++++++++++------------------------------------ 1 file changed, 31 insertions(+), 46 deletions(-) Index: src/code/intl.lisp diff -u src/code/intl.lisp:1.9 src/code/intl.lisp:1.10 --- src/code/intl.lisp:1.9 Sat Dec 11 17:39:46 2010 +++ src/code/intl.lisp Sun Dec 12 19:19:38 2010 @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*- -;;; $Revision: 1.9 $ +;;; $Revision: 1.10 $ ;;; Copyright 1999-2010 Paul Foley (mycroft(a)actrix.gen.nz) ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining @@ -23,7 +23,7 @@ ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.9 2010-12-11 22:39:46 rtoy Exp $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.10 2010-12-13 00:19:38 rtoy Exp $") (in-package "INTL") @@ -79,49 +79,29 @@ (ash (the (unsigned-byte 8) (read-byte stream)) 8) (the (unsigned-byte 8) (read-byte stream)))) -;; If the domain file doesn't exist because the locale isn't -;; supported, we end up doing a huge number of stats looking for a -;; non-existent file everytime a translation is needed. This is -;; really expensive. So create a cache to hold the results. -(let ((domain-file-cache (make-hash-table :test 'equal))) - (defun get-domain-file-cache () - ;; Mostly for debugging to let the user get at the cache. - domain-file-cache) - (defun clear-domain-file-cache () - ;; Mostly for debugging. But also useful if we now have installed - ;; some new translations. - (clrhash domain-file-cache)) - (defun locate-domain-file (domain locale locale-dir) - ;; The default locale-dir includes search lists. If we get called - ;; before the search lists are initialized, we lose. The search - ;; lists are initialized in environment-init, which sets - ;; *environment-list-initialized*. This way, we return NIL to - ;; indicate there's no domain file to use. - (when lisp::*environment-list-initialized* - (flet ((path (locale base) - (merge-pathnames (make-pathname :directory (list :relative locale - "LC_MESSAGES") - :name domain :type "mo") - base)) - (memoized-probe-file (p) - ;; Cache the results of probe-file and return the - ;; cached value when possible. - (multiple-value-bind (value foundp) - (gethash p domain-file-cache) - (if foundp - value - (setf (gethash p domain-file-cache) (probe-file p)))))) - (let ((locale (or (gethash locale *locale-aliases*) locale))) - (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) - (let ((probe - (or (memoized-probe-file (path locale base)) - (let ((dot (position #\. locale))) - (and dot (memoized-probe-file (path (subseq locale 0 dot) base)))) - (let ((at (position #\@ locale))) - (and at (memoized-probe-file (path (subseq locale 0 at) base)))) - (let ((us (position #\_ locale))) - (and us (memoized-probe-file (path (subseq locale 0 us) base))))))) - (when probe (return probe))))))))) +(defun locate-domain-file (domain locale locale-dir) + ;; The default locale-dir includes search lists. If we get called + ;; before the search lists are initialized, we lose. The search + ;; lists are initialized in environment-init, which sets + ;; *environment-list-initialized*. This way, we return NIL to + ;; indicate there's no domain file to use. + (when lisp::*environment-list-initialized* + (flet ((path (locale base) + (merge-pathnames (make-pathname :directory (list :relative locale + "LC_MESSAGES") + :name domain :type "mo") + base))) + (let ((locale (or (gethash locale *locale-aliases*) locale))) + (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) + (let ((probe + (or (probe-file (path locale base)) + (let ((dot (position #\. locale))) + (and dot (probe-file (path (subseq locale 0 dot) base)))) + (let ((at (position #\@ locale))) + (and at (probe-file (path (subseq locale 0 at) base)))) + (let ((us (position #\_ locale))) + (and us (probe-file (path (subseq locale 0 us) base))))))) + (when probe (return probe)))))))) (defun find-encoding (domain) (when (null (domain-entry-encoding domain)) @@ -341,7 +321,12 @@ (defun load-domain (domain locale &optional (locale-dir *locale-directories*)) (let ((file (locate-domain-file domain locale locale-dir)) (read #'read-lelong)) - (unless file (return-from load-domain nil)) + (unless file + (let ((entry (make-domain-entry :domain domain :locale locale + :hash (make-hash-table :size 0 + :test 'equal)))) + (setf (gethash domain *loaded-domains*) entry) + (return-from load-domain entry))) (with-open-file (stream file :direction :input :if-does-not-exist nil :element-type '(unsigned-byte 8)) (unless stream (return-from load-domain nil))

1 0

[cmucl-cvs] CMUCL commit: src/code (intl.lisp)
by Raymond Toy 11 Dec '10

11 Dec '10

Date: Saturday, December 11, 2010 @ 17:39:46 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: intl.lisp Speed up building on sparc. Time taken is now almost half! This was caused by all the calls to stat in PROBE-FILE in LOCATE-DOMAIN-FILE for files that did not exist. The default locale was C, so every message lookup was causing many stat's to non-exist files. (There were over 1000 calls/sec on a 750 MHz sparc!) So we cache all the calls to PROBE-FILE in LOCATE-DOMAIN-FILE. But just in case, we also allow the user to get at the hash table to examine it (GET-DOMAIN-FILE-CACHE) and also allow the user to clear it (CLEAR-DOMAIN-FILE-CACHE) in case new translations are added without restarting lisp. -----------+ intl.lisp | 70 ++++++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 45 insertions(+), 25 deletions(-) Index: src/code/intl.lisp diff -u src/code/intl.lisp:1.8 src/code/intl.lisp:1.9 --- src/code/intl.lisp:1.8 Tue Jul 13 23:13:20 2010 +++ src/code/intl.lisp Sat Dec 11 17:39:46 2010 @@ -1,6 +1,6 @@ ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Package: INTL -*- -;;; $Revision: 1.8 $ +;;; $Revision: 1.9 $ ;;; Copyright 1999-2010 Paul Foley (mycroft(a)actrix.gen.nz) ;;; ;;; Permission is hereby granted, free of charge, to any person obtaining @@ -23,7 +23,7 @@ ;;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE ;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH ;;; DAMAGE. -(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.8 2010-07-14 03:13:20 rtoy Rel $") +(ext:file-comment "$Header: /project/cmucl/cvsroot/src/code/intl.lisp,v 1.9 2010-12-11 22:39:46 rtoy Exp $") (in-package "INTL") @@ -79,29 +79,49 @@ (ash (the (unsigned-byte 8) (read-byte stream)) 8) (the (unsigned-byte 8) (read-byte stream)))) -(defun locate-domain-file (domain locale locale-dir) - ;; The default locale-dir includes search lists. If we get called - ;; before the search lists are initialized, we lose. The search - ;; lists are initialized in environment-init, which sets - ;; *environment-list-initialized*. This way, we return NIL to - ;; indicate there's no domain file to use. - (when lisp::*environment-list-initialized* - (flet ((path (locale base) - (merge-pathnames (make-pathname :directory (list :relative locale - "LC_MESSAGES") - :name domain :type "mo") - base))) - (let ((locale (or (gethash locale *locale-aliases*) locale))) - (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) - (let ((probe - (or (probe-file (path locale base)) - (let ((dot (position #\. locale))) - (and dot (probe-file (path (subseq locale 0 dot) base)))) - (let ((at (position #\@ locale))) - (and at (probe-file (path (subseq locale 0 at) base)))) - (let ((us (position #\_ locale))) - (and us (probe-file (path (subseq locale 0 us) base))))))) - (when probe (return probe)))))))) +;; If the domain file doesn't exist because the locale isn't +;; supported, we end up doing a huge number of stats looking for a +;; non-existent file everytime a translation is needed. This is +;; really expensive. So create a cache to hold the results. +(let ((domain-file-cache (make-hash-table :test 'equal))) + (defun get-domain-file-cache () + ;; Mostly for debugging to let the user get at the cache. + domain-file-cache) + (defun clear-domain-file-cache () + ;; Mostly for debugging. But also useful if we now have installed + ;; some new translations. + (clrhash domain-file-cache)) + (defun locate-domain-file (domain locale locale-dir) + ;; The default locale-dir includes search lists. If we get called + ;; before the search lists are initialized, we lose. The search + ;; lists are initialized in environment-init, which sets + ;; *environment-list-initialized*. This way, we return NIL to + ;; indicate there's no domain file to use. + (when lisp::*environment-list-initialized* + (flet ((path (locale base) + (merge-pathnames (make-pathname :directory (list :relative locale + "LC_MESSAGES") + :name domain :type "mo") + base)) + (memoized-probe-file (p) + ;; Cache the results of probe-file and return the + ;; cached value when possible. + (multiple-value-bind (value foundp) + (gethash p domain-file-cache) + (if foundp + value + (setf (gethash p domain-file-cache) (probe-file p)))))) + (let ((locale (or (gethash locale *locale-aliases*) locale))) + (dolist (base (if (listp locale-dir) locale-dir (list locale-dir))) + (let ((probe + (or (memoized-probe-file (path locale base)) + (let ((dot (position #\. locale))) + (and dot (memoized-probe-file (path (subseq locale 0 dot) base)))) + (let ((at (position #\@ locale))) + (and at (memoized-probe-file (path (subseq locale 0 at) base)))) + (let ((us (position #\_ locale))) + (and us (memoized-probe-file (path (subseq locale 0 us) base))))))) + (when probe (return probe))))))))) (defun find-encoding (domain) (when (null (domain-entry-encoding domain))

1 0

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

11 Dec '10

Date: Saturday, December 11, 2010 @ 10:07:08 Author: rtoy Path: /project/cmucl/cvsroot/src/compiler/generic Modified: new-genesis.lisp Revert some of the previous cleanups. They were preventing building on sparc for some reason. We keep the unicode and non-unicode fops separate for now. ------------------+ new-genesis.lisp | 85 ++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 59 insertions(+), 26 deletions(-) Index: src/compiler/generic/new-genesis.lisp diff -u src/compiler/generic/new-genesis.lisp:1.93 src/compiler/generic/new-genesis.lisp:1.94 --- src/compiler/generic/new-genesis.lisp:1.93 Sat Dec 4 18:17:06 2010 +++ src/compiler/generic/new-genesis.lisp Sat Dec 11 10:07:08 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.93 2010-12-04 23:17:06 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.94 2010-12-11 15:07:08 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -431,22 +431,15 @@ 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)) - (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 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))) + ;; Swap byte order of unicode strings. (dotimes (k len) (let ((x (aref bytes k))) - (setf (aref bytes k) (maybe-byte-swap-short x)))) - #+(or) - (format t " new codes = ~{~X~^ ~}~%" (coerce bytes 'list))) + (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 @@ -1340,15 +1333,30 @@ (defun maybe-byte-swap-string (s &optional len) (declare (ignore s len)) s) - + ;;; Cold-Load-Symbol loads a symbol N characters long from the File and interns ;;; that symbol in the given Package. ;;; +#-unicode +(defun cold-load-symbol (size package) + (let ((string (make-string size))) + (read-n-bytes *fasl-file* string 0 size) + (cold-intern (intern string package) package))) + +#+unicode +(defmacro load-char-code () + (ecase (c::backend-byte-order c::*native-backend*) + (:little-endian + `(code-char (+ (read-arg 1) + (ash (read-arg 1) 8)))) + (:big-endian + `(code-char (+ (ash (read-arg 1) 8) + (read-arg 1)))))) + +#+unicode (defun cold-load-symbol (size package) (let ((string (make-string size))) - (read-n-bytes *fasl-file* string 0 (* vm:char-bytes size)) - ;; Make the string have the correct byte order for the native - ;; backend. + (read-n-bytes *fasl-file* string 0 (* 2 size)) (maybe-byte-swap-string string) (cold-intern (intern string package) package))) @@ -1375,11 +1383,21 @@ (fop-keyword-small-symbol-save) (push-table (cold-load-symbol (clone-arg) *keyword-package*))) +#-unicode +(clone-cold-fop (fop-uninterned-symbol-save) + (fop-uninterned-small-symbol-save) + (let* ((size (clone-arg)) + (name (make-string size))) + (read-n-bytes *fasl-file* name 0 size) + (let ((symbol (allocate-symbol name))) + (push-table symbol)))) + +#+unicode (clone-cold-fop (fop-uninterned-symbol-save) (fop-uninterned-small-symbol-save) (let* ((size (clone-arg)) (name (make-string size))) - (read-n-bytes *fasl-file* name 0 (* vm:char-bytes size)) + (read-n-bytes *fasl-file* name 0 (* 2 size)) (maybe-byte-swap-string name) (let ((symbol (allocate-symbol name))) (push-table symbol)))) @@ -1434,14 +1452,20 @@ ;;; Loading vectors... +#-unicode +(clone-cold-fop (fop-string) + (fop-small-string) + (let* ((len (clone-arg)) + (string (make-string len))) + (read-n-bytes *fasl-file* string 0 len) + (string-to-core string))) + +#+unicode (clone-cold-fop (fop-string) (fop-small-string) (let* ((len (clone-arg)) (string (make-string len))) - (read-n-bytes *fasl-file* string 0 (* vm:char-bytes len)) - ;; Make the string have the correct byte order for the native - ;; backend. (This wouldn't be needed if string-to-core had an - ;; option not to swap bytes. + (read-n-bytes *fasl-file* string 0 (* 2 len)) (maybe-byte-swap-string string) (string-to-core string))) @@ -1965,8 +1989,13 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) - (maybe-byte-swap-string sym) + #-unicode + (read-n-bytes *fasl-file* sym 0 len) + #+unicode + (progn + (read-n-bytes *fasl-file* sym 0 (* 2 len)) + (maybe-byte-swap-string sym)) + (let ((offset (read-arg 4)) (value #+linkage-table (cold-register-foreign-linkage sym :code) #-linkage-table (lookup-foreign-symbol sym))) @@ -1981,8 +2010,12 @@ (code-object (pop-stack)) (len (read-arg 1)) (sym (make-string len))) - (read-n-bytes *fasl-file* sym 0 (* vm:char-bytes len)) - (maybe-byte-swap-string sym) + #-unicode + (read-n-bytes *fasl-file* sym 0 len) + #+unicode + (progn + (read-n-bytes *fasl-file* sym 0 (* 2 len)) + (maybe-byte-swap-string sym)) (let ((offset (read-arg 4)) (value (cold-register-foreign-linkage sym :data))) (do-cold-fixup code-object offset value kind)) @@ -2185,8 +2218,8 @@ type *cold-linkage-table* *cold-foreign-hash*))) - (+ (c:backend-foreign-linkage-space-start c:*backend*) - (* entry-num (c:backend-foreign-linkage-entry-size c:*backend*))))) + (+ vm:target-foreign-linkage-space-start + (* entry-num vm:target-foreign-linkage-entry-size)))) #+linkage-table (defun init-foreign-linkage ()

1 0

[cmucl-cvs] CMUCL commit: src/code (exports.lisp)
by Raymond Toy 09 Dec '10

09 Dec '10

Date: Thursday, December 9, 2010 @ 09:01:01 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: exports.lisp Export some UNIX symbols for FreeBSD to get rid of a build warning. --------------+ exports.lisp | 19 ++++++++++++++++++- 1 file changed, 18 insertions(+), 1 deletion(-) Index: src/code/exports.lisp diff -u src/code/exports.lisp:1.302 src/code/exports.lisp:1.303 --- src/code/exports.lisp:1.302 Wed Nov 10 14:51:23 2010 +++ src/code/exports.lisp Thu Dec 9 09:01: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/exports.lisp,v 1.302 2010-11-10 19:51:23 rtoy Exp $") + "$Header: /project/cmucl/cvsroot/src/code/exports.lisp,v 1.303 2010-12-09 14:01:01 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -338,6 +338,23 @@ "USER-INFO" "USER-INFO-NAME" "USER-INFO-PASSWORD" "USER-INFO-UID" "USER-INFO-GID" "USER-INFO-GECOS" "USER-INFO-DIR" "USER-INFO-SHELL" "GROUP-INFO" "GROUP-INFO-NAME" "GROUP-INFO-GID" "GROUP-INFO-MEMBERS") + #+freebsd + (:export "GROUP-INFO" + "GROUP-INFO-GID" + "GROUP-INFO-MEMBERS" + "GROUP-INFO-NAME" + "UNIX-GETGRGID" + "UNIX-GETGRNAM" + "UNIX-GETPWNAM" + "UNIX-GETPWUID" + "USER-INFO" + "USER-INFO-DIR" + "USER-INFO-GECOS" + "USER-INFO-GID" + "USER-INFO-NAME" + "USER-INFO-PASSWORD" + "USER-INFO-SHELL" + "USER-INFO-UID") #+ppc (:export "UNIX-GETPWUID" "USER-INFO"

1 0

[cmucl-cvs] CMUCL commit: src (code/seq.lisp general-info/release-20c.txt)
by Raymond Toy 09 Dec '10

09 Dec '10

Date: Thursday, December 9, 2010 @ 00:13:51 Author: rtoy Path: /project/cmucl/cvsroot/src Modified: code/seq.lisp general-info/release-20c.txt SUBSEQ was sometimes crashing lisp when the end index was less than the start. This was due to one of two things: The result sequence was created with a negative length, creating invalid objects, or accessing the invalid object would cause a segfault. code/seq.lisp: o Declare the type of LENGTH in MAKE-SEQUENCE-OF-TYPE better. It's not a fixnum, but an index (non-negative fixnum). This should catch any mistakes where we try to create sequences of negative length. o Explicitly catch invalid START and END indices in VECTOR-SUBSEQ* and LIST-SUBSEQ* and signal an error general-info/release-20c.txt: o Document bugfix. ------------------------------+ code/seq.lisp | 8 ++++++-- general-info/release-20c.txt | 3 +++ 2 files changed, 9 insertions(+), 2 deletions(-) Index: src/code/seq.lisp diff -u src/code/seq.lisp:1.58 src/code/seq.lisp:1.59 --- src/code/seq.lisp:1.58 Tue Apr 20 13:57:45 2010 +++ src/code/seq.lisp Thu Dec 9 00:13:50 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/seq.lisp,v 1.58 2010-04-20 17:57:45 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/seq.lisp,v 1.59 2010-12-09 05:13:50 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -124,7 +124,7 @@ (defun make-sequence-of-type (type length) "Returns a sequence of the given TYPE and LENGTH." - (declare (fixnum length)) + (declare (type index length)) (case (type-specifier-atom type) (list (make-list length)) ((bit-vector simple-bit-vector) (make-array length :element-type '(mod 2))) @@ -285,6 +285,8 @@ (defun vector-subseq* (sequence start &optional end) (declare (vector sequence) (fixnum start)) (when (null end) (setf end (length sequence))) + (unless (<= start end) + (error "Illegal bounding indices: ~S ~S" start end)) (do ((old-index start (1+ old-index)) (new-index 0 (1+ new-index)) (copy (make-sequence-like sequence (- end start)))) @@ -294,6 +296,8 @@ (defun list-subseq* (sequence start &optional end) (declare (list sequence) (fixnum start)) + (when (and end (> start (the fixnum end))) + (error "Illegal bounding indices: ~S ~S" start end)) (if (and end (>= start (the fixnum end))) () (let* ((groveled (nthcdr start sequence)) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.13 src/general-info/release-20c.txt:1.14 --- src/general-info/release-20c.txt:1.13 Thu Dec 2 09:26:45 2010 +++ src/general-info/release-20c.txt Thu Dec 9 00:13:50 2010 @@ -85,6 +85,9 @@ - FORMAT signals an warning if ~:; is used inside ~:[. - SET-SYSTEM-EXTERNAL-FORMAT was not actually setting the filename encoding if given. + - SUBSEQ with an end index less than the start index sometimes + crashes CMUCL. Now, signal an error if the boudns are not + valid. * Trac Tickets:

1 0

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

08 Dec '10

Date: Wednesday, December 8, 2010 @ 18:57:02 Author: rtoy Path: /project/cmucl/cvsroot/src/contrib/asdf Modified: asdf.lisp Update to version 2.011. -----------+ asdf.lisp | 351 ++++++++++++++++++++++++++++++++---------------------------- 1 file changed, 188 insertions(+), 163 deletions(-) Index: src/contrib/asdf/asdf.lisp diff -u src/contrib/asdf/asdf.lisp:1.10 src/contrib/asdf/asdf.lisp:1.11 --- src/contrib/asdf/asdf.lisp:1.10 Thu Nov 4 10:04:10 2010 +++ src/contrib/asdf/asdf.lisp Wed Dec 8 18:57:02 2010 @@ -49,6 +49,8 @@ (cl:in-package :cl-user) +#+gcl (defpackage :asdf (:use :cl)) ;; GCL treats defpackage magically and needs this + (eval-when (:compile-toplevel :load-toplevel :execute) ;;; make package if it doesn't exist yet. ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. @@ -66,20 +68,25 @@ ;;;; Create packages in a way that is compatible with hot-upgrade. ;;;; See https://bugs.launchpad.net/asdf/+bug/485687 -;;;; See more at the end of the file. +;;;; See more near the end of the file. (eval-when (:load-toplevel :compile-toplevel :execute) (defvar *asdf-version* nil) (defvar *upgraded-p* nil) - (let* ((asdf-version "2.010") ;; same as 2.146 + (let* (;; For bug reporting sanity, please always bump this version when you modify this file. + ;; "2.345" would be an official release + ;; "2.345.6" would be a development version in the official upstream + ;; "2.345.0.7" would be your local modification of an official release + ;; "2.345.6.7" would be your local modification of a development version + (asdf-version "2.011") (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 *error-output* - "~&Upgrading ASDF package ~@[from version ~A ~]to version ~A~%" - existing-version asdf-version)) + (format *trace-output* + "~&~@<; ~@;Upgrading ASDF package ~@[from version ~A ~]to version ~A~@:>~%" + existing-version asdf-version)) (labels ((unlink-package (package) (let ((u (find-package package))) @@ -180,7 +187,8 @@ #:apply-output-translations #:translate-pathname* #:resolve-location) :unintern (#:*asdf-revision* #:around #:asdf-method-combination - #:split #:make-collector) + #:split #:make-collector + #:output-files-for-system-and-operation) ; obsolete ASDF-BINARY-LOCATION function :fmakunbound (#:system-source-file #:component-relative-pathname #:system-relative-pathname @@ -234,6 +242,7 @@ #:system-relative-pathname #:map-systems + #:operation-description #:operation-on-warnings #:operation-on-failure #:component-visited-p @@ -286,7 +295,7 @@ ;; Utilities #:absolute-pathname-p - ;; #:aif #:it + ;; #:aif #:it ;; #:appendf #:coerce-name #:directory-pathname-p @@ -295,11 +304,12 @@ #:getenv ;; #:get-uid ;; #:length=n-p + ;; #:find-symbol* #:merge-pathnames* #:pathname-directory-pathname #:read-file-forms - ;; #:remove-keys - ;; #:remove-keyword + ;; #:remove-keys + ;; #:remove-keyword #:resolve-symlinks #:split-string #:component-name-to-pathname-components @@ -312,31 +322,6 @@ (cons existing-version *upgraded-p*) *upgraded-p*)))))) -;; More cleanups in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 -(when *upgraded-p* - #+ecl - (when (find-class 'compile-op nil) - (defmethod update-instance-for-redefined-class :after - ((c compile-op) added deleted plist &key) - (declare (ignore added deleted)) - (let ((system-p (getf plist 'system-p))) - (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) - (when (find-class 'module nil) - (eval - '(progn - (defmethod update-instance-for-redefined-class :after - ((m module) added deleted plist &key) - (declare (ignorable deleted plist)) - (when *asdf-verbose* (format *trace-output* "Updating ~A~%" m)) - (when (member 'components-by-name added) - (compute-module-components-by-name m))) - (defmethod update-instance-for-redefined-class :after - ((s system) added deleted plist &key) - (declare (ignorable deleted plist)) - (when *asdf-verbose* (format *trace-output* "Updating ~A~%" s)) - (when (member 'source-file added) - (%set-system-source-file (probe-asd (component-name s) (component-pathname s)) s))))))) - ;;;; ------------------------------------------------------------------------- ;;;; User-visible parameters ;;;; @@ -378,7 +363,8 @@ (setf excl:*warn-on-nested-reader-conditionals* nil))) ;;;; ------------------------------------------------------------------------- -;;;; ASDF Interface, in terms of generic functions. +;;;; General Purpose Utilities + (macrolet ((defdef (def* def) `(defmacro ,def* (name formals &rest rest) @@ -390,113 +376,6 @@ (defdef defgeneric* defgeneric) (defdef defun* defun)) -(defgeneric* find-system (system &optional error-p)) -(defgeneric* perform-with-restarts (operation component)) -(defgeneric* perform (operation component)) -(defgeneric* operation-done-p (operation component)) -(defgeneric* explain (operation component)) -(defgeneric* output-files (operation component)) -(defgeneric* input-files (operation component)) -(defgeneric* component-operation-time (operation component)) -(defgeneric* operation-description (operation component) - (:documentation "returns a phrase that describes performing this operation -on this component, e.g. \"loading /a/b/c\". -You can put together sentences using this phrase.")) - -(defgeneric* system-source-file (system) - (:documentation "Return the source file in which system is defined.")) - -(defgeneric* component-system (component) - (:documentation "Find the top-level system containing COMPONENT")) - -(defgeneric* component-pathname (component) - (:documentation "Extracts the pathname applicable for a particular component.")) - -(defgeneric* component-relative-pathname (component) - (:documentation "Returns a pathname for the component argument intended to be -interpreted relative to the pathname of that component's parent. -Despite the function's name, the return value may be an absolute -pathname, because an absolute pathname may be interpreted relative to -another pathname in a degenerate way.")) - -(defgeneric* component-property (component property)) - -(defgeneric* (setf component-property) (new-value component property)) - -(defgeneric* version-satisfies (component version)) - -(defgeneric* find-component (base path) - (:documentation "Finds the component with PATH starting from BASE module; -if BASE is nil, then the component is assumed to be a system.")) - -(defgeneric* source-file-type (component system)) - -(defgeneric* operation-ancestor (operation) - (:documentation - "Recursively chase the operation's parent pointer until we get to -the head of the tree")) - -(defgeneric* component-visited-p (operation component) - (:documentation "Returns the value stored by a call to -VISIT-COMPONENT, if that has been called, otherwise NIL. -This value stored will be a cons cell, the first element -of which is a computed key, so not interesting. The -CDR wil be the DATA value stored by VISIT-COMPONENT; recover -it as (cdr (component-visited-p op c)). - In the current form of ASDF, the DATA value retrieved is -effectively a boolean, indicating whether some operations are -to be performed in order to do OPERATION X COMPONENT. If the -data value is NIL, the combination had been explored, but no -operations needed to be performed.")) - -(defgeneric* visit-component (operation component data) - (:documentation "Record DATA as being associated with OPERATION -and COMPONENT. This is a side-effecting function: the association -will be recorded on the ROOT OPERATION $OPERATION-ANCESTOR of the -OPERATION$. - No evidence that DATA is ever interesting, beyond just being -non-NIL. Using the data field is probably very risky; if there is -already a record for OPERATION X COMPONENT, DATA will be quietly -discarded instead of recorded. - Starting with 2.006, TRAVERSE will store an integer in data, -so that nodes can be sorted in decreasing order of traversal.")) - - -(defgeneric* (setf visiting-component) (new-value operation component)) - -(defgeneric* component-visiting-p (operation component)) - -(defgeneric* component-depends-on (operation component) - (:documentation - "Returns a list of dependencies needed by the component to perform - the operation. A dependency has one of the following forms: - - (<operation> <component>*), where <operation> is a class - designator and each <component> is a component - designator, which means that the component depends on - <operation> having been performed on each <component>; or - - (FEATURE <feature>), which means that the component depends - on <feature>'s presence in *FEATURES*. - - Methods specialized on subclasses of existing component types - should usually append the results of CALL-NEXT-METHOD to the - list.")) - -(defgeneric* component-self-dependencies (operation component)) - -(defgeneric* traverse (operation component) - (:documentation -"Generate and return a plan for performing OPERATION on COMPONENT. - -The plan returned is a list of dotted-pairs. Each pair is the CONS -of ASDF operation object and a COMPONENT object. The pairs will be -processed in order by OPERATE.")) - - -;;;; ------------------------------------------------------------------------- -;;;; General Purpose Utilities - (defmacro while-collecting ((&rest collectors) &body body) "COLLECTORS should be a list of names for collections. A collector defines a function that, when applied to an argument inside BODY, will @@ -535,11 +414,11 @@ (directory (pathname-directory specified)) (directory (cond - #-(or sbcl cmu) + #-(or sbcl cmu scl) ((stringp directory) `(:absolute ,directory) directory) #+gcl - ((and (consp directory) (stringp (first directory))) - `(:absolute ,@directory)) + ((and (consp directory) (not (member (first directory) '(:absolute :relative)))) + `(:relative ,@directory)) ((or (null directory) (and (consp directory) (member (first directory) '(:absolute :relative)))) directory) @@ -675,9 +554,8 @@ :append (list k v))) (defun* getenv (x) - (#+abcl ext:getenv + (#+(or abcl clisp) ext:getenv #+allegro sys:getenv - #+clisp ext:getenv #+clozure ccl:getenv #+(or cmu scl) (lambda (x) (cdr (assoc x ext:*environment-list* :test #'string=))) #+ecl si:getenv @@ -723,7 +601,8 @@ :defaults pathspec)))) (defun* absolute-pathname-p (pathspec) - (and pathspec (eq :absolute (car (pathname-directory (pathname pathspec)))))) + (and (typep pathspec '(or pathname string)) + (eq :absolute (car (pathname-directory (pathname pathspec)))))) (defun* length=n-p (x n) ;is it that (= (length x) n) ? (check-type n (integer 0 *)) @@ -755,7 +634,7 @@ (defun* get-uid () #+allegro (excl.osi:getuid) #+clisp (loop :for s :in '("posix:uid" "LINUX:getuid") - :for f = (ignore-errors (read-from-string s)) + :for f = (ignore-errors (read-from-string s)) :when f :return (funcall f)) #+(or cmu scl) (unix:unix-getuid) #+ecl #.(cl:if (cl:< ext:+ecl-version-number+ 100601) @@ -777,6 +656,9 @@ :directory '(:absolute) :name nil :type nil :version nil)) +(defun* find-symbol* (s p) + (find-symbol (string s) p)) + (defun* probe-file* (p) "when given a pathname P, probes the filesystem for a file or directory with given pathname and if it exists return its truename." @@ -785,8 +667,8 @@ (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) `(ignore-errors (,it p))) - '(ignore-errors (truename p))))))) + #+clisp (aif (find-symbol (string '#:probe-pathname) :ext) `(ignore-errors (,it p))) + '(ignore-errors (truename p))))))) (defun* truenamize (p) "Resolve as much of a pathname as possible" @@ -859,6 +741,134 @@ (translate-pathname absolute-pathname wild-root (wilden new-base)))))) ;;;; ------------------------------------------------------------------------- +;;;; ASDF Interface, in terms of generic functions. +(defgeneric* find-system (system &optional error-p)) +(defgeneric* perform-with-restarts (operation component)) +(defgeneric* perform (operation component)) +(defgeneric* operation-done-p (operation component)) +(defgeneric* explain (operation component)) +(defgeneric* output-files (operation component)) +(defgeneric* input-files (operation component)) +(defgeneric* component-operation-time (operation component)) +(defgeneric* operation-description (operation component) + (:documentation "returns a phrase that describes performing this operation +on this component, e.g. \"loading /a/b/c\". +You can put together sentences using this phrase.")) + +(defgeneric* system-source-file (system) + (:documentation "Return the source file in which system is defined.")) + +(defgeneric* component-system (component) + (:documentation "Find the top-level system containing COMPONENT")) + +(defgeneric* component-pathname (component) + (:documentation "Extracts the pathname applicable for a particular component.")) + +(defgeneric* component-relative-pathname (component) + (:documentation "Returns a pathname for the component argument intended to be +interpreted relative to the pathname of that component's parent. +Despite the function's name, the return value may be an absolute +pathname, because an absolute pathname may be interpreted relative to +another pathname in a degenerate way.")) + +(defgeneric* component-property (component property)) + +(defgeneric* (setf component-property) (new-value component property)) + +(defgeneric* version-satisfies (component version)) + +(defgeneric* find-component (base path) + (:documentation "Finds the component with PATH starting from BASE module; +if BASE is nil, then the component is assumed to be a system.")) + +(defgeneric* source-file-type (component system)) + +(defgeneric* operation-ancestor (operation) + (:documentation + "Recursively chase the operation's parent pointer until we get to +the head of the tree")) + +(defgeneric* component-visited-p (operation component) + (:documentation "Returns the value stored by a call to +VISIT-COMPONENT, if that has been called, otherwise NIL. +This value stored will be a cons cell, the first element +of which is a computed key, so not interesting. The +CDR wil be the DATA value stored by VISIT-COMPONENT; recover +it as (cdr (component-visited-p op c)). + In the current form of ASDF, the DATA value retrieved is +effectively a boolean, indicating whether some operations are +to be performed in order to do OPERATION X COMPONENT. If the +data value is NIL, the combination had been explored, but no +operations needed to be performed.")) + +(defgeneric* visit-component (operation component data) + (:documentation "Record DATA as being associated with OPERATION +and COMPONENT. This is a side-effecting function: the association +will be recorded on the ROOT OPERATION $OPERATION-ANCESTOR of the +OPERATION$. + No evidence that DATA is ever interesting, beyond just being +non-NIL. Using the data field is probably very risky; if there is +already a record for OPERATION X COMPONENT, DATA will be quietly +discarded instead of recorded. + Starting with 2.006, TRAVERSE will store an integer in data, +so that nodes can be sorted in decreasing order of traversal.")) + + +(defgeneric* (setf visiting-component) (new-value operation component)) + +(defgeneric* component-visiting-p (operation component)) + +(defgeneric* component-depends-on (operation component) + (:documentation + "Returns a list of dependencies needed by the component to perform + the operation. A dependency has one of the following forms: + + (<operation> <component>*), where <operation> is a class + designator and each <component> is a component + designator, which means that the component depends on + <operation> having been performed on each <component>; or + + (FEATURE <feature>), which means that the component depends + on <feature>'s presence in *FEATURES*. + + Methods specialized on subclasses of existing component types + should usually append the results of CALL-NEXT-METHOD to the + list.")) + +(defgeneric* component-self-dependencies (operation component)) + +(defgeneric* traverse (operation component) + (:documentation +"Generate and return a plan for performing OPERATION on COMPONENT. + +The plan returned is a list of dotted-pairs. Each pair is the CONS +of ASDF operation object and a COMPONENT object. The pairs will be +processed in order by OPERATE.")) + + +;;;; ------------------------------------------------------------------------- +;;; Methods in case of hot-upgrade. See https://bugs.launchpad.net/asdf/+bug/485687 +(when *upgraded-p* + #+ecl + (when (find-class 'compile-op nil) + (defmethod update-instance-for-redefined-class :after + ((c compile-op) added deleted plist &key) + (declare (ignore added deleted)) + (let ((system-p (getf plist 'system-p))) + (when system-p (setf (getf (slot-value c 'flags) :system-p) system-p))))) + (when (find-class 'module nil) + (eval + `(defmethod update-instance-for-redefined-class :after + ((m module) added deleted plist &key) + (declare (ignorable deleted plist)) + (when (or *asdf-verbose* *load-verbose*) + (asdf-message "~&~@<; ~@; Updating ~A for ASDF ~A~@:>~%" m ,(asdf-version))) + (when (member 'components-by-name added) + (compute-module-components-by-name m)) + (when (and (typep m 'system) (member 'source-file added)) + (%set-system-source-file (probe-asd (component-name m) (component-pathname m)) m)))))) + +;;;; ------------------------------------------------------------------------- ;;;; Classes, Conditions (define-condition system-definition-error (error) () @@ -1000,7 +1010,7 @@ (format s "~@<component ~S not found~@[ in ~A~]~@:>" (missing-requires c) (when (missing-parent c) - (component-name (missing-parent c))))) + (coerce-name (missing-parent c))))) (defmethod print-object ((c missing-component-of-version) s) (format s "~@<component ~S does not match version ~A~@[ in ~A~]~@:>" @@ -1295,7 +1305,7 @@ :condition condition)))) (let ((*package* package)) (asdf-message - "~&~@<; ~@;loading system definition from ~A into ~A~@:>~%" + "~&~@<; ~@;Loading system definition from ~A into ~A~@:>~%" on-disk *package*) (load on-disk))) (delete-package package)))) @@ -1309,19 +1319,22 @@ (error 'missing-component :requires name))))))) (defun* register-system (name system) - (asdf-message "~&~@<; ~@;registering ~A as ~A~@:>~%" system name) + (asdf-message "~&~@<; ~@;Registering ~A as ~A~@:>~%" system name) (setf (gethash (coerce-name name) *defined-systems*) (cons (get-universal-time) system))) (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*) + source-file (or source-file + (if *resolve-symlinks* + (or *compile-file-truename* *load-truename*) + (or *compile-file-pathname* *load-pathname*))) requested (coerce-name requested)) (when (equal requested fallback) (let* ((registered (cdr (gethash fallback *defined-systems*))) (system (or registered (apply 'make-instance 'system - :name fallback :source-file source-file keys)))) + :name fallback :source-file source-file keys)))) (unless registered (register-system fallback system)) (throw 'find-system system)))) @@ -2201,9 +2214,9 @@ (defun* class-for-type (parent type) (or (loop :for symbol :in (list - (unless (keywordp type) type) - (find-symbol (symbol-name type) *package*) - (find-symbol (symbol-name type) :asdf)) + type + (find-symbol* type *package*) + (find-symbol* type :asdf)) :for class = (and symbol (find-class symbol nil)) :when (and class (subtypep class 'component)) :return class) @@ -2390,8 +2403,8 @@ #+mswindows "sh" #-mswindows "/bin/sh" command) :input nil :whole nil #+mswindows :show-window #+mswindows :hide) - (format *verbose-out* "~{~&; ~a~%~}~%" stderr) - (format *verbose-out* "~{~&; ~a~%~}~%" stdout) + (asdf-message "~{~&; ~a~%~}~%" stderr) + (asdf-message "~{~&; ~a~%~}~%" stdout) exit-code) #+clisp ;XXX not exactly *verbose-out*, I know @@ -3121,6 +3134,18 @@ ;;;; ----------------------------------------------------------------- ;;;; Compatibility mode for ASDF-Binary-Locations +(defmethod operate :before (operation-class system &rest args &key &allow-other-keys) + (declare (ignorable operation-class system args)) + (when (find-symbol* '#:output-files-for-system-and-operation :asdf) + (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using. +ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS, +which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS, +and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details. +In case you insist on preserving your previous A-B-L configuration, but +do not know how to achieve the same effect with A-O-T, you may use function +ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual; +call that function where you would otherwise have loaded and configured A-B-L."))) + (defun* enable-asdf-binary-locations-compatibility (&key (centralize-lisp-binaries nil) @@ -3548,7 +3573,7 @@ (clear-output-translations)) ;;;; ----------------------------------------------------------------- -;;;; Hook into REQUIRE for ABCL, ClozureCL, CMUCL, ECL and SBCL +;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL ;;;; (defun* module-provide-asdf (name) (handler-bind @@ -3564,7 +3589,7 @@ t)))) #+(or abcl clisp clozure cmu ecl sbcl) -(let ((x (and #+clisp (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" :custom)))) +(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom)))) (when x (eval `(pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions*

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www (3 files)
by Raymond Toy 07 Dec '10

07 Dec '10

Date: Monday, December 6, 2010 @ 20:25:14 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www Modified: download.html index.html news/index.html Update for 2010-12 snapshot release. -----------------+ download.html | 78 +++++++++++++++++++++++++++++++++++++++++++++++++----- index.html | 51 +++++++++++++++++++---------------- news/index.html | 27 ++++++++++++++++++ 3 files changed, 127 insertions(+), 29 deletions(-) Index: cmucl-www/cmucl-www/www/download.html diff -u cmucl-www/cmucl-www/www/download.html:1.26 cmucl-www/cmucl-www/www/download.html:1.27 --- cmucl-www/cmucl-www/www/download.html:1.26 Mon Nov 1 13:09:21 2010 +++ cmucl-www/cmucl-www/www/download.html Mon Dec 6 20:25:14 2010 @@ -92,6 +92,69 @@ </tr> <tr> + <th>2010-12</th> + <td> + <ul> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Unicode</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Unicode extras</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Non-Unicode</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Non-Unicode extras</a></li> + </ul> + </td> + <td> + <ul> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Unicode extras</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Non-Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Non-Unicode extras</a></li> + </ul> + </td> + <td> + + + </td> + <td> + + <ul> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Unicode extras</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Non-Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-2010…">Non-Unicode extras</a></li> + </ul> + </td> + <td> + + + </td> + <td> + + + </td> + <td> + <ul> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/cmucl-src-…">Source code</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/12/release-20…">Release notes for 20c</a></li> + </ul> + </td> + </tr> + + <tr> <th>2010-11</th> <td> <ul> @@ -150,7 +213,7 @@ <td> <ul> <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/cmucl-src-…">Source code</a></li> - <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/release-20…">Release notes for 20b</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/release-20…">Release notes for 20c</a></li> </ul> </td> </tr> @@ -174,11 +237,14 @@ </ul> </td> <td> - - + <dl> + <dt>8.1-stable + <dd> <a + href="http://common-lisp.net/project/cmucl/downloads/release/20b/cmucl-20b-x86-fr…">Unicode</a></dd> + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/release/20b/cmucl-20b-x86-fr…">Unicode extras</a></dd> + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/release/20b/cmucl-20b-non-un…">Non-Unicode</a></dd> + <dd> <a href="http://common-lisp.net/project/cmucl/downloads/release/20b/cmucl-20b-non-un…">Non-Unicode extras</a></dd> + </dl> </td> <td>  Index: cmucl-www/cmucl-www/www/index.html diff -u cmucl-www/cmucl-www/www/index.html:1.18 cmucl-www/cmucl-www/www/index.html:1.19 --- cmucl-www/cmucl-www/www/index.html:1.18 Mon Nov 1 09:54:10 2010 +++ cmucl-www/cmucl-www/www/index.html Mon Dec 6 20:25:14 2010 @@ -68,6 +68,34 @@ Also see <a href="news/index.html">News</a> for older news. <dl> +<dt>Snapshot 2010-12 +<dd> + The 2010-11 snapshot has been released. See the release notes for + details, but here is a quick summary of the changes between the + this snapshot and the 2010-11 snapshot. + <ul> + <li> ASDF2 updated to version 2.010.</li> + <li> On x86, <code>REALPART</code> and <code>IMAGPART</code> no longer incorrectly returns 0 + instead of the correct part of a complex number in some + situations.</li> + <li> The command line parser now correctly handles the case where + "--" is the first command option.</li> + <li> <code>build.sh</code> was accidenally loading the site-init file, but it + shouldn't. </li> + <li> 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.</li> + <li> <code>XLIB::GET-BEST-AUTHORIZATION</code> 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 <code>GET-BEST-AUTHORIZATION</code> was looking for the + hostname.</li> + <li> <code>FORMAT</code> signals an warning if <code>~:;</code> is used inside <code>~:[.</code></li> + <li> <code>SET-SYSTEM-EXTERNAL-FORMAT</code> was not actually setting the filename + encoding if given.</li> + </ul> +</dd> + <dt>20b patch 000 <dd> A critical bug in <code>REALPART</code> and <code>IMAGPART</code> has @@ -75,29 +103,6 @@ this issue in the 20b release. <a href="install.html">Installation</a> instructions are available. </dd> -<dt>Snapshot 2010-11 -<dd> - The 2010-11 snapshot has been released. See the release notes for - details, but here is a quick summary of the changes between the - snapshot and the 20b release: - <ul> - <li> Update to Unicode 5.2.0.</li> - <li> Support for character name completion for use with Slime.</li> - <li> <code>COMPILE-FILE</code> accepts a - <code>:DECODING-ERROR</code> argument that indicates how to handle - decoding errors when reading the file.</li> - <li> <code>RUN-PROGRAM</code> accepts <code>:EXTERNAL-FORMAT</code> - parameter to specify the external format for streams that are - created.</li> - <li> <code>READ-CHAR</code> signals errors on non-character - streams. <code>READ-BYTE</code> signals errors on character - streams. This is a change from previous versions. However, both - will work if the stream is a <code>binary-text-stream</code>.</li> - <li> <code>REALPART</code> and <code>IMAGPARG</code> no longer - returns 0 instead of the correct part of a complex number in some - situations. </li> - </ul> -</dd> <dt>CMUCL 20b released</dt> <dd> CMUCL 20b has been released, For information on the changes between Index: cmucl-www/cmucl-www/www/news/index.html diff -u cmucl-www/cmucl-www/www/news/index.html:1.43 cmucl-www/cmucl-www/www/news/index.html:1.44 --- cmucl-www/cmucl-www/www/news/index.html:1.43 Mon Nov 1 10:05:40 2010 +++ cmucl-www/cmucl-www/www/news/index.html Mon Dec 6 20:25:14 2010 @@ -11,6 +11,33 @@ <dl> +<dt>2010-12 snapshot +<dd> +Some of the important changes are listed below. See the <a +href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/release-20…">release +notes</a> for more details. + <ul> + <li> ASDF2 updated to version 2.010.</li> + <li> On x86, <code>REALPART</code> and <code>IMAGPART</code> no longer incorrectly returns 0 + instead of the correct part of a complex number in some + situations.</li> + <li> The command line parser now correctly handles the case where + "--" is the first command option.</li> + <li> <code>build.sh</code> was accidenally loading the site-init file, but it + shouldn't. </li> + <li> 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.</li> + <li> <code>XLIB::GET-BEST-AUTHORIZATION</code> 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 <code>GET-BEST-AUTHORIZATION</code> was looking for the + hostname.</li> + <li> <code>FORMAT</code> signals an warning if <code>~:;</code> is used inside <code>~:[.</code></li> + <li> <code>SET-SYSTEM-EXTERNAL-FORMAT</code> was not actually setting the filename + encoding if given.</li> + </ul> +</dd> <dt>20b patch 000 <dd> A critical bug in <code>REALPART</code> and <code>IMAGPART</code> has

1 0

[cmucl-cvs] CMUCL commit: src/code (alieneval.lisp)
by Raymond Toy 05 Dec '10

05 Dec '10

Date: Sunday, December 5, 2010 @ 10:55:53 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: alieneval.lisp No functional changes. Just update examples. o Fix typo in callback examples. o Add package qualifiers so the examples can be used in CL-USER. ----------------+ alieneval.lisp | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) Index: src/code/alieneval.lisp diff -u src/code/alieneval.lisp:1.69 src/code/alieneval.lisp:1.70 --- src/code/alieneval.lisp:1.69 Tue Apr 20 13:57:43 2010 +++ src/code/alieneval.lisp Sun Dec 5 10:55:53 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/alieneval.lisp,v 1.69 2010-04-20 17:57:43 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/alieneval.lisp,v 1.70 2010-12-05 15:55:53 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -2120,25 +2120,26 @@ #|| ;;; Example 1: -(defcallback foo (int (arg1 int) (arg2 int)) +(alien:def-callback foo (c-call:int (arg1 c-call:int) (arg2 c-call:int)) (format t "~&foo: ~S, ~S~%" arg1 arg2) (+ arg1 arg2)) -(alien-funcall (sap-alien (callback foo) (function int int int)) +(alien:alien-funcall (alien:sap-alien (alien:callback foo) + (function c-call:int c-call:int c-call:int)) 555 444444) ;;; Example 2: -(def-alien-routine qsort void +(alien:def-alien-routine qsort c-call:void (base (* t)) - (nmemb int) - (size int) - (compar (* (function int (* t) (* t))))) - -(defcallback my< (int (arg1 (* double)) - (arg2 (* double))) - (let ((a1 (deref arg1)) - (a2 (deref arg2))) + (nmemb c-call:int) + (size c-call:int) + (compar (* (function c-call:int (* t) (* t))))) + +(alien:def-callback my< (c-call:int (arg1 (* c-call:double)) + (arg2 (* c-call:double))) + (let ((a1 (alien:deref arg1)) + (a2 (alien:deref arg2))) (cond ((= a1 a2) 0) ((< a1 a2) -1) (t +1)))) @@ -2149,8 +2150,8 @@ (print a) (qsort (sys:vector-sap a) (length a) - (alien-size double :bytes) - (callback my<)) + (alien:alien-size c-call:double :bytes) + (alien:callback my<)) (print a)) ||#

1 0

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

05 Dec '10

Date: Sunday, December 5, 2010 @ 09:28:49 Author: rtoy Path: /project/cmucl/cvsroot/src/tools/cross-scripts Modified: cross-x86-sparc.lisp Minor change to allow the script to work for cross-compiling non-unicode sparc from x86 OSX. ----------------------+ cross-x86-sparc.lisp | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) Index: src/tools/cross-scripts/cross-x86-sparc.lisp diff -u src/tools/cross-scripts/cross-x86-sparc.lisp:1.2 src/tools/cross-scripts/cross-x86-sparc.lisp:1.3 --- src/tools/cross-scripts/cross-x86-sparc.lisp:1.2 Sat Dec 4 12:32:35 2010 +++ src/tools/cross-scripts/cross-x86-sparc.lisp Sun Dec 5 09:28:49 2010 @@ -65,6 +65,7 @@ ;; 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. +#+unicode (progn (defun maybe-swap-string (f name &optional (len (length name))) (declare (ignorable f)) @@ -90,7 +91,7 @@ (when (> ,n-size *load-symbol-buffer-size*) (setq *load-symbol-buffer* (make-string (setq *load-symbol-buffer-size* - (* ,n-size 2))))) + (* ,n-size vm:char-bytes))))) (done-with-fast-read-byte) (let ((,n-buffer *load-symbol-buffer*)) (read-n-bytes *fasl-file* ,n-buffer 0

1 0