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

[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

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

03 Nov '10

Date: Wednesday, November 3, 2010 @ 11:11:57 Author: rtoy Path: /project/cmucl/cvsroot/src/tools Modified: build.sh Don't load site-init file. ----------+ build.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/tools/build.sh diff -u src/tools/build.sh:1.36 src/tools/build.sh:1.37 --- src/tools/build.sh:1.36 Thu Oct 14 13:47:12 2010 +++ src/tools/build.sh Wed Nov 3 11:11:57 2010 @@ -32,7 +32,7 @@ # # For more information see src/BUILDING. # -# $Header: /project/cmucl/cvsroot/src/tools/build.sh,v 1.36 2010-10-14 17:47:12 rtoy Exp $ +# $Header: /project/cmucl/cvsroot/src/tools/build.sh,v 1.37 2010-11-03 15:11:57 rtoy Exp $ # ENABLE2="yes" @@ -133,7 +133,7 @@ fi $TOOLDIR/load-world.sh $TARGET "$VERSION" || { echo "Failed: $TOOLDIR/load-world.sh"; exit 1; } - $TARGET/lisp/lisp -batch -noinit $FPU_MODE < /dev/null || { echo "Failed: $TARGET/lisp/lisp -batch -noinit $FPU_MODE"; exit 1; } + $TARGET/lisp/lisp -batch -noinit -nositeinit $FPU_MODE < /dev/null || { echo "Failed: $TARGET/lisp/lisp -batch -noinit $FPU_MODE"; exit 1; } return 0; fi }

1 0

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

02 Nov '10

Date: Tuesday, November 2, 2010 @ 14:31:33 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Oops. Fix typo. -----------------+ release-20c.txt | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) Index: src/general-info/release-20c.txt diff -u src/general-info/release-20c.txt:1.8 src/general-info/release-20c.txt:1.9 --- src/general-info/release-20c.txt:1.8 Tue Nov 2 14:31:07 2010 +++ src/general-info/release-20c.txt Tue Nov 2 14:31:33 2010 @@ -66,8 +66,8 @@ correctly. The normalization test now passes. - REALPART and IMAGPART no longer incorrectly returns 0 instead of the correct part of a complex number. - - The command line parser now correctly handles the case where "-- - is the first command option. + - The command line parser now correctly handles the case where + "--" is the first command option. * Trac Tickets:

1 0

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

02 Nov '10

Date: Tuesday, November 2, 2010 @ 14:31:07 Author: rtoy Path: /project/cmucl/cvsroot/src/general-info Modified: release-20c.txt Update from logs. -----------------+ 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.7 src/general-info/release-20c.txt:1.8 --- src/general-info/release-20c.txt:1.7 Wed Oct 27 20:03:25 2010 +++ src/general-info/release-20c.txt Tue Nov 2 14:31:07 2010 @@ -66,6 +66,8 @@ correctly. The normalization test now passes. - REALPART and IMAGPART no longer incorrectly returns 0 instead of the correct part of a complex number. + - The command line parser now correctly handles the case where "-- + is the first command option. * Trac Tickets:

1 0

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

02 Nov '10

Date: Tuesday, November 2, 2010 @ 14:30:04 Author: rtoy Path: /project/cmucl/cvsroot/src/code Modified: commandline.lisp Command line processing didn't handle -- properly if it is the first option. Bug noted by Didier Verna, cmucl-help, 2010-11-02. ------------------+ commandline.lisp | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) Index: src/code/commandline.lisp diff -u src/code/commandline.lisp:1.25 src/code/commandline.lisp:1.26 --- src/code/commandline.lisp:1.25 Wed Jul 14 09:19:03 2010 +++ src/code/commandline.lisp Tue Nov 2 14:30:04 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/commandline.lisp,v 1.25 2010-07-14 13:19:03 rtoy Rel $") + "$Header: /project/cmucl/cvsroot/src/code/commandline.lisp,v 1.26 2010-11-02 18:30:04 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -93,6 +93,15 @@ (return nil)) (push str *command-line-words*)) (setq str (pop cmd-strings))) + + (when (string= str "--") + ;; Handle the special case where -- is the first option. The + ;; code below interprets that incorrectly and I (rtoy) don't + ;; want to mess with that, so just set up + ;; *command-line-application-arguments* and return. + (setf *command-line-application-arguments* cmd-strings) + (return-from process-command-strings nil)) + ;; Set command line switches. ;; (loop

1 0

[cmucl-cvs] CMUCL commit: cmucl-www/cmucl-www/www (download.html)
by Raymond Toy 01 Nov '10

01 Nov '10

Date: Monday, November 1, 2010 @ 13:09:21 Author: rtoy Path: /project/cmucl/cvsroot/cmucl-www/cmucl-www/www Modified: download.html Add links for 2010-11 downloads. ---------------+ download.html | 64 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 64 insertions(+) Index: cmucl-www/cmucl-www/www/download.html diff -u cmucl-www/cmucl-www/www/download.html:1.25 cmucl-www/cmucl-www/www/download.html:1.26 --- cmucl-www/cmucl-www/www/download.html:1.25 Tue Oct 26 10:17:25 2010 +++ cmucl-www/cmucl-www/www/download.html Mon Nov 1 13:09:21 2010 @@ -92,6 +92,70 @@ </tr> <tr> + <th>2010-11</th> + <td> + <ul> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/cmucl-2010…">Unicode</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/cmucl-2010…">Unicode extras</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/cmucl-2010…">Non-Unicode</a></li> + <li><a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/cmucl-2010…">Non-Unicode extras</a></li> + </ul> + </td> + <td> + <ul> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/cmucl-2010…">Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/cmucl-2010…">Unicode extras</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/cmucl-2010…">Non-Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/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/11/cmucl-2010…">Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/cmucl-2010…">Unicode extras</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/cmucl-2010…">Non-Unicode</a></li> + <li> <a href="http://common-lisp.net/project/cmucl/downloads/snapshots/2010/11/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/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> + </ul> + </td> + </tr> + + <tr> <th>20b</th> <td> <ul>

1 0