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

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

23 Aug '11

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

1 0

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

21 Aug '11

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

1 0

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

21 Aug '11

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

1 0